Rename main_thread to main_thread_id and simplify
[emacs.git] / lisp / ffap.el
blob99bb65faafe1f8969859d401124a93464b3e3ae5
1 ;;; ffap.el --- find file (or url) at point
3 ;; Copyright (C) 1995-1997, 2000-2016 Free Software Foundation, Inc.
5 ;; Author: Michelangelo Grigni <mic@mathcs.emory.edu>
6 ;; Maintainer: emacs-devel@gnu.org
7 ;; Created: 29 Mar 1993
8 ;; Keywords: files, hypermedia, matching, mouse, convenience
9 ;; X-URL: ftp://ftp.mathcs.emory.edu/pub/mic/emacs/
11 ;; This file is part of GNU Emacs.
13 ;; GNU Emacs is free software: you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation, either version 3 of the License, or
16 ;; (at your option) any later version.
18 ;; GNU Emacs is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
27 ;;; Commentary:
29 ;; Command find-file-at-point replaces find-file. With a prefix, it
30 ;; behaves exactly like find-file. Without a prefix, it first tries
31 ;; to guess a default file or URL from the text around the point
32 ;; (`ffap-require-prefix' swaps these behaviors). This is useful for
33 ;; following references in situations such as mail or news buffers,
34 ;; README's, MANIFEST's, and so on. Submit bugs or suggestions with
35 ;; M-x ffap-bug.
37 ;; For the default installation, add this line to your init file:
39 ;; (ffap-bindings) ; do default key bindings
41 ;; ffap-bindings makes the following global key bindings:
43 ;; C-x C-f find-file-at-point (abbreviated as ffap)
44 ;; C-x C-r ffap-read-only
45 ;; C-x C-v ffap-alternate-file
47 ;; C-x d dired-at-point
48 ;; C-x C-d ffap-list-directory
50 ;; C-x 4 f ffap-other-window
51 ;; C-x 4 r ffap-read-only-other-window
52 ;; C-x 4 d ffap-dired-other-window
54 ;; C-x 5 f ffap-other-frame
55 ;; C-x 5 r ffap-read-only-other-frame
56 ;; C-x 5 d ffap-dired-other-frame
58 ;; S-mouse-3 ffap-at-mouse
59 ;; C-S-mouse-3 ffap-menu
61 ;; ffap-bindings also adds hooks to make the following local bindings
62 ;; in vm, gnus, and rmail:
64 ;; M-l ffap-next, or ffap-gnus-next in gnus (l == "link")
65 ;; M-m ffap-menu, or ffap-gnus-menu in gnus (m == "menu")
67 ;; If you do not like these bindings, modify the variable
68 ;; `ffap-bindings', or write your own.
70 ;; If you use ange-ftp, browse-url, complete, efs, or w3, it is best
71 ;; to load or autoload them before ffap. If you use ff-paths, load it
72 ;; afterwards. Try apropos {C-h a ffap RET} to get a list of the many
73 ;; option variables. In particular, if ffap is slow, try these:
75 ;; (setq ffap-alist nil) ; faster, dumber prompting
76 ;; (setq ffap-machine-p-known 'accept) ; no pinging
77 ;; (setq ffap-url-regexp nil) ; disable URL features in ffap
78 ;; (setq ffap-shell-prompt-regexp nil) ; disable shell prompt stripping
80 ;; ffap uses `browse-url' (if found, else `w3-fetch') to fetch URL's.
81 ;; For a hairier `ffap-url-fetcher', try ffap-url.el (same ftp site).
82 ;; Also, you can add `ffap-menu-rescan' to various hooks to fontify
83 ;; the file and URL references within a buffer.
86 ;;; Change Log:
88 ;; The History and Contributors moved to ffap.LOG (same ftp site),
89 ;; which also has some old examples and commentary from ffap 1.5.
92 ;;; Todo list:
93 ;; * let "/dir/file#key" jump to key (tag or regexp) in /dir/file
94 ;; * find file of symbol if TAGS is loaded (like above)
95 ;; * break long menus into multiple panes (like imenu?)
96 ;; * notice node in "(dired)Virtual Dired" (quotes, parentheses, whitespace)
97 ;; * notice "machine.dom blah blah blah dir/file" (how?)
98 ;; * as w3 becomes standard, rewrite to rely more on its functions
99 ;; * regexp options for ffap-string-at-point, like font-lock (MCOOK)
100 ;; * v19: could replace `ffap-locate-file' with a quieter `locate-library'
101 ;; * handle "$(VAR)" in Makefiles
102 ;; * use the font-lock machinery
105 ;;; Code:
107 (require 'url-parse)
108 (require 'thingatpt)
110 (define-obsolete-variable-alias 'ffap-version 'emacs-version "23.2")
112 (defgroup ffap nil
113 "Find file or URL at point."
114 ;; Dead 2009/07/05.
115 ;; :link '(url-link :tag "URL" "ftp://ftp.mathcs.emory.edu/pub/mic/emacs/")
116 :group 'matching
117 :group 'convenience)
119 ;; The code is organized in pages, separated by formfeed characters.
120 ;; See the next two pages for standard customization ideas.
123 ;;; User Variables:
125 (defun ffap-symbol-value (sym &optional default)
126 "Return value of symbol SYM, if bound, or DEFAULT otherwise."
127 (if (boundp sym) (symbol-value sym) default))
129 (defcustom ffap-shell-prompt-regexp
130 ;; This used to test for some shell prompts that don't have a space
131 ;; after them. The common root shell prompt (#) is not listed since it
132 ;; also doubles up as a valid URL character.
133 "[$%><]*"
134 "Paths matching this regexp are stripped off the shell prompt.
135 If nil, ffap doesn't do shell prompt stripping."
136 :type '(choice (const :tag "Disable" nil)
137 (const :tag "Standard" "[$%><]*")
138 regexp)
139 :group 'ffap)
141 (defcustom ffap-ftp-regexp "\\`/[^/:]+:"
142 "File names matching this regexp are treated as remote ffap.
143 If nil, ffap neither recognizes nor generates such names."
144 :type '(choice (const :tag "Disable" nil)
145 (const :tag "Standard" "\\`/[^/:]+:")
146 regexp)
147 :group 'ffap)
149 (defcustom ffap-url-unwrap-local t
150 "If non-nil, convert some URLs to local file names before prompting.
151 Only \"file:\" and \"ftp:\" URLs are converted, and only if they
152 do not specify a host, or the host is either \"localhost\" or
153 equal to `system-name'."
154 :type 'boolean
155 :group 'ffap)
157 (defcustom ffap-url-unwrap-remote '("ftp")
158 "If non-nil, convert URLs to remote file names before prompting.
159 If the value is a list of strings, that specifies a list of URL
160 schemes (e.g. \"ftp\"); in that case, only convert those URLs."
161 :type '(choice (repeat string) boolean)
162 :group 'ffap
163 :version "24.3")
165 (defcustom ffap-lax-url nil
166 "If non-nil, allow lax URL matching."
167 :type 'boolean
168 :group 'ffap
169 :version "25.1")
171 (defcustom ffap-ftp-default-user "anonymous"
172 "User name in FTP file names generated by `ffap-host-to-path'.
173 Note this name may be omitted if it equals the default
174 \(either `efs-default-user' or `ange-ftp-default-user')."
175 :type 'string
176 :group 'ffap)
178 (defcustom ffap-rfs-regexp
179 ;; Remote file access built into file system? HP rfa or Andrew afs:
180 "\\`/\\(afs\\|net\\)/."
181 ;; afs only: (and (file-exists-p "/afs") "\\`/afs/.")
182 "Matching file names are treated as remote. Use nil to disable."
183 :type 'regexp
184 :group 'ffap)
186 (defvar ffap-url-regexp
187 (concat
188 "\\("
189 "news\\(post\\)?:\\|mailto:\\|file:" ; no host ok
190 "\\|"
191 "\\(ftp\\|https?\\|telnet\\|gopher\\|www\\|wais\\)://" ; needs host
192 "\\)")
193 "Regexp matching the beginning of a URI, for ffap.
194 If the value is nil, disable URL-matching features in ffap.")
196 (defcustom ffap-foo-at-bar-prefix "mailto"
197 "Presumed URL prefix type of strings like \"<foo.9z@bar>\".
198 Sensible values are nil, \"news\", or \"mailto\"."
199 :type '(choice (const "mailto")
200 (const "news")
201 (const :tag "Disable" nil)
202 ;; string -- possible, but not really useful
204 :group 'ffap)
206 (defvar ffap-max-region-length 1024
207 "Maximum active region length.
208 When the region is active and larger than this value,
209 `ffap-string-at-point' returns an empty string.")
212 ;;; Peanut Gallery (More User Variables):
214 ;; Users of ffap occasionally suggest new features. If I consider
215 ;; those features interesting but not clear winners (a matter of
216 ;; personal taste) I try to leave options to enable them. Read
217 ;; through this section for features that you like, put an appropriate
218 ;; enabler in your init file.
220 (defcustom ffap-dired-wildcards "[*?][^/]*\\'"
221 "A regexp matching filename wildcard characters, or nil.
223 If `find-file-at-point' gets a filename matching this pattern,
224 and `ffap-pass-wildcards-to-dired' is nil, it passes it on to
225 `find-file' with non-nil WILDCARDS argument, which expands
226 wildcards and visits multiple files. To visit a file whose name
227 contains wildcard characters you can suppress wildcard expansion
228 by setting `find-file-wildcards'. If `find-file-at-point' gets a
229 filename matching this pattern and `ffap-pass-wildcards-to-dired'
230 is non-nil, it passes it on to `dired'.
232 If `dired-at-point' gets a filename matching this pattern,
233 it passes it on to `dired'."
234 :type '(choice (const :tag "Disable" nil)
235 (const :tag "Enable" "[*?][^/]*\\'")
236 ;; regexp -- probably not useful
238 :group 'ffap)
240 (defcustom ffap-pass-wildcards-to-dired nil
241 "If non-nil, pass filenames matching `ffap-dired-wildcards' to Dired."
242 :type 'boolean
243 :group 'ffap)
245 (defcustom ffap-newfile-prompt nil
246 ;; Suggestion from RHOGEE, 11 Jul 1994. Disabled, I think this is
247 ;; better handled by `find-file-not-found-hooks'.
248 "Whether `find-file-at-point' prompts about a nonexistent file."
249 :type 'boolean
250 :group 'ffap)
252 (defcustom ffap-require-prefix nil
253 ;; Suggestion from RHOGEE, 20 Oct 1994.
254 "If set, reverses the prefix argument to `find-file-at-point'.
255 This is nil so neophytes notice ffap. Experts may prefer to disable
256 ffap most of the time."
257 :type 'boolean
258 :group 'ffap)
260 (defcustom ffap-file-finder 'find-file
261 "The command called by `find-file-at-point' to find a file."
262 :type 'function
263 :group 'ffap
264 :risky t)
266 (defcustom ffap-directory-finder 'dired
267 "The command called by `dired-at-point' to find a directory."
268 :type 'function
269 :group 'ffap
270 :risky t)
272 (defcustom ffap-url-fetcher 'browse-url
273 "A function of one argument, called by ffap to fetch an URL.
274 For a fancy alternative, get `ffap-url.el'."
275 :type '(choice (const browse-url)
276 function)
277 :group 'ffap
278 :risky t)
280 (defcustom ffap-next-regexp
281 ;; If you want ffap-next to find URL's only, try this:
282 ;; (and ffap-url-regexp (string-match "\\\\`" ffap-url-regexp)
283 ;; (concat "\\<" (substring ffap-url-regexp 2))))
285 ;; It pays to put a big fancy regexp here, since ffap-guesser is
286 ;; much more time-consuming than regexp searching:
287 "[/:.~[:alpha:]]/\\|@[[:alpha:]][-[:alnum:]]*\\."
288 "Regular expression governing movements of `ffap-next'."
289 :type 'regexp
290 :group 'ffap)
292 (defcustom dired-at-point-require-prefix nil
293 "If non-nil, reverse the prefix argument to `dired-at-point'.
294 This is nil so neophytes notice ffap. Experts may prefer to
295 disable ffap most of the time."
296 :type 'boolean
297 :group 'ffap
298 :version "20.3")
301 ;;; Compatibility:
303 ;; This version of ffap supports only the Emacs it is distributed in.
304 ;; See the ftp site for a more general version. The following
305 ;; functions are necessary "leftovers" from the more general version.
307 (defun ffap-mouse-event () ; current mouse event, or nil
308 (and (listp last-nonmenu-event) last-nonmenu-event))
309 (defun ffap-event-buffer (event)
310 (window-buffer (car (event-start event))))
313 ;;; Find Next Thing in buffer (`ffap-next'):
315 ;; Original ffap-next-url (URL's only) from RPECK 30 Mar 1995. Since
316 ;; then, broke it up into ffap-next-guess (noninteractive) and
317 ;; ffap-next (a command). It now work on files as well as url's.
319 (defvar ffap-next-guess nil
320 "Last value returned by `ffap-next-guess'.")
322 (defvar ffap-string-at-point-region '(1 1)
323 "List (BEG END), last region returned by the function `ffap-string-at-point'.")
325 (defun ffap-next-guess (&optional back lim)
326 "Move point to next file or URL, and return it as a string.
327 If nothing is found, leave point at limit and return nil.
328 Optional BACK argument makes search backwards.
329 Optional LIM argument limits the search.
330 Only considers strings that match `ffap-next-regexp'."
331 (or lim (setq lim (if back (point-min) (point-max))))
332 (let (guess)
333 (while (not (or guess (eq (point) lim)))
334 (funcall (if back 're-search-backward 're-search-forward)
335 ffap-next-regexp lim 'move)
336 (setq guess (ffap-guesser)))
337 ;; Go to end, so we do not get same guess twice:
338 (goto-char (nth (if back 0 1) ffap-string-at-point-region))
339 (setq ffap-next-guess guess)))
341 ;;;###autoload
342 (defun ffap-next (&optional back wrap)
343 "Search buffer for next file or URL, and run ffap.
344 Optional argument BACK says to search backwards.
345 Optional argument WRAP says to try wrapping around if necessary.
346 Interactively: use a single prefix \\[universal-argument] to search backwards,
347 double prefix to wrap forward, triple to wrap backwards.
348 Actual search is done by the function `ffap-next-guess'."
349 (interactive
350 (cdr (assq (prefix-numeric-value current-prefix-arg)
351 '((1) (4 t) (16 nil t) (64 t t)))))
352 (let ((pt (point))
353 (guess (ffap-next-guess back)))
354 ;; Try wraparound if necessary:
355 (and (not guess) wrap
356 (goto-char (if back (point-max) (point-min)))
357 (setq guess (ffap-next-guess back pt)))
358 (if guess
359 (progn
360 (sit-for 0) ; display point movement
361 (find-file-at-point (ffap-prompter guess)))
362 (goto-char pt) ; restore point
363 (message "No %sfiles or URL's found"
364 (if wrap "" "more ")))))
366 (defun ffap-next-url (&optional back wrap)
367 "Like `ffap-next', but search with `ffap-url-regexp'."
368 (interactive)
369 (let ((ffap-next-regexp ffap-url-regexp))
370 (if (called-interactively-p 'interactive)
371 (call-interactively 'ffap-next)
372 (ffap-next back wrap))))
375 ;;; Machines (`ffap-machine-p'):
377 ;; I cannot decide a "best" strategy here, so these are variables. In
378 ;; particular, if `Pinging...' is broken or takes too long on your
379 ;; machine, try setting these all to accept or reject.
380 (defcustom ffap-machine-p-local 'reject ; this happens often
381 "What `ffap-machine-p' does with hostnames that have no domain.
382 Value should be a symbol, one of `ping', `accept', and `reject'."
383 :type '(choice (const ping)
384 (const accept)
385 (const reject))
386 :group 'ffap)
387 (defcustom ffap-machine-p-known 'ping ; `accept' for higher speed
388 "What `ffap-machine-p' does with hostnames that have a known domain.
389 Value should be a symbol, one of `ping', `accept', and `reject'.
390 See `mail-extr.el' for the known domains."
391 :type '(choice (const ping)
392 (const accept)
393 (const reject))
394 :group 'ffap)
395 (defcustom ffap-machine-p-unknown 'reject
396 "What `ffap-machine-p' does with hostnames that have an unknown domain.
397 Value should be a symbol, one of `ping', `accept', and `reject'.
398 See `mail-extr.el' for the known domains."
399 :type '(choice (const ping)
400 (const accept)
401 (const reject))
402 :group 'ffap)
404 (defun ffap-what-domain (domain)
405 ;; Like what-domain in mail-extr.el, returns string or nil.
406 (require 'mail-extr)
407 (let ((ob (or (ffap-symbol-value 'mail-extr-all-top-level-domains)
408 (ffap-symbol-value 'all-top-level-domains)))) ; XEmacs
409 (and ob (get (intern-soft (downcase domain) ob) 'domain-name))))
411 (defun ffap-machine-p (host &optional service quiet strategy)
412 "Decide whether HOST is the name of a real, reachable machine.
413 Depending on the domain (none, known, or unknown), follow the strategy
414 named by the variable `ffap-machine-p-local', `ffap-machine-p-known',
415 or `ffap-machine-p-unknown'. Pinging uses `open-network-stream'.
416 Optional SERVICE specifies the port used (default \"discard\").
417 Optional QUIET flag suppresses the \"Pinging...\" message.
418 Optional STRATEGY overrides the three variables above.
419 Returned values:
420 t means that HOST answered.
421 `accept' means the relevant variable told us to accept.
422 \"mesg\" means HOST exists, but does not respond for some reason."
423 ;; Try some (Emory local):
424 ;; (ffap-machine-p "ftp" nil nil 'ping)
425 ;; (ffap-machine-p "nonesuch" nil nil 'ping)
426 ;; (ffap-machine-p "ftp.mathcs.emory.edu" nil nil 'ping)
427 ;; (ffap-machine-p "mathcs" 5678 nil 'ping)
428 ;; (ffap-machine-p "foo.bonk" nil nil 'ping)
429 ;; (ffap-machine-p "foo.bonk.com" nil nil 'ping)
430 (if (or (string-match "[^-[:alnum:].]" host) ; Invalid chars (?)
431 (not (string-match "[^0-9]" host))) ; 1: a number? 2: quick reject
433 (let* ((domain
434 (and (string-match "\\.[^.]*$" host)
435 (downcase (substring host (1+ (match-beginning 0))))))
436 (what-domain (if domain (ffap-what-domain domain) "Local")))
437 (or strategy
438 (setq strategy
439 (cond ((not domain) ffap-machine-p-local)
440 ((not what-domain) ffap-machine-p-unknown)
441 (t ffap-machine-p-known))))
442 (cond
443 ((eq strategy 'accept) 'accept)
444 ((eq strategy 'reject) nil)
445 ((not (fboundp 'open-network-stream)) nil)
446 ;; assume (eq strategy 'ping)
448 (or quiet
449 (if (stringp what-domain)
450 (message "Pinging %s (%s)..." host what-domain)
451 (message "Pinging %s ..." host)))
452 (condition-case error
453 (progn
454 (delete-process
455 (open-network-stream
456 "ffap-machine-p" nil host (or service "discard")))
458 (error
459 (let ((mesg (car (cdr error))))
460 (cond
461 ;; v18:
462 ((string-match "\\(^Unknown host\\|Name or service not known$\\)"
463 mesg) nil)
464 ((string-match "not responding$" mesg) mesg)
465 ;; v19:
466 ;; (file-error "connection failed" "permission denied"
467 ;; "nonesuch" "ffap-machine-p")
468 ;; (file-error "connection failed" "host is unreachable"
469 ;; "gopher.house.gov" "ffap-machine-p")
470 ;; (file-error "connection failed" "address already in use"
471 ;; "ftp.uu.net" "ffap-machine-p")
472 ((equal mesg "connection failed")
473 (if (string= (downcase (nth 2 error)) "permission denied")
474 nil ; host does not exist
475 ;; Other errors mean the host exists:
476 (nth 2 error)))
477 ;; Could be "Unknown service":
478 (t (signal (car error) (cdr error))))))))))))
481 ;;; Possibly Remote Resources:
483 (defun ffap-replace-file-component (fullname name)
484 "In remote FULLNAME, replace path with NAME. May return nil."
485 ;; Use efs if loaded, but do not load it otherwise.
486 (if (fboundp 'efs-replace-path-component)
487 (funcall 'efs-replace-path-component fullname name)
488 (and (stringp fullname)
489 (stringp name)
490 (concat (file-remote-p fullname) name))))
491 ;; (ffap-replace-file-component "/who@foo.com:/whatever" "/new")
493 (defun ffap-file-suffix (file)
494 "Return trailing `.foo' suffix of FILE, or nil if none."
495 (let ((pos (string-match "\\.[^./]*\\'" file)))
496 (and pos (substring file pos nil))))
498 (defvar ffap-compression-suffixes '(".gz" ".Z") ; .z is mostly dead
499 "List of suffixes tried by `ffap-file-exists-string'.")
501 (defun ffap-file-exists-string (file &optional nomodify)
502 ;; Early jka-compr versions modified file-exists-p to return the
503 ;; filename, maybe modified by adding a suffix like ".gz". That
504 ;; broke the interface of file-exists-p, so it was later dropped.
505 ;; Here we document and simulate the old behavior.
506 "Return FILE (maybe modified) if the file exists, else nil.
507 When using jka-compr (a.k.a. `auto-compression-mode'), the returned
508 name may have a suffix added from `ffap-compression-suffixes'.
509 The optional NOMODIFY argument suppresses the extra search."
510 (cond
511 ((not file) nil) ; quietly reject nil
512 ((file-exists-p file) file) ; try unmodified first
513 ;; three reasons to suppress search:
514 (nomodify nil)
515 ((not (rassq 'jka-compr-handler file-name-handler-alist)) nil)
516 ((member (ffap-file-suffix file) ffap-compression-suffixes) nil)
517 (t ; ok, do the search
518 (let ((list ffap-compression-suffixes) try ret)
519 (while list
520 (if (file-exists-p (setq try (concat file (car list))))
521 (setq ret try list nil)
522 (setq list (cdr list))))
523 ret))))
525 (defun ffap-file-remote-p (filename)
526 "If FILENAME looks remote, return it (maybe slightly improved)."
527 ;; (ffap-file-remote-p "/user@foo.bar.com:/pub")
528 ;; (ffap-file-remote-p "/cssun.mathcs.emory.edu://dir")
529 ;; (ffap-file-remote-p "/ffap.el:80")
530 (or (and ffap-ftp-regexp
531 (string-match ffap-ftp-regexp filename)
532 ;; Convert "/host.com://dir" to "/host:/dir", to handle a dying
533 ;; practice of advertising ftp files as "host.dom://filename".
534 (if (string-match "//" filename)
535 ;; (replace-match "/" nil nil filename)
536 (concat (substring filename 0 (1+ (match-beginning 0)))
537 (substring filename (match-end 0)))
538 filename))
539 (and ffap-rfs-regexp
540 (string-match ffap-rfs-regexp filename)
541 filename)))
543 (defun ffap-machine-at-point ()
544 "Return machine name at point if it exists, or nil."
545 (let ((mach (ffap-string-at-point 'machine)))
546 (and (ffap-machine-p mach) mach)))
548 (defsubst ffap-host-to-filename (host)
549 "Convert HOST to something like \"/USER@HOST:\" or \"/HOST:\".
550 Looks at `ffap-ftp-default-user', returns \"\" for \"localhost\"."
551 (if (equal host "localhost")
553 (let ((user ffap-ftp-default-user))
554 ;; Avoid including the user if it is same as default:
555 (if (or (equal user (ffap-symbol-value 'ange-ftp-default-user))
556 (equal user (ffap-symbol-value 'efs-default-user)))
557 (setq user nil))
558 (concat "/" user (and user "@") host ":"))))
560 (defun ffap-fixup-machine (mach)
561 ;; Convert a hostname into an url, an ftp file name, or nil.
562 (cond
563 ((not (and ffap-url-regexp (stringp mach))) nil)
564 ;; gopher.well.com
565 ((string-match "\\`gopher[-.]" mach) ; or "info"?
566 (concat "gopher://" mach "/"))
567 ;; www.ncsa.uiuc.edu
568 ((and (string-match "\\`w\\(ww\\|eb\\)[-.]" mach))
569 (concat "http://" mach "/"))
570 ;; More cases? Maybe "telnet:" for archie?
571 (ffap-ftp-regexp (ffap-host-to-filename mach))
574 (defvaralias 'ffap-newsgroup-regexp 'thing-at-point-newsgroup-regexp)
575 (defvaralias 'ffap-newsgroup-heads 'thing-at-point-newsgroup-heads)
576 (defalias 'ffap-newsgroup-p 'thing-at-point-newsgroup-p)
578 (defun ffap-url-p (string)
579 "If STRING looks like an URL, return it (maybe improved), else nil."
580 (when (and (stringp string) ffap-url-regexp)
581 (let* ((case-fold-search t)
582 (match (string-match ffap-url-regexp string)))
583 (cond ((eq match 0) string)
584 (match (substring string match))))))
586 ;; Broke these out of ffap-fixup-url, for use of ffap-url package.
587 (defun ffap-url-unwrap-local (url)
588 "Return URL as a local file name, or nil."
589 (let* ((obj (url-generic-parse-url url))
590 (host (url-host obj))
591 (filename (car (url-path-and-query obj))))
592 (when (and (member (url-type obj) '("ftp" "file"))
593 (member host `("" "localhost" ,(system-name))))
594 ;; On Windows, "file:///C:/foo" should unwrap to "C:/foo"
595 (if (and (memq system-type '(ms-dos windows-nt cygwin))
596 (string-match "\\`/[a-zA-Z]:" filename))
597 (substring filename 1)
598 filename))))
600 (defun ffap-url-unwrap-remote (url)
601 "Return URL as a remote file name, or nil."
602 (let* ((obj (url-generic-parse-url url))
603 (scheme (url-type obj))
604 (valid-schemes (if (listp ffap-url-unwrap-remote)
605 ffap-url-unwrap-remote
606 '("ftp")))
607 (host (url-host obj))
608 (port (url-port-if-non-default obj))
609 (user (url-user obj))
610 (filename (car (url-path-and-query obj))))
611 (when (and (member scheme valid-schemes)
612 (string-match "\\`[a-zA-Z][-a-zA-Z0-9+.]*\\'" scheme)
613 (not (equal host "")))
614 (concat "/" scheme ":"
615 (if user (concat user "@"))
616 host
617 (if port (concat "#" (number-to-string port)))
618 ":" filename))))
620 (defun ffap-fixup-url (url)
621 "Clean up URL and return it, maybe as a file name."
622 (cond
623 ((not (stringp url)) nil)
624 ((and ffap-url-unwrap-local (ffap-url-unwrap-local url)))
625 ((and ffap-url-unwrap-remote (ffap-url-unwrap-remote url)))
626 (url)))
629 ;;; File Name Handling:
631 ;; The upcoming ffap-alist actions need various utilities to prepare
632 ;; and search directories. Too many features here.
634 ;; (defun ffap-last (l) (while (cdr l) (setq l (cdr l))) l)
635 ;; (defun ffap-splice (func inlist)
636 ;; "Equivalent to (apply 'nconc (mapcar FUNC INLIST)), but less consing."
637 ;; (let* ((head (cons 17 nil)) (last head))
638 ;; (while inlist
639 ;; (setcdr last (funcall func (car inlist)))
640 ;; (setq last (ffap-last last) inlist (cdr inlist)))
641 ;; (cdr head)))
643 (defun ffap-list-env (env &optional empty)
644 "Return a list of strings parsed from environment variable ENV.
645 Optional EMPTY is the default list if (getenv ENV) is undefined, and
646 also is substituted for the first empty-string component, if there is one.
647 Uses `path-separator' to separate the path into substrings."
648 ;; We cannot use parse-colon-path (files.el), since it kills
649 ;; "//" entries using file-name-as-directory.
650 ;; Similar: dired-split, TeX-split-string, and RHOGEE's psg-list-env
651 ;; in ff-paths and bib-cite. The EMPTY arg may help mimic kpathsea.
652 (if (or empty (getenv env)) ; should return something
653 (let ((start 0) match dir ret)
654 (setq env (concat (getenv env) path-separator))
655 (while (setq match (string-match path-separator env start))
656 (setq dir (substring env start match) start (1+ match))
657 ;;(and (file-directory-p dir) (not (member dir ret)) ...)
658 (setq ret (cons dir ret)))
659 (setq ret (nreverse ret))
660 (and empty (setq match (member "" ret))
661 (progn ; allow string or list here
662 (setcdr match (append (cdr-safe empty) (cdr match)))
663 (setcar match (or (car-safe empty) empty))))
664 ret)))
666 (defun ffap-reduce-path (path)
667 "Remove duplicates and non-directories from PATH list."
668 (let (ret tem)
669 (while path
670 (setq tem path path (cdr path))
671 (if (equal (car tem) ".") (setcar tem ""))
672 (or (member (car tem) ret)
673 (not (file-directory-p (car tem)))
674 (progn (setcdr tem ret) (setq ret tem))))
675 (nreverse ret)))
677 (defun ffap-all-subdirs (dir &optional depth)
678 "Return list of all subdirectories under DIR, starting with itself.
679 Directories beginning with \".\" are ignored, and directory symlinks
680 are listed but never searched (to avoid loops).
681 Optional DEPTH limits search depth."
682 (and (file-exists-p dir)
683 (ffap-all-subdirs-loop (expand-file-name dir) (or depth -1))))
685 (defun ffap-all-subdirs-loop (dir depth) ; internal
686 (setq depth (1- depth))
687 (cons dir
688 (and (not (eq depth -1))
689 (apply 'nconc
690 (mapcar
691 (function
692 (lambda (d)
693 (cond
694 ((not (file-directory-p d)) nil)
695 ((file-symlink-p d) (list d))
696 (t (ffap-all-subdirs-loop d depth)))))
697 (directory-files dir t "\\`[^.]")
698 )))))
700 (defvar ffap-kpathsea-depth 1
701 "Bound on depth of subdirectory search in `ffap-kpathsea-expand-path'.
702 Set to 0 to avoid all searching, or nil for no limit.")
704 (defun ffap-kpathsea-expand-path (path)
705 "Replace each \"//\"-suffixed dir in PATH by a list of its subdirs.
706 The subdirs begin with the original directory, and the depth of the
707 search is bounded by `ffap-kpathsea-depth'. This is intended to mimic
708 kpathsea, a library used by some versions of TeX."
709 (apply 'nconc
710 (mapcar
711 (function
712 (lambda (dir)
713 (if (string-match "[^/]//\\'" dir)
714 (ffap-all-subdirs (substring dir 0 -2) ffap-kpathsea-depth)
715 (list dir))))
716 path)))
718 (defun ffap-locate-file (file nosuffix path)
719 ;; The current version of locate-library could almost replace this,
720 ;; except it does not let us override the suffix list. The
721 ;; compression-suffixes search moved to ffap-file-exists-string.
722 "A generic path-searching function.
723 Returns the name of file in PATH, or nil.
724 Optional NOSUFFIX, if nil or t, is like the fourth argument
725 for `load': whether to try the suffixes (\".elc\" \".el\" \"\").
726 If a nonempty list, it is a list of suffixes to try instead.
727 PATH is a list of directories.
729 This uses `ffap-file-exists-string', which may try adding suffixes from
730 `ffap-compression-suffixes'."
731 (if (file-name-absolute-p file)
732 (setq path (list (file-name-directory file))
733 file (file-name-nondirectory file)))
734 (let ((dir-ok (equal "" (file-name-nondirectory file)))
735 (suffixes-to-try
736 (cond
737 ((consp nosuffix) nosuffix)
738 (nosuffix '(""))
739 (t '(".elc" ".el" ""))))
740 suffixes try found)
741 (while path
742 (setq suffixes suffixes-to-try)
743 (while suffixes
744 (setq try (ffap-file-exists-string
745 (expand-file-name
746 (concat file (car suffixes)) (car path))))
747 (if (and try (or dir-ok (not (file-directory-p try))))
748 (setq found try suffixes nil path nil)
749 (setq suffixes (cdr suffixes))))
750 (setq path (cdr path)))
751 found))
754 ;;; Action List (`ffap-alist'):
756 ;; These search actions depend on the major-mode or regexps matching
757 ;; the current name. The little functions and their variables are
758 ;; deferred to the next section, at some loss of "code locality". A
759 ;; good example of featuritis. Trim this list for speed.
761 (defvar ffap-alist
763 ("" . ffap-completable) ; completion, slow on some systems
764 ("\\.info\\'" . ffap-info) ; gzip.info
765 ("\\`info/" . ffap-info-2) ; info/emacs
766 ("\\`[-[:lower:]]+\\'" . ffap-info-3) ; (emacs)Top [only in the parentheses]
767 ("\\.elc?\\'" . ffap-el) ; simple.el, simple.elc
768 (emacs-lisp-mode . ffap-el-mode) ; rmail, gnus, simple, custom
769 ;; (lisp-interaction-mode . ffap-el-mode) ; maybe
770 (finder-mode . ffap-el-mode) ; type {C-h p} and try it
771 (help-mode . ffap-el-mode) ; maybe useful
772 (c++-mode . ffap-c++-mode) ; search ffap-c++-path
773 (cc-mode . ffap-c-mode) ; same
774 ("\\.\\([chCH]\\|cc\\|hh\\)\\'" . ffap-c-mode) ; stdio.h
775 (fortran-mode . ffap-fortran-mode) ; FORTRAN requested by MDB
776 ("\\.[fF]\\'" . ffap-fortran-mode)
777 (tex-mode . ffap-tex-mode) ; search ffap-tex-path
778 (latex-mode . ffap-latex-mode) ; similar
779 ("\\.\\(tex\\|sty\\|doc\\|cls\\)\\'" . ffap-tex)
780 ("\\.bib\\'" . ffap-bib) ; search ffap-bib-path
781 ("\\`\\." . ffap-home) ; .emacs, .bashrc, .profile
782 ("\\`~/" . ffap-lcd) ; |~/misc/ffap.el.Z|
783 ;; This used to have a blank, but ffap-string-at-point doesn't
784 ;; handle blanks.
785 ;; http://lists.gnu.org/archive/html/emacs-devel/2008-01/msg01058.html
786 ("\\`[Rr][Ff][Cc][-#]?\\([0-9]+\\)" ; no $
787 . ffap-rfc) ; "100% RFC2100 compliant"
788 (dired-mode . ffap-dired) ; maybe in a subdirectory
790 "Alist of (KEY . FUNCTION) pairs parsed by `ffap-file-at-point'.
791 If string NAME at point (maybe \"\") is not a file or URL, these pairs
792 specify actions to try creating such a string. A pair matches if either
793 KEY is a symbol, and it equals `major-mode', or
794 KEY is a string, it should match NAME as a regexp.
795 On a match, (FUNCTION NAME) is called and should return a file, an
796 URL, or nil. If nil, search the alist for further matches.")
798 (put 'ffap-alist 'risky-local-variable t)
800 ;; Example `ffap-alist' modifications:
802 ;; (setq ffap-alist ; remove a feature in `ffap-alist'
803 ;; (delete (assoc 'c-mode ffap-alist) ffap-alist))
805 ;; (setq ffap-alist ; add something to `ffap-alist'
806 ;; (cons
807 ;; (cons "^YSN[0-9]+$"
808 ;; (defun ffap-ysn (name)
809 ;; (concat
810 ;; "http://www.physics.uiuc.edu/"
811 ;; "ysn/httpd/htdocs/ysnarchive/issuefiles/"
812 ;; (substring name 3) ".html")))
813 ;; ffap-alist))
816 ;;; Action Definitions:
818 ;; Define various default members of `ffap-alist'.
820 (defun ffap-completable (name)
821 (let* ((dir (or (file-name-directory name) default-directory))
822 (cmp (file-name-completion (file-name-nondirectory name) dir)))
823 (and cmp (concat dir cmp))))
825 (defun ffap-home (name) (ffap-locate-file name t '("~")))
827 (defun ffap-info (name)
828 (ffap-locate-file
829 name '("" ".info")
830 (or (ffap-symbol-value 'Info-directory-list)
831 (ffap-symbol-value 'Info-default-directory-list)
834 (defun ffap-info-2 (name) (ffap-info (substring name 5)))
836 (defun ffap-info-3 (name)
837 ;; This ignores the node! "(emacs)Top" same as "(emacs)Intro"
838 (and (equal (ffap-string-around) "()") (ffap-info name)))
840 (defun ffap-el (name) (ffap-locate-file name t load-path))
842 (defun ffap-el-mode (name)
843 ;; If name == "foo.el" we will skip it, since ffap-el already
844 ;; searched for it once. (This assumes the default ffap-alist.)
845 (and (not (string-match "\\.el\\'" name))
846 (ffap-locate-file name '(".el") load-path)))
848 ;; FIXME this duplicates the logic of Man-header-file-path.
849 ;; There should be a single central variable or function for this.
850 ;; See also (bug#10702):
851 ;; cc-search-directories, semantic-c-dependency-system-include-path,
852 ;; semantic-gcc-setup
853 (defvar ffap-c-path
854 (let ((arch (with-temp-buffer
855 (when (eq 0 (ignore-errors
856 (call-process "gcc" nil '(t nil) nil
857 "-print-multiarch")))
858 (goto-char (point-min))
859 (buffer-substring (point) (line-end-position)))))
860 (base '("/usr/include" "/usr/local/include")))
861 (if (zerop (length arch))
862 base
863 (append base (list (expand-file-name arch "/usr/include")))))
864 "List of directories to search for include files.")
866 (defun ffap-c-mode (name)
867 (ffap-locate-file name t ffap-c-path))
869 (defvar ffap-c++-path
870 (let ((c++-include-dir (with-temp-buffer
871 (when (eq 0 (ignore-errors
872 (call-process "g++" nil t nil "-v")))
873 (goto-char (point-min))
874 (if (re-search-forward "--with-gxx-include-dir=\
875 \\([^[:space:]]+\\)"
876 nil 'noerror)
877 (match-string 1)
878 (when (re-search-forward "gcc version \
879 \\([[:digit:]]+.[[:digit:]]+.[[:digit:]]+\\)"
880 nil 'noerror)
881 (expand-file-name (match-string 1)
882 "/usr/include/c++/")))))))
883 (if c++-include-dir
884 (cons c++-include-dir ffap-c-path)
885 ffap-c-path))
886 "List of directories to search for include files.")
888 (defun ffap-c++-mode (name)
889 (ffap-locate-file name t ffap-c++-path))
891 (defvar ffap-fortran-path '("../include" "/usr/include"))
893 (defun ffap-fortran-mode (name)
894 (ffap-locate-file name t ffap-fortran-path))
896 (defvar ffap-tex-path
897 t ; delayed initialization
898 "Path where `ffap-tex-mode' looks for TeX files.
899 If t, `ffap-tex-init' will initialize this when needed.")
901 (defvar ffap-latex-guess-rules '(("" . ".sty")
902 ("" . ".cls")
903 ("" . ".ltx")
904 ("" . ".tex")
905 ("" . "") ;; in some rare cases the
906 ;; extension is already in
907 ;; the buffer.
908 ("beamertheme" . ".sty")
909 ("beamercolortheme". ".sty")
910 ("beamerfonttheme". ".sty")
911 ("beamerinnertheme". ".sty")
912 ("beameroutertheme". ".sty")
913 ("" . ".ldf"))
914 "List of rules for guessing a filename.
915 Each rule is a cons (PREFIX . SUFFIX) used for guessing a
916 filename from the word at point by prepending PREFIX and
917 appending SUFFIX.")
919 (defun ffap-tex-init ()
920 ;; Compute ffap-tex-path if it is now t.
921 (and (eq t ffap-tex-path)
922 ;; this may be slow, so say something
923 (message "Initializing ffap-tex-path ...")
924 (setq ffap-tex-path
925 (ffap-reduce-path
926 (cons
928 (ffap-kpathsea-expand-path
929 (append
930 (ffap-list-env "TEXINPUTS")
931 ;; (ffap-list-env "BIBINPUTS")
932 (ffap-symbol-value
933 'TeX-macro-global ; AUCTeX
934 '("/usr/local/lib/tex/macros"
935 "/usr/local/lib/tex/inputs")))))))))
937 (defun ffap-tex-mode (name)
938 (ffap-tex-init)
939 (ffap-locate-file name '(".tex" "") ffap-tex-path))
941 (defun ffap-latex-mode (name)
942 "`ffap' function suitable for latex buffers.
943 This uses the program kpsewhich if available. In this case, the
944 variable `ffap-latex-guess-rules' is used for building a filename
945 out of NAME."
946 (cond ((file-exists-p name)
947 name)
948 ((not (executable-find "kpsewhich"))
949 (ffap-tex-init)
950 (ffap-locate-file name '(".cls" ".sty" ".tex" "") ffap-tex-path))
952 (let ((curbuf (current-buffer))
953 (guess-rules ffap-latex-guess-rules)
954 (preferred-suffix-rules '(("input" . ".tex")
955 ("include" . ".tex")
956 ("usepackage" . ".sty")
957 ("RequirePackageWithOptions" . ".sty")
958 ("RequirePackage" . ".sty")
959 ("documentclass" . ".cls")
960 ("documentstyle" . ".cls")
961 ("LoadClass" . ".cls")
962 ("LoadClassWithOptions" . ".cls")
963 ("bibliography" . ".bib")
964 ("addbibresource" . ""))))
965 ;; We now add preferred suffix in front of suffixes.
966 (when
967 ;; The condition is essentially:
968 ;; (assoc (TeX-current-macro)
969 ;; (mapcar 'car preferred-suffix-rules))
970 ;; but (TeX-current-macro) can take time, so we just
971 ;; check if one of the `car' in preferred-suffix-rules
972 ;; is found before point on the current line. It
973 ;; should cover most cases.
974 (save-excursion
975 (re-search-backward (regexp-opt
976 (mapcar 'car preferred-suffix-rules))
977 (point-at-bol)
979 (push (cons "" (cdr (assoc (match-string 0) ; i.e. "(TeX-current-macro)"
980 preferred-suffix-rules)))
981 guess-rules))
982 (with-temp-buffer
983 (let ((process-environment (buffer-local-value
984 'process-environment curbuf))
985 (exec-path (buffer-local-value 'exec-path curbuf)))
986 (apply #'call-process "kpsewhich" nil t nil
987 (mapcar (lambda (rule)
988 (concat (car rule) name (cdr rule)))
989 guess-rules)))
990 (when (< (point-min) (point-max))
991 (buffer-substring (goto-char (point-min)) (point-at-eol))))))))
993 (defun ffap-tex (name)
994 (ffap-tex-init)
995 (ffap-locate-file name t ffap-tex-path))
997 (defvar ffap-bib-path
998 (ffap-list-env "BIBINPUTS"
999 (ffap-reduce-path
1001 ;; a few wild guesses, need better
1002 "/usr/local/lib/tex/macros/bib" ; Solaris?
1003 "/usr/lib/texmf/bibtex/bib" ; Linux?
1004 ))))
1006 (defun ffap-bib (name)
1007 (ffap-locate-file name t ffap-bib-path))
1009 (defun ffap-dired (name)
1010 (let ((pt (point)) try)
1011 (save-excursion
1012 (and (progn
1013 (beginning-of-line)
1014 (looking-at " *[-d]r[-w][-x][-r][-w][-x][-r][-w][-x] "))
1015 (re-search-backward "^ *$" nil t)
1016 (re-search-forward "^ *\\([^ \t\n:]*\\):\n *total " pt t)
1017 (file-exists-p
1018 (setq try
1019 (expand-file-name
1020 name
1021 (buffer-substring
1022 (match-beginning 1) (match-end 1)))))
1023 try))))
1025 ;; Maybe a "Lisp Code Directory" reference:
1026 (defun ffap-lcd (name)
1027 ;; FIXME: Is this still in use?
1028 (and
1030 ;; lisp-dir-apropos output buffer:
1031 (string-match "Lisp Code Dir" (buffer-name))
1032 ;; Inside an LCD entry like |~/misc/ffap.el.Z|,
1033 ;; or maybe the holy LCD-Datafile itself:
1034 (member (ffap-string-around) '("||" "|\n")))
1035 (concat
1036 ;; lispdir.el may not be loaded yet:
1037 (ffap-host-to-filename
1038 (ffap-symbol-value 'elisp-archive-host
1039 "archive.cis.ohio-state.edu"))
1040 (file-name-as-directory
1041 (ffap-symbol-value 'elisp-archive-directory
1042 "/pub/gnu/emacs/elisp-archive/"))
1043 (substring name 2))))
1045 (defcustom ffap-rfc-path
1046 (concat (ffap-host-to-filename "ftp.rfc-editor.org") "/in-notes/rfc%s.txt")
1047 "A `format' string making a filename for RFC documents.
1048 This can be an ange-ftp or Tramp remote filename to download, or
1049 a local filename if you have full set of RFCs locally. See also
1050 `ffap-rfc-directories'."
1051 :type 'string
1052 :version "23.1"
1053 :group 'ffap)
1055 (defcustom ffap-rfc-directories nil
1056 "A list of directories to look for RFC files.
1057 If a given RFC isn't in these then `ffap-rfc-path' is offered."
1058 :type '(repeat directory)
1059 :version "23.1"
1060 :group 'ffap)
1062 (defun ffap-rfc (name)
1063 (let ((num (match-string 1 name)))
1064 (or (ffap-locate-file (format "rfc%s.txt" num) t ffap-rfc-directories)
1065 (format ffap-rfc-path num))))
1068 ;;; At-Point Functions:
1070 (defvar ffap-string-at-point-mode-alist
1072 ;; The default, used when the `major-mode' is not found.
1073 ;; Slightly controversial decisions:
1074 ;; * strip trailing "@" and ":"
1075 ;; * no commas (good for latex)
1076 (file "--:\\\\${}+<>@-Z_[:alpha:]~*?" "<@" "@>;.,!:")
1077 ;; An url, or maybe a email/news message-id:
1078 (url "--:=&?$+@-Z_[:alpha:]~#,%;*()!'" "^[0-9a-zA-Z]" ":;.,!?")
1079 ;; Find a string that does *not* contain a colon:
1080 (nocolon "--9$+<>@-Z_[:alpha:]~" "<@" "@>;.,!?")
1081 ;; A machine:
1082 (machine "-[:alnum:]." "" ".")
1083 ;; Mathematica paths: allow backquotes
1084 (math-mode ",-:$+<>@-Z_[:lower:]~`" "<" "@>;.,!?`:")
1085 ;; (La)TeX: don't allow braces
1086 (latex-mode "--:\\\\$+<>@-Z_[:alpha:]~*?" "<@" "@>;.,!:")
1087 (tex-mode "--:\\\\$+<>@-Z_[:alpha:]~*?" "<@" "@>;.,!:")
1089 "Alist of (MODE CHARS BEG END), where MODE is a symbol,
1090 possibly a major-mode name, or one of the symbols
1091 `file', `url', `machine', and `nocolon'.
1092 Function `ffap-string-at-point' uses the data fields as follows:
1093 1. find a maximal string of CHARS around point,
1094 2. strip BEG chars before point from the beginning,
1095 3. strip END chars after point from the end.
1096 The arguments CHARS, BEG and END are handled as described in
1097 `skip-chars-forward'.")
1099 (defvar ffap-string-at-point nil
1100 ;; Added at suggestion of RHOGEE (for ff-paths), 7/24/95.
1101 "Last string returned by the function `ffap-string-at-point'.")
1103 (defun ffap-string-at-point (&optional mode)
1104 "Return a string of characters from around point.
1105 MODE (defaults to value of `major-mode') is a symbol used to look up
1106 string syntax parameters in `ffap-string-at-point-mode-alist'.
1107 If MODE is not found, we use `file' instead of MODE.
1108 If the region is active, return a string from the region.
1109 Set the variable `ffap-string-at-point' and the variable
1110 `ffap-string-at-point-region'.
1111 When the region is active and larger than `ffap-max-region-length',
1112 return an empty string, and set `ffap-string-at-point-region' to '(1 1)."
1113 (let* ((args
1114 (cdr
1115 (or (assq (or mode major-mode) ffap-string-at-point-mode-alist)
1116 (assq 'file ffap-string-at-point-mode-alist))))
1117 (pt (point))
1118 (beg (if (use-region-p)
1119 (region-beginning)
1120 (save-excursion
1121 (skip-chars-backward (car args))
1122 (skip-chars-forward (nth 1 args) pt)
1123 (point))))
1124 (end (if (use-region-p)
1125 (region-end)
1126 (save-excursion
1127 (skip-chars-forward (car args))
1128 (skip-chars-backward (nth 2 args) pt)
1129 (point))))
1130 (region-len (- (max beg end) (min beg end))))
1131 (if (and (natnump ffap-max-region-length)
1132 (< region-len ffap-max-region-length)) ; Bug#25243.
1133 (setf ffap-string-at-point-region (list beg end)
1134 ffap-string-at-point
1135 (buffer-substring-no-properties beg end))
1136 (setf ffap-string-at-point-region (list 1 1)
1137 ffap-string-at-point ""))))
1139 (defun ffap-string-around ()
1140 ;; Sometimes useful to decide how to treat a string.
1141 "Return string of two chars around last result of function
1142 `ffap-string-at-point'.
1143 Assumes the buffer has not changed."
1144 (save-excursion
1145 (format "%c%c"
1146 (progn
1147 (goto-char (car ffap-string-at-point-region))
1148 (preceding-char)) ; maybe 0
1149 (progn
1150 (goto-char (nth 1 ffap-string-at-point-region))
1151 (following-char)) ; maybe 0
1154 (defun ffap-copy-string-as-kill (&optional mode)
1155 ;; Requested by MCOOK. Useful?
1156 "Call function `ffap-string-at-point', and copy result to `kill-ring'."
1157 (interactive)
1158 (let ((str (ffap-string-at-point mode)))
1159 (if (equal "" str)
1160 (message "No string found around point.")
1161 (kill-new str)
1162 ;; Older: (apply 'copy-region-as-kill ffap-string-at-point-region)
1163 (message "Copied to kill ring: %s" str))))
1165 ;; External.
1166 (declare-function w3-view-this-url "ext:w3" (&optional no-show))
1168 (defun ffap-url-at-point ()
1169 "Return URL from around point if it exists, or nil.
1171 Sets the variable `ffap-string-at-point-region' to the bounds of URL, if any."
1172 (when ffap-url-regexp
1173 (or (and (eq major-mode 'w3-mode) ; In a w3 buffer button?
1174 (w3-view-this-url t))
1175 (let ((thing-at-point-beginning-of-url-regexp ffap-url-regexp)
1176 (thing-at-point-default-mail-uri-scheme ffap-foo-at-bar-prefix)
1177 val)
1178 (setq val (thing-at-point-url-at-point ffap-lax-url
1179 (if (use-region-p)
1180 (cons (region-beginning)
1181 (region-end)))))
1182 (if val
1183 (let ((bounds (thing-at-point-bounds-of-url-at-point
1184 ffap-lax-url)))
1185 (setq ffap-string-at-point-region
1186 (list (car bounds) (cdr bounds)))))
1187 val))))
1189 (defvar ffap-gopher-regexp
1190 "^.*\\<\\(Type\\|Name\\|Path\\|Host\\|Port\\) *= *\\(.*\\) *$"
1191 "Regexp matching a line in a gopher bookmark (maybe indented).
1192 The two subexpressions are the KEY and VALUE.")
1194 (defun ffap-gopher-at-point ()
1195 "If point is inside a gopher bookmark block, return its URL.
1197 Sets the variable `ffap-string-at-point-region' to the bounds of URL, if any."
1198 ;; `gopher-parse-bookmark' from gopher.el is not so robust
1199 (save-excursion
1200 (beginning-of-line)
1201 (if (looking-at ffap-gopher-regexp)
1202 (progn
1203 (while (and (looking-at ffap-gopher-regexp) (not (bobp)))
1204 (forward-line -1))
1205 (or (looking-at ffap-gopher-regexp) (forward-line 1))
1206 (setq ffap-string-at-point-region (list (point) (point)))
1207 (let ((type "1") path host (port "70"))
1208 (while (looking-at ffap-gopher-regexp)
1209 (let ((var (intern
1210 (downcase
1211 (buffer-substring (match-beginning 1)
1212 (match-end 1)))))
1213 (val (buffer-substring (match-beginning 2)
1214 (match-end 2))))
1215 (set var val)
1216 (forward-line 1)))
1217 (setcdr ffap-string-at-point-region (list (point)))
1218 (if (and path (string-match "^ftp:.*@" path))
1219 (concat "ftp://"
1220 (substring path 4 (1- (match-end 0)))
1221 (substring path (match-end 0)))
1222 (and (= (length type) 1)
1223 host;; (ffap-machine-p host)
1224 (concat "gopher://" host
1225 (if (equal port "70") "" (concat ":" port))
1226 "/" type path))))))))
1228 (defvar ffap-ftp-sans-slash-regexp
1229 (and
1230 ffap-ftp-regexp
1231 ;; Note: by now, we know it is not an url.
1232 ;; Icky regexp avoids: default: 123: foo::bar cs:pub
1233 ;; It does match on: mic@cs: cs:/pub mathcs.emory.edu: (point at end)
1234 "\\`\\([^:@]+@[^:@]+:\\|[^@.:]+\\.[^@:]+:\\|[^:]+:[~/]\\)\\([^:]\\|\\'\\)")
1235 "Strings matching this are coerced to FTP file names by ffap.
1236 That is, ffap just prepends \"/\". Set to nil to disable.")
1238 (defun ffap-file-at-point ()
1239 "Return filename from around point if it exists, or nil.
1240 Existence test is skipped for names that look remote.
1241 If the filename is not obvious, it also tries `ffap-alist',
1242 which may actually result in an URL rather than a filename."
1243 ;; Note: this function does not need to look for url's, just
1244 ;; filenames. On the other hand, it is responsible for converting
1245 ;; a pseudo-url "site.com://dir" to an ftp file name
1246 (let* ((case-fold-search t) ; url prefixes are case-insensitive
1247 (data (match-data))
1248 (string (ffap-string-at-point)) ; uses mode alist
1249 (name
1250 (or (condition-case nil
1251 (and (not (string-match "//" string)) ; foo.com://bar
1252 (substitute-in-file-name string))
1253 (error nil))
1254 string))
1255 (abs (file-name-absolute-p name))
1256 (default-directory default-directory)
1257 (oname name))
1258 (unwind-protect
1259 (cond
1260 ;; Immediate rejects (/ and // and /* are too common in C/C++):
1261 ((member name '("" "/" "//" "/*" ".")) nil)
1262 ;; Immediately test local filenames. If default-directory is
1263 ;; remote, you probably already have a connection.
1264 ((and (not abs) (ffap-file-exists-string name)))
1265 ;; Try stripping off line numbers; good for compilation/grep output.
1266 ((and (not abs) (string-match ":[0-9]" name)
1267 (ffap-file-exists-string (substring name 0 (match-beginning 0)))))
1268 ;; Try stripping off prominent (non-root - #) shell prompts
1269 ;; if the ffap-shell-prompt-regexp is non-nil.
1270 ((and ffap-shell-prompt-regexp
1271 (not abs) (string-match ffap-shell-prompt-regexp name)
1272 (ffap-file-exists-string (substring name (match-end 0)))))
1273 ;; Accept remote names without actual checking (too slow):
1274 ((and abs (ffap-file-remote-p name)))
1275 ;; Ok, not remote, try the existence test even if it is absolute:
1276 ((and abs (ffap-file-exists-string name)))
1277 ;; Try stripping off line numbers.
1278 ((and abs (string-match ":[0-9]" name)
1279 (ffap-file-exists-string (substring name 0 (match-beginning 0)))))
1280 ;; If it contains a colon, get rid of it (and return if exists)
1281 ((and (string-match path-separator name)
1282 (setq name (ffap-string-at-point 'nocolon))
1283 (ffap-file-exists-string name)))
1284 ;; File does not exist, try the alist:
1285 ((let ((alist ffap-alist) tem try case-fold-search)
1286 (while (and alist (not try))
1287 (setq tem (car alist) alist (cdr alist))
1288 (if (or (eq major-mode (car tem))
1289 (and (stringp (car tem))
1290 (string-match (car tem) name)))
1291 (and (setq try
1292 (condition-case nil
1293 (funcall (cdr tem) name)
1294 (error nil)))
1295 (setq try (or
1296 (ffap-url-p try) ; not a file!
1297 (ffap-file-remote-p try)
1298 (ffap-file-exists-string try))))))
1299 try))
1300 ;; Try adding a leading "/" (common omission in ftp file names).
1301 ;; Note that this uses oname, which still has any colon part.
1302 ;; This should have a lower priority than the alist stuff,
1303 ;; else it matches things like "ffap.el:1234:56:Warning".
1304 ((and (not abs)
1305 ffap-ftp-sans-slash-regexp
1306 (string-match ffap-ftp-sans-slash-regexp oname)
1307 (ffap-file-remote-p (concat "/" oname))))
1308 ;; Alist failed? Try to guess an active remote connection
1309 ;; from buffer variables, and try once more, both as an
1310 ;; absolute and relative file name on that remote host.
1311 ((let* (ffap-rfs-regexp ; suppress
1312 (remote-dir
1313 (cond
1314 ((ffap-file-remote-p default-directory))
1315 ((and (eq major-mode 'internal-ange-ftp-mode)
1316 (string-match "^\\*ftp \\(.*\\)@\\(.*\\)\\*$"
1317 (buffer-name)))
1318 (concat "/" (substring (buffer-name) 5 -1) ":"))
1319 ;; This is too often a bad idea:
1320 ;;((and (eq major-mode 'w3-mode)
1321 ;; (stringp url-current-server))
1322 ;; (host-to-ange-path url-current-server))
1324 (and remote-dir
1326 (and (string-match "\\`\\(/?~?ftp\\)/" name)
1327 (ffap-file-exists-string
1328 (ffap-replace-file-component
1329 remote-dir (substring name (match-end 1)))))
1330 (ffap-file-exists-string
1331 (ffap-replace-file-component remote-dir name))))))
1332 ((and ffap-dired-wildcards
1333 (string-match ffap-dired-wildcards name)
1335 (ffap-file-exists-string (file-name-directory
1336 (directory-file-name name)))
1337 name))
1338 ;; Try all parent directories by deleting the trailing directory
1339 ;; name until existing directory is found or name stops changing
1340 ((let ((dir name))
1341 (while (and dir
1342 (not (ffap-file-exists-string dir))
1343 (not (equal dir (setq dir (file-name-directory
1344 (directory-file-name dir)))))))
1345 (and (not (string= dir "/"))
1346 (ffap-file-exists-string dir))))
1348 (set-match-data data))))
1350 ;;; Prompting (`ffap-read-file-or-url'):
1352 ;; We want to complete filenames as in read-file-name, but also url's
1353 ;; which read-file-name-internal would truncate at the "//" string.
1354 ;; The solution here is to replace read-file-name-internal with
1355 ;; `ffap-read-file-or-url-internal', which checks the minibuffer
1356 ;; contents before attempting to complete filenames.
1358 (defun ffap-read-file-or-url (prompt guess)
1359 "Read file or URL from minibuffer, with PROMPT and initial GUESS."
1360 (or guess (setq guess default-directory))
1361 (let (dir)
1362 ;; Tricky: guess may have or be a local directory, like "w3/w3.elc"
1363 ;; or "w3/" or "../el/ffap.el" or "../../../"
1364 (unless (ffap-url-p guess)
1365 (unless (ffap-file-remote-p guess)
1366 (setq guess
1367 (abbreviate-file-name (expand-file-name guess))))
1368 (setq dir (file-name-directory guess)))
1369 (let ((minibuffer-completing-file-name t)
1370 (completion-ignore-case read-file-name-completion-ignore-case)
1371 (fnh-elem (cons ffap-url-regexp 'url-file-handler)))
1372 ;; Explain to `rfn-eshadow' that we can use URLs here.
1373 (push fnh-elem file-name-handler-alist)
1374 (unwind-protect
1375 (setq guess
1376 (let ((default-directory (if dir (expand-file-name dir)
1377 default-directory)))
1378 (completing-read
1379 prompt
1380 'ffap-read-file-or-url-internal
1383 (if dir (cons guess (length dir)) guess)
1384 'file-name-history
1385 (and buffer-file-name
1386 (abbreviate-file-name buffer-file-name)))))
1387 ;; Remove the special handler manually. We used to just let-bind
1388 ;; file-name-handler-alist to preserve its value, but that caused
1389 ;; other modifications to be lost (e.g. when Tramp gets loaded
1390 ;; during the completing-read call).
1391 (setq file-name-handler-alist (delq fnh-elem file-name-handler-alist))))
1392 (or (ffap-url-p guess)
1393 (substitute-in-file-name guess))))
1395 (defun ffap-read-url-internal (string pred action)
1396 "Complete URLs from history, treating given string as valid."
1397 (let ((hist (ffap-symbol-value 'url-global-history-hash-table)))
1398 (cond
1399 ((not action)
1400 (or (try-completion string hist pred) string))
1401 ((eq action t)
1402 (or (all-completions string hist pred) (list string)))
1403 ;; action == lambda, documented where? Tests whether string is a
1404 ;; valid "match". Let us always say yes.
1405 (t t))))
1407 (defun ffap-read-file-or-url-internal (string pred action)
1408 (let ((url (ffap-url-p string)))
1409 (if url
1410 (ffap-read-url-internal url pred action)
1411 (read-file-name-internal (or string default-directory) pred action))))
1413 ;; The rest of this page is just to work with package complete.el.
1414 ;; This code assumes that you load ffap.el after complete.el.
1416 ;; We must inform complete about whether our completion function
1417 ;; will do filename style completion.
1420 ;;; Highlighting (`ffap-highlight'):
1422 (defvar ffap-highlight t
1423 "If non-nil, ffap highlights the current buffer substring.")
1425 (defface ffap
1426 '((t :inherit highlight))
1427 "Face used to highlight the current buffer substring."
1428 :group 'ffap
1429 :version "22.1")
1431 (defvar ffap-highlight-overlay nil
1432 "Overlay used by function `ffap-highlight'.")
1434 (defun ffap-highlight (&optional remove)
1435 "If `ffap-highlight' is set, highlight the guess in this buffer.
1436 That is, the last buffer substring found by `ffap-string-at-point'.
1437 Optional argument REMOVE means to remove any such highlighting.
1438 Uses the face `ffap' if it is defined, or else `highlight'."
1439 (cond
1440 (remove
1441 (and ffap-highlight-overlay
1442 (delete-overlay ffap-highlight-overlay))
1444 ((not ffap-highlight) nil)
1445 (ffap-highlight-overlay
1446 (move-overlay
1447 ffap-highlight-overlay
1448 (car ffap-string-at-point-region)
1449 (nth 1 ffap-string-at-point-region)
1450 (current-buffer)))
1452 (setq ffap-highlight-overlay
1453 (apply 'make-overlay ffap-string-at-point-region))
1454 (overlay-put ffap-highlight-overlay 'face 'ffap))))
1457 ;;; Main Entrance (`find-file-at-point' == `ffap'):
1459 (defun ffap-guesser ()
1460 "Return file or URL or nil, guessed from text around point."
1461 (or (and ffap-url-regexp
1462 (ffap-fixup-url (or (ffap-url-at-point)
1463 (ffap-gopher-at-point))))
1464 (ffap-file-at-point) ; may yield url!
1465 (ffap-fixup-machine (ffap-machine-at-point))))
1467 (defun ffap-prompter (&optional guess)
1468 ;; Does guess and prompt step for find-file-at-point.
1469 ;; Extra complication for the temporary highlighting.
1470 (unwind-protect
1471 ;; This catch will let ffap-alist entries do their own prompting
1472 ;; and then maybe skip over this prompt (ff-paths, for example).
1473 (catch 'ffap-prompter
1474 (ffap-read-file-or-url
1475 (if ffap-url-regexp "Find file or URL: " "Find file: ")
1476 (prog1
1477 (let ((mark-active nil))
1478 ;; Don't use the region here, since it can be something
1479 ;; completely unwieldy. If the user wants that, she could
1480 ;; use M-w before and then C-y. --Stef
1481 (setq guess (or guess (ffap-guesser)))) ; using ffap-alist here
1482 (and guess (ffap-highlight))
1484 (ffap-highlight t)))
1486 ;;;###autoload
1487 (defun find-file-at-point (&optional filename)
1488 "Find FILENAME, guessing a default from text around point.
1489 If `ffap-url-regexp' is not nil, the FILENAME may also be an URL.
1490 With a prefix, this command behaves exactly like `ffap-file-finder'.
1491 If `ffap-require-prefix' is set, the prefix meaning is reversed.
1492 See also the variables `ffap-dired-wildcards', `ffap-newfile-prompt',
1493 and the functions `ffap-file-at-point' and `ffap-url-at-point'."
1494 (interactive)
1495 (if (and (called-interactively-p 'interactive)
1496 (if ffap-require-prefix (not current-prefix-arg)
1497 current-prefix-arg))
1498 ;; Do exactly the ffap-file-finder command, even the prompting:
1499 (let (current-prefix-arg) ; we already interpreted it
1500 (call-interactively ffap-file-finder))
1501 (or filename (setq filename (ffap-prompter)))
1502 (let ((url (ffap-url-p filename)))
1503 (cond
1504 (url
1505 (let (current-prefix-arg)
1506 (funcall ffap-url-fetcher url)))
1507 ((and ffap-pass-wildcards-to-dired
1508 ffap-dired-wildcards
1509 (string-match ffap-dired-wildcards filename))
1510 (funcall ffap-directory-finder filename))
1511 ((and ffap-dired-wildcards
1512 (string-match ffap-dired-wildcards filename)
1513 find-file-wildcards
1514 ;; Check if it's find-file that supports wildcards arg
1515 (memq ffap-file-finder '(find-file find-alternate-file)))
1516 (funcall ffap-file-finder (expand-file-name filename) t))
1517 ((or (not ffap-newfile-prompt)
1518 (file-exists-p filename)
1519 (y-or-n-p "File does not exist, create buffer? "))
1520 (funcall ffap-file-finder
1521 ;; expand-file-name fixes "~/~/.emacs" bug sent by CHUCKR.
1522 (expand-file-name filename)))
1523 ;; User does not want to find a non-existent file:
1524 ((signal 'file-missing (list "Opening file buffer"
1525 "No such file or directory"
1526 filename)))))))
1528 ;; Shortcut: allow {M-x ffap} rather than {M-x find-file-at-point}.
1529 ;;;###autoload
1530 (defalias 'ffap 'find-file-at-point)
1533 ;;; Menu support (`ffap-menu'):
1535 (defcustom ffap-menu-regexp nil
1536 "If non-nil, regexp overriding `ffap-next-regexp' in `ffap-menu'.
1537 Make this more restrictive for faster menu building.
1538 For example, try \":/\" for URL (and some FTP) references."
1539 :type '(choice (const nil) regexp)
1540 :group 'ffap)
1542 (defvar ffap-menu-alist nil
1543 "Buffer local cache of menu presented by `ffap-menu'.")
1544 (make-variable-buffer-local 'ffap-menu-alist)
1546 (defvar ffap-menu-text-plist
1547 (cond
1548 ((display-mouse-p) '(face bold mouse-face highlight)) ; keymap <mousy-map>
1549 (t nil))
1550 "Text properties applied to strings found by `ffap-menu-rescan'.
1551 These properties may be used to fontify the menu references.")
1553 ;;;###autoload
1554 (defun ffap-menu (&optional rescan)
1555 "Put up a menu of files and URLs mentioned in this buffer.
1556 Then set mark, jump to choice, and try to fetch it. The menu is
1557 cached in `ffap-menu-alist', and rebuilt by `ffap-menu-rescan'.
1558 The optional RESCAN argument (a prefix, interactively) forces
1559 a rebuild. Searches with `ffap-menu-regexp'."
1560 (interactive "P")
1561 ;; (require 'imenu) -- no longer used, but roughly emulated
1562 (if (or (not ffap-menu-alist) rescan
1563 ;; or if the first entry is wrong:
1564 (and ffap-menu-alist
1565 (let ((first (car ffap-menu-alist)))
1566 (save-excursion
1567 (goto-char (cdr first))
1568 (not (equal (car first) (ffap-guesser)))))))
1569 (ffap-menu-rescan))
1570 ;; Tail recursive:
1571 (ffap-menu-ask
1572 (if ffap-url-regexp "Find file or URL" "Find file")
1573 (cons (cons "*Rescan Buffer*" -1) ffap-menu-alist)
1574 'ffap-menu-cont))
1576 (defun ffap-menu-cont (choice) ; continuation of ffap-menu
1577 (if (< (cdr choice) 0)
1578 (ffap-menu t) ; *Rescan*
1579 (push-mark)
1580 (goto-char (cdr choice))
1581 ;; Momentary highlight:
1582 (unwind-protect
1583 (progn
1584 (and ffap-highlight (ffap-guesser) (ffap-highlight))
1585 (sit-for 0) ; display
1586 (find-file-at-point (car choice)))
1587 (ffap-highlight t))))
1589 (defun ffap-menu-ask (title alist cont)
1590 "Prompt from a menu of choices, and then apply some action.
1591 Arguments are TITLE, ALIST, and CONT (a continuation function).
1592 This uses either a menu or the minibuffer depending on invocation.
1593 The TITLE string is used as either the prompt or menu title.
1594 Each ALIST entry looks like (STRING . DATA) and defines one choice.
1595 Function CONT is applied to the entry chosen by the user."
1596 ;; Note: this function is used with a different continuation
1597 ;; by the ffap-url add-on package.
1598 ;; Could try rewriting to use easymenu.el or lmenu.el.
1599 (let (choice)
1600 (cond
1601 ;; Emacs mouse:
1602 ((and (fboundp 'x-popup-menu) (ffap-mouse-event))
1603 (setq choice
1604 (x-popup-menu
1606 (list "" (cons title
1607 (mapcar (lambda (i) (cons (car i) i))
1608 alist))))))
1609 ;; minibuffer with completion buffer:
1611 (let ((minibuffer-setup-hook 'minibuffer-completion-help))
1612 ;; Bug: prompting may assume unique strings, no "".
1613 (setq choice
1614 (completing-read
1615 (format "%s (default %s): " title (car (car alist)))
1616 alist nil t
1617 ;; (cons (car (car alist)) 0)
1618 nil)))
1619 (sit-for 0) ; redraw original screen
1620 ;; Convert string to its entry, or else the default:
1621 (setq choice (or (assoc choice alist) (car alist)))))
1622 (if choice
1623 (funcall cont choice)
1624 (message "No choice made!") ; possible with menus
1625 nil)))
1627 (defun ffap-menu-rescan ()
1628 "Search buffer for `ffap-menu-regexp' to build `ffap-menu-alist'.
1629 Applies `ffap-menu-text-plist' text properties at all matches."
1630 (interactive)
1631 (let ((ffap-next-regexp (or ffap-menu-regexp ffap-next-regexp))
1632 (range (- (point-max) (point-min)))
1633 (mod (buffer-modified-p)) ; was buffer modified?
1634 ;; inhibit-read-only works on read-only text properties
1635 ;; as well as read-only buffers.
1636 (inhibit-read-only t) ; to set text-properties
1637 item
1638 ;; Avoid repeated searches of the *mode-alist:
1639 (major-mode (if (assq major-mode ffap-string-at-point-mode-alist)
1640 major-mode
1641 'file)))
1642 (setq ffap-menu-alist nil)
1643 (unwind-protect
1644 (save-excursion
1645 (goto-char (point-min))
1646 (while (setq item (ffap-next-guess))
1647 (setq ffap-menu-alist (cons (cons item (point)) ffap-menu-alist))
1648 (add-text-properties (car ffap-string-at-point-region) (point)
1649 ffap-menu-text-plist)
1650 (message "Scanning...%2d%% <%s>"
1651 (floor (* 100.0 (- (point) (point-min))) range) item)))
1652 (or mod (restore-buffer-modified-p nil))))
1653 (message "Scanning...done")
1654 ;; Remove duplicates.
1655 (setq ffap-menu-alist ; sort by item
1656 (sort ffap-menu-alist
1657 (function
1658 (lambda (a b) (string-lessp (car a) (car b))))))
1659 (let ((ptr ffap-menu-alist)) ; remove duplicates
1660 (while (cdr ptr)
1661 (if (equal (car (car ptr)) (car (car (cdr ptr))))
1662 (setcdr ptr (cdr (cdr ptr)))
1663 (setq ptr (cdr ptr)))))
1664 (setq ffap-menu-alist ; sort by position
1665 (sort ffap-menu-alist
1666 (function
1667 (lambda (a b) (< (cdr a) (cdr b)))))))
1670 ;;; Mouse Support (`ffap-at-mouse'):
1672 ;; See the suggested binding in ffap-bindings (near eof).
1674 (defvar ffap-at-mouse-fallback nil ; ffap-menu? too time-consuming
1675 "Command invoked by `ffap-at-mouse' if nothing found at click, or nil.
1676 Ignored when `ffap-at-mouse' is called programmatically.")
1677 (put 'ffap-at-mouse-fallback 'risky-local-variable t)
1679 ;;;###autoload
1680 (defun ffap-at-mouse (e)
1681 "Find file or URL guessed from text around mouse click.
1682 Interactively, calls `ffap-at-mouse-fallback' if no guess is found.
1683 Return value:
1684 * if a guess string is found, return it (after finding it)
1685 * if the fallback is called, return whatever it returns
1686 * otherwise, nil"
1687 (interactive "e")
1688 (let ((guess
1689 ;; Maybe less surprising without the save-excursion?
1690 (save-excursion
1691 (mouse-set-point e)
1692 ;; Would prefer to do nothing unless click was *on* text. How
1693 ;; to tell that the click was beyond the end of current line?
1694 (ffap-guesser))))
1695 (cond
1696 (guess
1697 (set-buffer (ffap-event-buffer e))
1698 (ffap-highlight)
1699 (unwind-protect
1700 (progn
1701 (sit-for 0) ; display
1702 (message "Finding `%s'" guess)
1703 (find-file-at-point guess)
1704 guess) ; success: return non-nil
1705 (ffap-highlight t)))
1706 ((called-interactively-p 'interactive)
1707 (if ffap-at-mouse-fallback
1708 (call-interactively ffap-at-mouse-fallback)
1709 (message "No file or URL found at mouse click.")
1710 nil)) ; no fallback, return nil
1711 ;; failure: return nil
1715 ;;; ffap-other-*, ffap-read-only-*, ffap-alternate-* commands:
1717 ;; There could be a real `ffap-noselect' function, but we would need
1718 ;; at least two new user variables, and there is no w3-fetch-noselect.
1719 ;; So instead, we just fake it with a slow save-window-excursion.
1721 (defun ffap-other-window ()
1722 "Like `ffap', but put buffer in another window.
1723 Only intended for interactive use."
1724 (interactive)
1725 (let (value)
1726 (switch-to-buffer-other-window
1727 (save-window-excursion
1728 (setq value (call-interactively 'ffap))
1729 (unless (or (bufferp value) (bufferp (car-safe value)))
1730 (setq value (current-buffer)))
1731 (current-buffer)))
1732 value))
1734 (defun ffap-other-frame ()
1735 "Like `ffap', but put buffer in another frame.
1736 Only intended for interactive use."
1737 (interactive)
1738 ;; Extra code works around dedicated windows (noted by JENS, 7/96):
1739 (let* ((win (selected-window))
1740 (wdp (window-dedicated-p win))
1741 value)
1742 (unwind-protect
1743 (progn
1744 (set-window-dedicated-p win nil)
1745 (switch-to-buffer-other-frame
1746 (save-window-excursion
1747 (setq value (call-interactively 'ffap))
1748 (unless (or (bufferp value) (bufferp (car-safe value)))
1749 (setq value (current-buffer)))
1750 (current-buffer))))
1751 (set-window-dedicated-p win wdp))
1752 value))
1754 (defun ffap--toggle-read-only (buffer-or-list)
1755 (dolist (buffer (if (listp buffer-or-list)
1756 buffer-or-list
1757 (list buffer-or-list)))
1758 (with-current-buffer buffer
1759 (read-only-mode 1))))
1761 (defun ffap-read-only ()
1762 "Like `ffap', but mark buffer as read-only.
1763 Only intended for interactive use."
1764 (interactive)
1765 (let ((value (call-interactively 'ffap)))
1766 (unless (or (bufferp value) (bufferp (car-safe value)))
1767 (setq value (current-buffer)))
1768 (ffap--toggle-read-only value)
1769 value))
1771 (defun ffap-read-only-other-window ()
1772 "Like `ffap', but put buffer in another window and mark as read-only.
1773 Only intended for interactive use."
1774 (interactive)
1775 (let ((value (ffap-other-window)))
1776 (ffap--toggle-read-only value)
1777 value))
1779 (defun ffap-read-only-other-frame ()
1780 "Like `ffap', but put buffer in another frame and mark as read-only.
1781 Only intended for interactive use."
1782 (interactive)
1783 (let ((value (ffap-other-frame)))
1784 (ffap--toggle-read-only value)
1785 value))
1787 (defun ffap-alternate-file ()
1788 "Like `ffap' and `find-alternate-file'.
1789 Only intended for interactive use."
1790 (interactive)
1791 (let ((ffap-file-finder 'find-alternate-file))
1792 (call-interactively 'ffap)))
1794 (defun ffap-alternate-file-other-window ()
1795 "Like `ffap' and `find-alternate-file-other-window'.
1796 Only intended for interactive use."
1797 (interactive)
1798 (let ((ffap-file-finder 'find-alternate-file-other-window))
1799 (call-interactively 'ffap)))
1801 (defun ffap-literally ()
1802 "Like `ffap' and command `find-file-literally'.
1803 Only intended for interactive use."
1804 (interactive)
1805 (let ((ffap-file-finder 'find-file-literally))
1806 (call-interactively 'ffap)))
1808 (defalias 'find-file-literally-at-point 'ffap-literally)
1811 ;;; Bug Reporter:
1813 (define-obsolete-function-alias 'ffap-bug 'report-emacs-bug "23.1")
1814 (define-obsolete-function-alias 'ffap-submit-bug 'report-emacs-bug "23.1")
1817 ;;; Hooks for Gnus, VM, Rmail:
1819 ;; If you do not like these bindings, write versions with whatever
1820 ;; bindings you would prefer.
1822 (defun ffap-ro-mode-hook ()
1823 "Bind `ffap-next' and `ffap-menu' to M-l and M-m, resp."
1824 (local-set-key "\M-l" 'ffap-next)
1825 (local-set-key "\M-m" 'ffap-menu))
1827 (defun ffap-gnus-hook ()
1828 "Bind `ffap-gnus-next' and `ffap-gnus-menu' to M-l and M-m, resp."
1829 ;; message-id's
1830 (setq-local thing-at-point-default-mail-uri-scheme "news")
1831 ;; Note "l", "L", "m", "M" are taken:
1832 (local-set-key "\M-l" 'ffap-gnus-next)
1833 (local-set-key "\M-m" 'ffap-gnus-menu))
1835 (defvar gnus-summary-buffer)
1836 (defvar gnus-article-buffer)
1838 ;; This code is called from gnus.
1839 (declare-function gnus-summary-select-article "gnus-sum"
1840 (&optional all-headers force pseudo article))
1842 (declare-function gnus-configure-windows "gnus-win"
1843 (setting &optional force))
1845 (defun ffap-gnus-wrapper (form) ; used by both commands below
1846 (and (eq (current-buffer) (get-buffer gnus-summary-buffer))
1847 (gnus-summary-select-article)) ; get article of current line
1848 ;; Preserve selected buffer, but do not do save-window-excursion,
1849 ;; since we want to see any window created by the form. Temporarily
1850 ;; select the article buffer, so we can see any point movement.
1851 (let ((sb (window-buffer)))
1852 (gnus-configure-windows 'article)
1853 (pop-to-buffer gnus-article-buffer)
1854 (widen)
1855 ;; Skip headers for ffap-gnus-next (which will wrap around)
1856 (if (eq (point) (point-min)) (search-forward "\n\n" nil t))
1857 (unwind-protect
1858 (eval form)
1859 (pop-to-buffer sb))))
1861 (defun ffap-gnus-next ()
1862 "Run `ffap-next' in the gnus article buffer."
1863 (interactive) (ffap-gnus-wrapper '(ffap-next nil t)))
1865 (defun ffap-gnus-menu ()
1866 "Run `ffap-menu' in the gnus article buffer."
1867 (interactive) (ffap-gnus-wrapper '(ffap-menu)))
1871 ;;;###autoload
1872 (defun dired-at-point (&optional filename)
1873 "Start Dired, defaulting to file at point. See `ffap'.
1874 If `dired-at-point-require-prefix' is set, the prefix meaning is reversed."
1875 (interactive)
1876 (if (and (called-interactively-p 'interactive)
1877 (if dired-at-point-require-prefix
1878 (not current-prefix-arg)
1879 current-prefix-arg))
1880 (let (current-prefix-arg) ; already interpreted
1881 (call-interactively ffap-directory-finder))
1882 (or filename (setq filename (dired-at-point-prompter)))
1883 (let ((url (ffap-url-p filename)))
1884 (cond
1885 (url
1886 (funcall ffap-url-fetcher url))
1887 ((and ffap-dired-wildcards
1888 (string-match ffap-dired-wildcards filename))
1889 (funcall ffap-directory-finder filename))
1890 ((file-exists-p filename)
1891 (if (file-directory-p filename)
1892 (funcall ffap-directory-finder
1893 (expand-file-name filename))
1894 (funcall ffap-directory-finder
1895 (concat (expand-file-name filename) "*"))))
1896 ((and (file-writable-p
1897 (or (file-name-directory (directory-file-name filename))
1898 filename))
1899 (y-or-n-p "Directory does not exist, create it? "))
1900 (make-directory filename)
1901 (funcall ffap-directory-finder filename))
1903 (signal 'file-missing (list "Opening directory"
1904 "No such file or directory"
1905 filename)))))))
1907 (defun dired-at-point-prompter (&optional guess)
1908 ;; Does guess and prompt step for find-file-at-point.
1909 ;; Extra complication for the temporary highlighting.
1910 (unwind-protect
1911 (ffap-read-file-or-url
1912 (cond
1913 ((eq ffap-directory-finder 'list-directory)
1914 "List directory (brief): ")
1915 (ffap-url-regexp "Dired file or URL: ")
1916 (t "Dired file: "))
1917 (prog1
1918 (setq guess
1919 (let ((guess (or guess (ffap-guesser))))
1920 (cond
1921 ((null guess) nil)
1922 ((ffap-url-p guess))
1923 ((ffap-file-remote-p guess)
1924 guess)
1925 ((progn
1926 (setq guess (abbreviate-file-name
1927 (expand-file-name guess)))
1928 ;; Interpret local directory as a directory.
1929 (file-directory-p guess))
1930 (file-name-as-directory guess))
1931 ;; Get directory component from local files.
1932 ((file-regular-p guess)
1933 (file-name-directory guess))
1934 (guess))))
1935 (and guess (ffap-highlight))))
1936 (ffap-highlight t)))
1938 ;;; ffap-dired-other-*, ffap-list-directory commands:
1940 (defun ffap-dired-other-window ()
1941 "Like `dired-at-point', but put buffer in another window.
1942 Only intended for interactive use."
1943 (interactive)
1944 (let (value)
1945 (switch-to-buffer-other-window
1946 (save-window-excursion
1947 (setq value (call-interactively 'dired-at-point))
1948 (current-buffer)))
1949 value))
1951 (defun ffap-dired-other-frame ()
1952 "Like `dired-at-point', but put buffer in another frame.
1953 Only intended for interactive use."
1954 (interactive)
1955 ;; Extra code works around dedicated windows (noted by JENS, 7/96):
1956 (let* ((win (selected-window))
1957 (wdp (window-dedicated-p win))
1958 value)
1959 (unwind-protect
1960 (progn
1961 (set-window-dedicated-p win nil)
1962 (switch-to-buffer-other-frame
1963 (save-window-excursion
1964 (setq value (call-interactively 'dired-at-point))
1965 (current-buffer))))
1966 (set-window-dedicated-p win wdp))
1967 value))
1969 (defun ffap-list-directory ()
1970 "Like `dired-at-point' and `list-directory'.
1971 Only intended for interactive use."
1972 (interactive)
1973 (let ((ffap-directory-finder 'list-directory))
1974 (call-interactively 'dired-at-point)))
1977 ;;; Hooks to put in `file-name-at-point-functions':
1979 ;;;###autoload
1980 (defun ffap-guess-file-name-at-point ()
1981 "Try to get a file name at point.
1982 This hook is intended to be put in `file-name-at-point-functions'."
1983 ;; ffap-guesser can signal an error, and we don't want that when,
1984 ;; e.g., the user types M-n at the "C-x C-f" prompt.
1985 (let ((guess (ignore-errors (ffap-guesser))))
1986 (when (stringp guess)
1987 (let ((url (ffap-url-p guess)))
1988 (or url
1989 (progn
1990 (unless (ffap-file-remote-p guess)
1991 (setq guess
1992 (abbreviate-file-name (expand-file-name guess))))
1993 (if (file-directory-p guess)
1994 (file-name-as-directory guess)
1995 guess)))))))
1997 ;;; Offer default global bindings (`ffap-bindings'):
1999 (defvar ffap-bindings
2000 '((global-set-key [S-mouse-3] 'ffap-at-mouse)
2001 (global-set-key [C-S-mouse-3] 'ffap-menu)
2003 (global-set-key "\C-x\C-f" 'find-file-at-point)
2004 (global-set-key "\C-x\C-r" 'ffap-read-only)
2005 (global-set-key "\C-x\C-v" 'ffap-alternate-file)
2007 (global-set-key "\C-x4f" 'ffap-other-window)
2008 (global-set-key "\C-x5f" 'ffap-other-frame)
2009 (global-set-key "\C-x4r" 'ffap-read-only-other-window)
2010 (global-set-key "\C-x5r" 'ffap-read-only-other-frame)
2012 (global-set-key "\C-xd" 'dired-at-point)
2013 (global-set-key "\C-x4d" 'ffap-dired-other-window)
2014 (global-set-key "\C-x5d" 'ffap-dired-other-frame)
2015 (global-set-key "\C-x\C-d" 'ffap-list-directory)
2017 (add-hook 'gnus-summary-mode-hook 'ffap-gnus-hook)
2018 (add-hook 'gnus-article-mode-hook 'ffap-gnus-hook)
2019 (add-hook 'vm-mode-hook 'ffap-ro-mode-hook)
2020 (add-hook 'rmail-mode-hook 'ffap-ro-mode-hook))
2021 "List of binding forms evaluated by function `ffap-bindings'.
2022 A reasonable ffap installation needs just this one line:
2023 (ffap-bindings)
2024 Of course if you do not like these bindings, just roll your own!")
2026 ;;;###autoload
2027 (defun ffap-bindings ()
2028 "Evaluate the forms in variable `ffap-bindings'."
2029 (interactive)
2030 (eval (cons 'progn ffap-bindings)))
2033 (provide 'ffap)
2035 ;;; ffap.el ends here