Merge from trunk.
[emacs.git] / lisp / ffap.el
blob97105ed422b1a6cd8b2637c116a95f9d98d86152
1 ;;; ffap.el --- find file (or url) at point
3 ;; Copyright (C) 1995-1997, 2000-2011 Free Software Foundation, Inc.
5 ;; Author: Michelangelo Grigni <mic@mathcs.emory.edu>
6 ;; Maintainer: FSF
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 .emacs 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 ;; * use kpsewhich
94 ;; * let "/dir/file#key" jump to key (tag or regexp) in /dir/file
95 ;; * find file of symbol if TAGS is loaded (like above)
96 ;; * break long menus into multiple panes (like imenu?)
97 ;; * notice node in "(dired)Virtual Dired" (quotes, parentheses, whitespace)
98 ;; * notice "machine.dom blah blah blah dir/file" (how?)
99 ;; * as w3 becomes standard, rewrite to rely more on its functions
100 ;; * regexp options for ffap-string-at-point, like font-lock (MCOOK)
101 ;; * v19: could replace `ffap-locate-file' with a quieter `locate-library'
102 ;; * handle "$(VAR)" in Makefiles
103 ;; * use the font-lock machinery
106 ;;; Code:
108 (define-obsolete-variable-alias 'ffap-version 'emacs-version "23.2")
110 (defgroup ffap nil
111 "Find file or URL at point."
112 ;; Dead 2009/07/05.
113 ;; :link '(url-link :tag "URL" "ftp://ftp.mathcs.emory.edu/pub/mic/emacs/")
114 :group 'matching
115 :group 'convenience)
117 ;; The code is organized in pages, separated by formfeed characters.
118 ;; See the next two pages for standard customization ideas.
121 ;;; User Variables:
123 (defun ffap-symbol-value (sym &optional default)
124 "Return value of symbol SYM, if bound, or DEFAULT otherwise."
125 (if (boundp sym) (symbol-value sym) default))
127 (defcustom ffap-shell-prompt-regexp
128 ;; This used to test for some shell prompts that don't have a space
129 ;; after them. The common root shell prompt (#) is not listed since it
130 ;; also doubles up as a valid URL character.
131 "[$%><]*"
132 "Paths matching this regexp are stripped off the shell prompt.
133 If nil, ffap doesn't do shell prompt stripping."
134 :type '(choice (const :tag "Disable" nil)
135 (const :tag "Standard" "[$%><]*")
136 regexp)
137 :group 'ffap)
139 (defcustom ffap-ftp-regexp
140 ;; This used to test for ange-ftp or efs being present, but it should be
141 ;; harmless (and simpler) to give it this value unconditionally.
142 "\\`/[^/:]+:"
143 "File names matching this regexp are treated as remote ffap.
144 If nil, ffap neither recognizes nor generates such names."
145 :type '(choice (const :tag "Disable" nil)
146 (const :tag "Standard" "\\`/[^/:]+:")
147 regexp)
148 :group 'ffap)
150 (defcustom ffap-url-unwrap-local t
151 "If non-nil, convert `file:' URL to local file name before prompting."
152 :type 'boolean
153 :group 'ffap)
155 (defcustom ffap-url-unwrap-remote t
156 "If non-nil, convert `ftp:' URL to remote file name before prompting.
157 This is ignored if `ffap-ftp-regexp' is nil."
158 :type 'boolean
159 :group 'ffap)
161 (defcustom ffap-ftp-default-user "anonymous"
162 "User name in ftp file names generated by `ffap-host-to-path'.
163 Note this name may be omitted if it equals the default
164 \(either `efs-default-user' or `ange-ftp-default-user'\)."
165 :type 'string
166 :group 'ffap)
168 (defcustom ffap-rfs-regexp
169 ;; Remote file access built into file system? HP rfa or Andrew afs:
170 "\\`/\\(afs\\|net\\)/."
171 ;; afs only: (and (file-exists-p "/afs") "\\`/afs/.")
172 "Matching file names are treated as remote. Use nil to disable."
173 :type 'regexp
174 :group 'ffap)
176 (defvar ffap-url-regexp
177 ;; Could just use `url-nonrelative-link' of w3, if loaded.
178 ;; This regexp is not exhaustive, it just matches common cases.
179 (concat
180 "\\`\\("
181 "news\\(post\\)?:\\|mailto:\\|file:" ; no host ok
182 "\\|"
183 "\\(ftp\\|https?\\|telnet\\|gopher\\|www\\|wais\\)://" ; needs host
184 "\\)." ; require one more character
186 "Regexp matching URLs. Use nil to disable URL features in ffap.")
188 (defcustom ffap-foo-at-bar-prefix "mailto"
189 "Presumed URL prefix type of strings like \"<foo.9z@bar>\".
190 Sensible values are nil, \"news\", or \"mailto\"."
191 :type '(choice (const "mailto")
192 (const "news")
193 (const :tag "Disable" nil)
194 ;; string -- possible, but not really useful
196 :group 'ffap)
199 ;;; Peanut Gallery (More User Variables):
201 ;; Users of ffap occasionally suggest new features. If I consider
202 ;; those features interesting but not clear winners (a matter of
203 ;; personal taste) I try to leave options to enable them. Read
204 ;; through this section for features that you like, put an appropriate
205 ;; enabler in your .emacs file.
207 (defcustom ffap-dired-wildcards "[*?][^/]*\\'"
208 "A regexp matching filename wildcard characters, or nil.
210 If `find-file-at-point' gets a filename matching this pattern,
211 and `ffap-pass-wildcards-to-dired' is nil, it passes it on to
212 `find-file' with non-nil WILDCARDS argument, which expands
213 wildcards and visits multiple files. To visit a file whose name
214 contains wildcard characters you can suppress wildcard expansion
215 by setting `find-file-wildcards'. If `find-file-at-point' gets a
216 filename matching this pattern and `ffap-pass-wildcards-to-dired'
217 is non-nil, it passes it on to `dired'.
219 If `dired-at-point' gets a filename matching this pattern,
220 it passes it on to `dired'."
221 :type '(choice (const :tag "Disable" nil)
222 (const :tag "Enable" "[*?][^/]*\\'")
223 ;; regexp -- probably not useful
225 :group 'ffap)
227 (defcustom ffap-pass-wildcards-to-dired nil
228 "If non-nil, pass filenames matching `ffap-dired-wildcards' to dired."
229 :type 'boolean
230 :group 'ffap)
232 (defcustom ffap-newfile-prompt nil
233 ;; Suggestion from RHOGEE, 11 Jul 1994. Disabled, I think this is
234 ;; better handled by `find-file-not-found-hooks'.
235 "Whether `find-file-at-point' prompts about a nonexistent file."
236 :type 'boolean
237 :group 'ffap)
239 (defcustom ffap-require-prefix nil
240 ;; Suggestion from RHOGEE, 20 Oct 1994.
241 "If set, reverses the prefix argument to `find-file-at-point'.
242 This is nil so neophytes notice ffap. Experts may prefer to disable
243 ffap most of the time."
244 :type 'boolean
245 :group 'ffap)
247 (defcustom ffap-file-finder 'find-file
248 "The command called by `find-file-at-point' to find a file."
249 :type 'function
250 :group 'ffap)
251 (put 'ffap-file-finder 'risky-local-variable t)
253 (defcustom ffap-directory-finder 'dired
254 "The command called by `dired-at-point' to find a directory."
255 :type 'function
256 :group 'ffap)
257 (put 'ffap-directory-finder 'risky-local-variable t)
259 (defcustom ffap-url-fetcher
260 (if (fboundp 'browse-url)
261 'browse-url ; rely on browse-url-browser-function
262 'w3-fetch)
263 ;; Remote control references:
264 ;; http://www.ncsa.uiuc.edu/SDG/Software/XMosaic/remote-control.html
265 ;; http://home.netscape.com/newsref/std/x-remote.html
266 "A function of one argument, called by ffap to fetch an URL.
267 Reasonable choices are `w3-fetch' or a `browse-url-*' function.
268 For a fancy alternative, get `ffap-url.el'."
269 :type '(choice (const w3-fetch)
270 (const browse-url) ; in recent versions of browse-url
271 (const browse-url-netscape)
272 (const browse-url-mosaic)
273 function)
274 :group 'ffap)
275 (put 'ffap-url-fetcher 'risky-local-variable t)
278 ;;; Compatibility:
280 ;; This version of ffap supports only the Emacs it is distributed in.
281 ;; See the ftp site for a more general version. The following
282 ;; functions are necessary "leftovers" from the more general version.
284 (defun ffap-mouse-event () ; current mouse event, or nil
285 (and (listp last-nonmenu-event) last-nonmenu-event))
286 (defun ffap-event-buffer (event)
287 (window-buffer (car (event-start event))))
290 ;;; Find Next Thing in buffer (`ffap-next'):
292 ;; Original ffap-next-url (URL's only) from RPECK 30 Mar 1995. Since
293 ;; then, broke it up into ffap-next-guess (noninteractive) and
294 ;; ffap-next (a command). It now work on files as well as url's.
296 (defcustom ffap-next-regexp
297 ;; If you want ffap-next to find URL's only, try this:
298 ;; (and ffap-url-regexp (string-match "\\\\`" ffap-url-regexp)
299 ;; (concat "\\<" (substring ffap-url-regexp 2))))
301 ;; It pays to put a big fancy regexp here, since ffap-guesser is
302 ;; much more time-consuming than regexp searching:
303 "[/:.~[:alpha:]]/\\|@[[:alpha:]][-[:alnum:]]*\\."
304 "Regular expression governing movements of `ffap-next'."
305 :type 'regexp
306 :group 'ffap)
308 (defvar ffap-next-guess nil
309 "Last value returned by `ffap-next-guess'.")
311 (defvar ffap-string-at-point-region '(1 1)
312 "List (BEG END), last region returned by `ffap-string-at-point'.")
314 (defun ffap-next-guess (&optional back lim)
315 "Move point to next file or URL, and return it as a string.
316 If nothing is found, leave point at limit and return nil.
317 Optional BACK argument makes search backwards.
318 Optional LIM argument limits the search.
319 Only considers strings that match `ffap-next-regexp'."
320 (or lim (setq lim (if back (point-min) (point-max))))
321 (let (guess)
322 (while (not (or guess (eq (point) lim)))
323 (funcall (if back 're-search-backward 're-search-forward)
324 ffap-next-regexp lim 'move)
325 (setq guess (ffap-guesser)))
326 ;; Go to end, so we do not get same guess twice:
327 (goto-char (nth (if back 0 1) ffap-string-at-point-region))
328 (setq ffap-next-guess guess)))
330 ;;;###autoload
331 (defun ffap-next (&optional back wrap)
332 "Search buffer for next file or URL, and run ffap.
333 Optional argument BACK says to search backwards.
334 Optional argument WRAP says to try wrapping around if necessary.
335 Interactively: use a single prefix to search backwards,
336 double prefix to wrap forward, triple to wrap backwards.
337 Actual search is done by `ffap-next-guess'."
338 (interactive
339 (cdr (assq (prefix-numeric-value current-prefix-arg)
340 '((1) (4 t) (16 nil t) (64 t t)))))
341 (let ((pt (point))
342 (guess (ffap-next-guess back)))
343 ;; Try wraparound if necessary:
344 (and (not guess) wrap
345 (goto-char (if back (point-max) (point-min)))
346 (setq guess (ffap-next-guess back pt)))
347 (if guess
348 (progn
349 (sit-for 0) ; display point movement
350 (find-file-at-point (ffap-prompter guess)))
351 (goto-char pt) ; restore point
352 (message "No %sfiles or URL's found"
353 (if wrap "" "more ")))))
355 (defun ffap-next-url (&optional back wrap)
356 "Like `ffap-next', but search with `ffap-url-regexp'."
357 (interactive)
358 (let ((ffap-next-regexp ffap-url-regexp))
359 (if (called-interactively-p 'interactive)
360 (call-interactively 'ffap-next)
361 (ffap-next back wrap))))
364 ;;; Machines (`ffap-machine-p'):
366 ;; I cannot decide a "best" strategy here, so these are variables. In
367 ;; particular, if `Pinging...' is broken or takes too long on your
368 ;; machine, try setting these all to accept or reject.
369 (defcustom ffap-machine-p-local 'reject ; this happens often
370 "What `ffap-machine-p' does with hostnames that have no domain.
371 Value should be a symbol, one of `ping', `accept', and `reject'."
372 :type '(choice (const ping)
373 (const accept)
374 (const reject))
375 :group 'ffap)
376 (defcustom ffap-machine-p-known 'ping ; `accept' for higher speed
377 "What `ffap-machine-p' does with hostnames that have a known domain.
378 Value should be a symbol, one of `ping', `accept', and `reject'.
379 See `mail-extr.el' for the known domains."
380 :type '(choice (const ping)
381 (const accept)
382 (const reject))
383 :group 'ffap)
384 (defcustom ffap-machine-p-unknown 'reject
385 "What `ffap-machine-p' does with hostnames that have an unknown domain.
386 Value should be a symbol, one of `ping', `accept', and `reject'.
387 See `mail-extr.el' for the known domains."
388 :type '(choice (const ping)
389 (const accept)
390 (const reject))
391 :group 'ffap)
393 (defun ffap-what-domain (domain)
394 ;; Like what-domain in mail-extr.el, returns string or nil.
395 (require 'mail-extr)
396 (let ((ob (or (ffap-symbol-value 'mail-extr-all-top-level-domains)
397 (ffap-symbol-value 'all-top-level-domains)))) ; XEmacs
398 (and ob (get (intern-soft (downcase domain) ob) 'domain-name))))
400 (defun ffap-machine-p (host &optional service quiet strategy)
401 "Decide whether HOST is the name of a real, reachable machine.
402 Depending on the domain (none, known, or unknown), follow the strategy
403 named by the variable `ffap-machine-p-local', `ffap-machine-p-known',
404 or `ffap-machine-p-unknown'. Pinging uses `open-network-stream'.
405 Optional SERVICE specifies the port used \(default \"discard\"\).
406 Optional QUIET flag suppresses the \"Pinging...\" message.
407 Optional STRATEGY overrides the three variables above.
408 Returned values:
409 t means that HOST answered.
410 'accept means the relevant variable told us to accept.
411 \"mesg\" means HOST exists, but does not respond for some reason."
412 ;; Try some (Emory local):
413 ;; (ffap-machine-p "ftp" nil nil 'ping)
414 ;; (ffap-machine-p "nonesuch" nil nil 'ping)
415 ;; (ffap-machine-p "ftp.mathcs.emory.edu" nil nil 'ping)
416 ;; (ffap-machine-p "mathcs" 5678 nil 'ping)
417 ;; (ffap-machine-p "foo.bonk" nil nil 'ping)
418 ;; (ffap-machine-p "foo.bonk.com" nil nil 'ping)
419 (if (or (string-match "[^-[:alnum:].]" host) ; Invalid chars (?)
420 (not (string-match "[^0-9]" host))) ; 1: a number? 2: quick reject
422 (let* ((domain
423 (and (string-match "\\.[^.]*$" host)
424 (downcase (substring host (1+ (match-beginning 0))))))
425 (what-domain (if domain (ffap-what-domain domain) "Local")))
426 (or strategy
427 (setq strategy
428 (cond ((not domain) ffap-machine-p-local)
429 ((not what-domain) ffap-machine-p-unknown)
430 (t ffap-machine-p-known))))
431 (cond
432 ((eq strategy 'accept) 'accept)
433 ((eq strategy 'reject) nil)
434 ((not (fboundp 'open-network-stream)) nil)
435 ;; assume (eq strategy 'ping)
437 (or quiet
438 (if (stringp what-domain)
439 (message "Pinging %s (%s)..." host what-domain)
440 (message "Pinging %s ..." host)))
441 (condition-case error
442 (progn
443 (delete-process
444 (open-network-stream
445 "ffap-machine-p" nil host (or service "discard")))
447 (error
448 (let ((mesg (car (cdr error))))
449 (cond
450 ;; v18:
451 ((string-match "^Unknown host" mesg) nil)
452 ((string-match "not responding$" mesg) mesg)
453 ;; v19:
454 ;; (file-error "connection failed" "permission denied"
455 ;; "nonesuch" "ffap-machine-p")
456 ;; (file-error "connection failed" "host is unreachable"
457 ;; "gopher.house.gov" "ffap-machine-p")
458 ;; (file-error "connection failed" "address already in use"
459 ;; "ftp.uu.net" "ffap-machine-p")
460 ((equal mesg "connection failed")
461 (if (equal (nth 2 error) "permission denied")
462 nil ; host does not exist
463 ;; Other errors mean the host exists:
464 (nth 2 error)))
465 ;; Could be "Unknown service":
466 (t (signal (car error) (cdr error))))))))))))
469 ;;; Possibly Remote Resources:
471 (defun ffap-replace-file-component (fullname name)
472 "In remote FULLNAME, replace path with NAME. May return nil."
473 ;; Use ange-ftp or efs if loaded, but do not load them otherwise.
474 (let (found)
475 (mapc
476 (function (lambda (sym) (and (fboundp sym) (setq found sym))))
478 efs-replace-path-component
479 ange-ftp-replace-path-component
480 ange-ftp-replace-name-component
482 (and found
483 (fset 'ffap-replace-file-component found)
484 (funcall found fullname name))))
485 ;; (ffap-replace-file-component "/who@foo.com:/whatever" "/new")
487 (defun ffap-file-suffix (file)
488 "Return trailing `.foo' suffix of FILE, or nil if none."
489 (let ((pos (string-match "\\.[^./]*\\'" file)))
490 (and pos (substring file pos nil))))
492 (defvar ffap-compression-suffixes '(".gz" ".Z") ; .z is mostly dead
493 "List of suffixes tried by `ffap-file-exists-string'.")
495 (defun ffap-file-exists-string (file &optional nomodify)
496 ;; Early jka-compr versions modified file-exists-p to return the
497 ;; filename, maybe modified by adding a suffix like ".gz". That
498 ;; broke the interface of file-exists-p, so it was later dropped.
499 ;; Here we document and simulate the old behavior.
500 "Return FILE (maybe modified) if the file exists, else nil.
501 When using jka-compr (a.k.a. `auto-compression-mode'), the returned
502 name may have a suffix added from `ffap-compression-suffixes'.
503 The optional NOMODIFY argument suppresses the extra search."
504 (cond
505 ((not file) nil) ; quietly reject nil
506 ((file-exists-p file) file) ; try unmodified first
507 ;; three reasons to suppress search:
508 (nomodify nil)
509 ((not (rassq 'jka-compr-handler file-name-handler-alist)) nil)
510 ((member (ffap-file-suffix file) ffap-compression-suffixes) nil)
511 (t ; ok, do the search
512 (let ((list ffap-compression-suffixes) try ret)
513 (while list
514 (if (file-exists-p (setq try (concat file (car list))))
515 (setq ret try list nil)
516 (setq list (cdr list))))
517 ret))))
519 (defun ffap-file-remote-p (filename)
520 "If FILENAME looks remote, return it (maybe slightly improved)."
521 ;; (ffap-file-remote-p "/user@foo.bar.com:/pub")
522 ;; (ffap-file-remote-p "/cssun.mathcs.emory.edu://dir")
523 ;; (ffap-file-remote-p "/ffap.el:80")
524 (or (and ffap-ftp-regexp
525 (string-match ffap-ftp-regexp filename)
526 ;; Convert "/host.com://dir" to "/host:/dir", to handle a dieing
527 ;; practice of advertising ftp files as "host.dom://filename".
528 (if (string-match "//" filename)
529 ;; (replace-match "/" nil nil filename)
530 (concat (substring filename 0 (1+ (match-beginning 0)))
531 (substring filename (match-end 0)))
532 filename))
533 (and ffap-rfs-regexp
534 (string-match ffap-rfs-regexp filename)
535 filename)))
537 (defun ffap-machine-at-point ()
538 "Return machine name at point if it exists, or nil."
539 (let ((mach (ffap-string-at-point 'machine)))
540 (and (ffap-machine-p mach) mach)))
542 (defsubst ffap-host-to-filename (host)
543 "Convert HOST to something like \"/USER@HOST:\" or \"/HOST:\".
544 Looks at `ffap-ftp-default-user', returns \"\" for \"localhost\"."
545 (if (equal host "localhost")
547 (let ((user ffap-ftp-default-user))
548 ;; Avoid including the user if it is same as default:
549 (if (or (equal user (ffap-symbol-value 'ange-ftp-default-user))
550 (equal user (ffap-symbol-value 'efs-default-user)))
551 (setq user nil))
552 (concat "/" user (and user "@") host ":"))))
554 (defun ffap-fixup-machine (mach)
555 ;; Convert a hostname into an url, an ftp file name, or nil.
556 (cond
557 ((not (and ffap-url-regexp (stringp mach))) nil)
558 ;; gopher.well.com
559 ((string-match "\\`gopher[-.]" mach) ; or "info"?
560 (concat "gopher://" mach "/"))
561 ;; www.ncsa.uiuc.edu
562 ((and (string-match "\\`w\\(ww\\|eb\\)[-.]" mach))
563 (concat "http://" mach "/"))
564 ;; More cases? Maybe "telnet:" for archie?
565 (ffap-ftp-regexp (ffap-host-to-filename mach))
568 (defvar ffap-newsgroup-regexp "^[[:lower:]]+\\.[-+[:lower:]_0-9.]+$"
569 "Strings not matching this fail `ffap-newsgroup-p'.")
570 (defvar ffap-newsgroup-heads ; entirely inadequate
571 '("alt" "comp" "gnu" "misc" "news" "sci" "soc" "talk")
572 "Used by `ffap-newsgroup-p' if gnus is not running.")
574 (defun ffap-newsgroup-p (string)
575 "Return STRING if it looks like a newsgroup name, else nil."
576 (and
577 (string-match ffap-newsgroup-regexp string)
578 (let ((htbs '(gnus-active-hashtb gnus-newsrc-hashtb gnus-killed-hashtb))
579 (heads ffap-newsgroup-heads)
580 htb ret)
581 (while htbs
582 (setq htb (car htbs) htbs (cdr htbs))
583 (condition-case nil
584 (progn
585 ;; errs: htb symbol may be unbound, or not a hash-table.
586 ;; gnus-gethash is just a macro for intern-soft.
587 (and (symbol-value htb)
588 (intern-soft string (symbol-value htb))
589 (setq ret string htbs nil))
590 ;; If we made it this far, gnus is running, so ignore "heads":
591 (setq heads nil))
592 (error nil)))
593 (or ret (not heads)
594 (let ((head (string-match "\\`\\([[:lower:]]+\\)\\." string)))
595 (and head (setq head (substring string 0 (match-end 1)))
596 (member head heads)
597 (setq ret string))))
598 ;; Is there ever a need to modify string as a newsgroup name?
599 ret)))
601 (defsubst ffap-url-p (string)
602 "If STRING looks like an URL, return it (maybe improved), else nil."
603 (let ((case-fold-search t))
604 (and ffap-url-regexp (string-match ffap-url-regexp string)
605 ;; I lied, no improvement:
606 string)))
608 ;; Broke these out of ffap-fixup-url, for use of ffap-url package.
609 (defsubst ffap-url-unwrap-local (url)
610 "Return URL as a local file, or nil. Ignores `ffap-url-regexp'."
611 (and (string-match "\\`\\(file\\|ftp\\):/?\\([^/]\\|\\'\\)" url)
612 (substring url (1+ (match-end 1)))))
613 (defsubst ffap-url-unwrap-remote (url)
614 "Return URL as a remote file, or nil. Ignores `ffap-url-regexp'."
615 (and (string-match "\\`\\(ftp\\|file\\)://\\([^:/]+\\):?\\(/.*\\)" url)
616 (concat
617 (ffap-host-to-filename (substring url (match-beginning 2) (match-end 2)))
618 (substring url (match-beginning 3) (match-end 3)))))
619 ;; Test: (ffap-url-unwrap-remote "ftp://foo.com/bar.boz")
621 (defun ffap-fixup-url (url)
622 "Clean up URL and return it, maybe as a file name."
623 (cond
624 ((not (stringp url)) nil)
625 ((and ffap-url-unwrap-local (ffap-url-unwrap-local url)))
626 ((and ffap-url-unwrap-remote ffap-ftp-regexp
627 (ffap-url-unwrap-remote url)))
628 ;; All this seems to do is remove any trailing "#anchor" part (Bug#898).
629 ;;; ((fboundp 'url-normalize-url) ; may autoload url (part of w3)
630 ;;; (url-normalize-url url))
631 (url)))
634 ;;; File Name Handling:
636 ;; The upcoming ffap-alist actions need various utilities to prepare
637 ;; and search directories. Too many features here.
639 ;; (defun ffap-last (l) (while (cdr l) (setq l (cdr l))) l)
640 ;; (defun ffap-splice (func inlist)
641 ;; "Equivalent to (apply 'nconc (mapcar FUNC INLIST)), but less consing."
642 ;; (let* ((head (cons 17 nil)) (last head))
643 ;; (while inlist
644 ;; (setcdr last (funcall func (car inlist)))
645 ;; (setq last (ffap-last last) inlist (cdr inlist)))
646 ;; (cdr head)))
648 (defun ffap-list-env (env &optional empty)
649 "Return a list of strings parsed from environment variable ENV.
650 Optional EMPTY is the default list if \(getenv ENV\) is undefined, and
651 also is substituted for the first empty-string component, if there is one.
652 Uses `path-separator' to separate the path into substrings."
653 ;; We cannot use parse-colon-path (files.el), since it kills
654 ;; "//" entries using file-name-as-directory.
655 ;; Similar: dired-split, TeX-split-string, and RHOGEE's psg-list-env
656 ;; in ff-paths and bib-cite. The EMPTY arg may help mimic kpathsea.
657 (if (or empty (getenv env)) ; should return something
658 (let ((start 0) match dir ret)
659 (setq env (concat (getenv env) path-separator))
660 (while (setq match (string-match path-separator env start))
661 (setq dir (substring env start match) start (1+ match))
662 ;;(and (file-directory-p dir) (not (member dir ret)) ...)
663 (setq ret (cons dir ret)))
664 (setq ret (nreverse ret))
665 (and empty (setq match (member "" ret))
666 (progn ; allow string or list here
667 (setcdr match (append (cdr-safe empty) (cdr match)))
668 (setcar match (or (car-safe empty) empty))))
669 ret)))
671 (defun ffap-reduce-path (path)
672 "Remove duplicates and non-directories from PATH list."
673 (let (ret tem)
674 (while path
675 (setq tem path path (cdr path))
676 (if (equal (car tem) ".") (setcar tem ""))
677 (or (member (car tem) ret)
678 (not (file-directory-p (car tem)))
679 (progn (setcdr tem ret) (setq ret tem))))
680 (nreverse ret)))
682 (defun ffap-all-subdirs (dir &optional depth)
683 "Return list of all subdirectories under DIR, starting with itself.
684 Directories beginning with \".\" are ignored, and directory symlinks
685 are listed but never searched (to avoid loops).
686 Optional DEPTH limits search depth."
687 (and (file-exists-p dir)
688 (ffap-all-subdirs-loop (expand-file-name dir) (or depth -1))))
690 (defun ffap-all-subdirs-loop (dir depth) ; internal
691 (setq depth (1- depth))
692 (cons dir
693 (and (not (eq depth -1))
694 (apply 'nconc
695 (mapcar
696 (function
697 (lambda (d)
698 (cond
699 ((not (file-directory-p d)) nil)
700 ((file-symlink-p d) (list d))
701 (t (ffap-all-subdirs-loop d depth)))))
702 (directory-files dir t "\\`[^.]")
703 )))))
705 (defvar ffap-kpathsea-depth 1
706 "Bound on depth of subdirectory search in `ffap-kpathsea-expand-path'.
707 Set to 0 to avoid all searching, or nil for no limit.")
709 (defun ffap-kpathsea-expand-path (path)
710 "Replace each \"//\"-suffixed dir in PATH by a list of its subdirs.
711 The subdirs begin with the original directory, and the depth of the
712 search is bounded by `ffap-kpathsea-depth'. This is intended to mimic
713 kpathsea, a library used by some versions of TeX."
714 (apply 'nconc
715 (mapcar
716 (function
717 (lambda (dir)
718 (if (string-match "[^/]//\\'" dir)
719 (ffap-all-subdirs (substring dir 0 -2) ffap-kpathsea-depth)
720 (list dir))))
721 path)))
723 (defun ffap-locate-file (file nosuffix path)
724 ;; The current version of locate-library could almost replace this,
725 ;; except it does not let us override the suffix list. The
726 ;; compression-suffixes search moved to ffap-file-exists-string.
727 "A generic path-searching function.
728 Returns the name of file in PATH, or nil.
729 Optional NOSUFFIX, if nil or t, is like the fourth argument
730 for `load': whether to try the suffixes (\".elc\" \".el\" \"\").
731 If a nonempty list, it is a list of suffixes to try instead.
732 PATH is a list of directories.
734 This uses `ffap-file-exists-string', which may try adding suffixes from
735 `ffap-compression-suffixes'."
736 (if (file-name-absolute-p file)
737 (setq path (list (file-name-directory file))
738 file (file-name-nondirectory file)))
739 (let ((dir-ok (equal "" (file-name-nondirectory file)))
740 (suffixes-to-try
741 (cond
742 ((consp nosuffix) nosuffix)
743 (nosuffix '(""))
744 (t '(".elc" ".el" ""))))
745 suffixes try found)
746 (while path
747 (setq suffixes suffixes-to-try)
748 (while suffixes
749 (setq try (ffap-file-exists-string
750 (expand-file-name
751 (concat file (car suffixes)) (car path))))
752 (if (and try (or dir-ok (not (file-directory-p try))))
753 (setq found try suffixes nil path nil)
754 (setq suffixes (cdr suffixes))))
755 (setq path (cdr path)))
756 found))
759 ;;; Action List (`ffap-alist'):
761 ;; These search actions depend on the major-mode or regexps matching
762 ;; the current name. The little functions and their variables are
763 ;; deferred to the next section, at some loss of "code locality". A
764 ;; good example of featuritis. Trim this list for speed.
766 (defvar ffap-alist
768 ("" . ffap-completable) ; completion, slow on some systems
769 ("\\.info\\'" . ffap-info) ; gzip.info
770 ("\\`info/" . ffap-info-2) ; info/emacs
771 ("\\`[-[:lower:]]+\\'" . ffap-info-3) ; (emacs)Top [only in the parentheses]
772 ("\\.elc?\\'" . ffap-el) ; simple.el, simple.elc
773 (emacs-lisp-mode . ffap-el-mode) ; rmail, gnus, simple, custom
774 ;; (lisp-interaction-mode . ffap-el-mode) ; maybe
775 (finder-mode . ffap-el-mode) ; type {C-h p} and try it
776 (help-mode . ffap-el-mode) ; maybe useful
777 (c++-mode . ffap-c-mode) ; search ffap-c-path
778 (cc-mode . ffap-c-mode) ; same
779 ("\\.\\([chCH]\\|cc\\|hh\\)\\'" . ffap-c-mode) ; stdio.h
780 (fortran-mode . ffap-fortran-mode) ; FORTRAN requested by MDB
781 ("\\.[fF]\\'" . ffap-fortran-mode)
782 (tex-mode . ffap-tex-mode) ; search ffap-tex-path
783 (latex-mode . ffap-latex-mode) ; similar
784 ("\\.\\(tex\\|sty\\|doc\\|cls\\)\\'" . ffap-tex)
785 ("\\.bib\\'" . ffap-bib) ; search ffap-bib-path
786 ("\\`\\." . ffap-home) ; .emacs, .bashrc, .profile
787 ("\\`~/" . ffap-lcd) ; |~/misc/ffap.el.Z|
788 ;; This used to have a blank, but ffap-string-at-point doesn't
789 ;; handle blanks.
790 ;; http://lists.gnu.org/archive/html/emacs-devel/2008-01/msg01058.html
791 ("\\`[Rr][Ff][Cc][-#]?\\([0-9]+\\)" ; no $
792 . ffap-rfc) ; "100% RFC2100 compliant"
793 (dired-mode . ffap-dired) ; maybe in a subdirectory
795 "Alist of \(KEY . FUNCTION\) pairs parsed by `ffap-file-at-point'.
796 If string NAME at point (maybe \"\") is not a file or URL, these pairs
797 specify actions to try creating such a string. A pair matches if either
798 KEY is a symbol, and it equals `major-mode', or
799 KEY is a string, it should match NAME as a regexp.
800 On a match, \(FUNCTION NAME\) is called and should return a file, an
801 URL, or nil. If nil, search the alist for further matches.")
803 (put 'ffap-alist 'risky-local-variable t)
805 ;; Example `ffap-alist' modifications:
807 ;; (setq ffap-alist ; remove a feature in `ffap-alist'
808 ;; (delete (assoc 'c-mode ffap-alist) ffap-alist))
810 ;; (setq ffap-alist ; add something to `ffap-alist'
811 ;; (cons
812 ;; (cons "^YSN[0-9]+$"
813 ;; (defun ffap-ysn (name)
814 ;; (concat
815 ;; "http://www.physics.uiuc.edu/"
816 ;; "ysn/httpd/htdocs/ysnarchive/issuefiles/"
817 ;; (substring name 3) ".html")))
818 ;; ffap-alist))
821 ;;; Action Definitions:
823 ;; Define various default members of `ffap-alist'.
825 (defun ffap-completable (name)
826 (let* ((dir (or (file-name-directory name) default-directory))
827 (cmp (file-name-completion (file-name-nondirectory name) dir)))
828 (and cmp (concat dir cmp))))
830 (defun ffap-home (name) (ffap-locate-file name t '("~")))
832 (defun ffap-info (name)
833 (ffap-locate-file
834 name '("" ".info")
835 (or (ffap-symbol-value 'Info-directory-list)
836 (ffap-symbol-value 'Info-default-directory-list)
839 (defun ffap-info-2 (name) (ffap-info (substring name 5)))
841 (defun ffap-info-3 (name)
842 ;; This ignores the node! "(emacs)Top" same as "(emacs)Intro"
843 (and (equal (ffap-string-around) "()") (ffap-info name)))
845 (defun ffap-el (name) (ffap-locate-file name t load-path))
847 (defun ffap-el-mode (name)
848 ;; If name == "foo.el" we will skip it, since ffap-el already
849 ;; searched for it once. (This assumes the default ffap-alist.)
850 (and (not (string-match "\\.el\\'" name))
851 (ffap-locate-file name '(".el") load-path)))
853 (defvar ffap-c-path
854 ;; Need smarter defaults here! Suggestions welcome.
855 '("/usr/include" "/usr/local/include"))
856 (defun ffap-c-mode (name)
857 (ffap-locate-file name t ffap-c-path))
859 (defvar ffap-fortran-path '("../include" "/usr/include"))
861 (defun ffap-fortran-mode (name)
862 (ffap-locate-file name t ffap-fortran-path))
864 (defvar ffap-tex-path
865 t ; delayed initialization
866 "Path where `ffap-tex-mode' looks for TeX files.
867 If t, `ffap-tex-init' will initialize this when needed.")
869 (defun ffap-tex-init ()
870 ;; Compute ffap-tex-path if it is now t.
871 (and (eq t ffap-tex-path)
872 ;; this may be slow, so say something
873 (message "Initializing ffap-tex-path ...")
874 (setq ffap-tex-path
875 (ffap-reduce-path
876 (cons
878 (ffap-kpathsea-expand-path
879 (append
880 (ffap-list-env "TEXINPUTS")
881 ;; (ffap-list-env "BIBINPUTS")
882 (ffap-symbol-value
883 'TeX-macro-global ; AUCTeX
884 '("/usr/local/lib/tex/macros"
885 "/usr/local/lib/tex/inputs")))))))))
887 (defun ffap-tex-mode (name)
888 (ffap-tex-init)
889 (ffap-locate-file name '(".tex" "") ffap-tex-path))
891 (defun ffap-latex-mode (name)
892 (ffap-tex-init)
893 ;; only rare need for ""
894 (ffap-locate-file name '(".cls" ".sty" ".tex" "") ffap-tex-path))
896 (defun ffap-tex (name)
897 (ffap-tex-init)
898 (ffap-locate-file name t ffap-tex-path))
900 (defvar ffap-bib-path
901 (ffap-list-env "BIBINPUTS"
902 (ffap-reduce-path
904 ;; a few wild guesses, need better
905 "/usr/local/lib/tex/macros/bib" ; Solaris?
906 "/usr/lib/texmf/bibtex/bib" ; Linux?
907 ))))
909 (defun ffap-bib (name)
910 (ffap-locate-file name t ffap-bib-path))
912 (defun ffap-dired (name)
913 (let ((pt (point)) try)
914 (save-excursion
915 (and (progn
916 (beginning-of-line)
917 (looking-at " *[-d]r[-w][-x][-r][-w][-x][-r][-w][-x] "))
918 (re-search-backward "^ *$" nil t)
919 (re-search-forward "^ *\\([^ \t\n:]*\\):\n *total " pt t)
920 (file-exists-p
921 (setq try
922 (expand-file-name
923 name
924 (buffer-substring
925 (match-beginning 1) (match-end 1)))))
926 try))))
928 ;; Maybe a "Lisp Code Directory" reference:
929 (defun ffap-lcd (name)
930 ;; FIXME: Is this still in use?
931 (and
933 ;; lisp-dir-apropos output buffer:
934 (string-match "Lisp Code Dir" (buffer-name))
935 ;; Inside an LCD entry like |~/misc/ffap.el.Z|,
936 ;; or maybe the holy LCD-Datafile itself:
937 (member (ffap-string-around) '("||" "|\n")))
938 (concat
939 ;; lispdir.el may not be loaded yet:
940 (ffap-host-to-filename
941 (ffap-symbol-value 'elisp-archive-host
942 "archive.cis.ohio-state.edu"))
943 (file-name-as-directory
944 (ffap-symbol-value 'elisp-archive-directory
945 "/pub/gnu/emacs/elisp-archive/"))
946 (substring name 2))))
948 (defcustom ffap-rfc-path
949 (concat (ffap-host-to-filename "ftp.rfc-editor.org") "/in-notes/rfc%s.txt")
950 "A `format' string making a filename for RFC documents.
951 This can be an ange-ftp or tramp remote filename to download, or
952 a local filename if you have full set of RFCs locally. See also
953 `ffap-rfc-directories'."
954 :type 'string
955 :version "23.1"
956 :group 'ffap)
958 (defcustom ffap-rfc-directories nil
959 "A list of directories to look for RFC files.
960 If a given RFC isn't in these then `ffap-rfc-path' is offered."
961 :type '(repeat directory)
962 :version "23.1"
963 :group 'ffap)
965 (defun ffap-rfc (name)
966 (let ((num (match-string 1 name)))
967 (or (ffap-locate-file (format "rfc%s.txt" num) t ffap-rfc-directories)
968 (format ffap-rfc-path num))))
971 ;;; At-Point Functions:
973 (defvar ffap-string-at-point-mode-alist
975 ;; The default, used when the `major-mode' is not found.
976 ;; Slightly controversial decisions:
977 ;; * strip trailing "@" and ":"
978 ;; * no commas (good for latex)
979 (file "--:\\\\$+<>@-Z_[:alpha:]~*?" "<@" "@>;.,!:")
980 ;; An url, or maybe a email/news message-id:
981 (url "--:=&?$+@-Z_[:alpha:]~#,%;*" "^[:alnum:]" ":;.,!?")
982 ;; Find a string that does *not* contain a colon:
983 (nocolon "--9$+<>@-Z_[:alpha:]~" "<@" "@>;.,!?")
984 ;; A machine:
985 (machine "-[:alnum:]." "" ".")
986 ;; Mathematica paths: allow backquotes
987 (math-mode ",-:$+<>@-Z_[:lower:]~`" "<" "@>;.,!?`:")
989 "Alist of \(MODE CHARS BEG END\), where MODE is a symbol,
990 possibly a major-mode name, or one of the symbol
991 `file', `url', `machine', and `nocolon'.
992 `ffap-string-at-point' uses the data fields as follows:
993 1. find a maximal string of CHARS around point,
994 2. strip BEG chars before point from the beginning,
995 3. Strip END chars after point from the end.")
997 (defvar ffap-string-at-point nil
998 ;; Added at suggestion of RHOGEE (for ff-paths), 7/24/95.
999 "Last string returned by `ffap-string-at-point'.")
1001 (defun ffap-string-at-point (&optional mode)
1002 "Return a string of characters from around point.
1003 MODE (defaults to value of `major-mode') is a symbol used to look up string
1004 syntax parameters in `ffap-string-at-point-mode-alist'.
1005 If MODE is not found, we use `file' instead of MODE.
1006 If the region is active, return a string from the region.
1007 Sets `ffap-string-at-point' and `ffap-string-at-point-region'."
1008 (let* ((args
1009 (cdr
1010 (or (assq (or mode major-mode) ffap-string-at-point-mode-alist)
1011 (assq 'file ffap-string-at-point-mode-alist))))
1012 (pt (point))
1013 (str
1014 (if (and transient-mark-mode mark-active)
1015 (buffer-substring
1016 (setcar ffap-string-at-point-region (region-beginning))
1017 (setcar (cdr ffap-string-at-point-region) (region-end)))
1018 (buffer-substring
1019 (save-excursion
1020 (skip-chars-backward (car args))
1021 (skip-chars-forward (nth 1 args) pt)
1022 (setcar ffap-string-at-point-region (point)))
1023 (save-excursion
1024 (skip-chars-forward (car args))
1025 (skip-chars-backward (nth 2 args) pt)
1026 (setcar (cdr ffap-string-at-point-region) (point)))))))
1027 (set-text-properties 0 (length str) nil str)
1028 (setq ffap-string-at-point str)))
1030 (defun ffap-string-around ()
1031 ;; Sometimes useful to decide how to treat a string.
1032 "Return string of two chars around last `ffap-string-at-point'.
1033 Assumes the buffer has not changed."
1034 (save-excursion
1035 (format "%c%c"
1036 (progn
1037 (goto-char (car ffap-string-at-point-region))
1038 (preceding-char)) ; maybe 0
1039 (progn
1040 (goto-char (nth 1 ffap-string-at-point-region))
1041 (following-char)) ; maybe 0
1044 (defun ffap-copy-string-as-kill (&optional mode)
1045 ;; Requested by MCOOK. Useful?
1046 "Call `ffap-string-at-point', and copy result to `kill-ring'."
1047 (interactive)
1048 (let ((str (ffap-string-at-point mode)))
1049 (if (equal "" str)
1050 (message "No string found around point.")
1051 (kill-new str)
1052 ;; Older: (apply 'copy-region-as-kill ffap-string-at-point-region)
1053 (message "Copied to kill ring: %s" str))))
1055 ;; External.
1056 (declare-function w3-view-this-url "ext:w3" (&optional no-show))
1058 (defun ffap-url-at-point ()
1059 "Return URL from around point if it exists, or nil."
1060 ;; Could use w3's url-get-url-at-point instead. Both handle "URL:",
1061 ;; ignore non-relative links, trim punctuation. The other will
1062 ;; actually look back if point is in whitespace, but I would rather
1063 ;; ffap be less aggressive in such situations.
1064 (and
1065 ffap-url-regexp
1067 ;; In a w3 buffer button?
1068 (and (eq major-mode 'w3-mode)
1069 ;; interface recommended by wmperry:
1070 (w3-view-this-url t))
1071 ;; Is there a reason not to strip trailing colon?
1072 (let ((name (ffap-string-at-point 'url)))
1073 (cond
1074 ((string-match "^url:" name) (setq name (substring name 4)))
1075 ((and (string-match "\\`[^:</>@]+@[^:</>@]+[[:alnum:]]\\'" name)
1076 ;; "foo@bar": could be "mailto" or "news" (a Message-ID).
1077 ;; Without "<>" it must be "mailto". Otherwise could be
1078 ;; either, so consult `ffap-foo-at-bar-prefix'.
1079 (let ((prefix (if (and (equal (ffap-string-around) "<>")
1080 ;; Expect some odd characters:
1081 (string-match "[$.0-9].*[$.0-9].*@" name))
1082 ;; Could be news:
1083 ffap-foo-at-bar-prefix
1084 "mailto")))
1085 (and prefix (setq name (concat prefix ":" name))))))
1086 ((ffap-newsgroup-p name) (setq name (concat "news:" name)))
1087 ((and (string-match "\\`[[:alnum:]]+\\'" name) ; <mic> <root> <nobody>
1088 (equal (ffap-string-around) "<>")
1089 ;; (ffap-user-p name):
1090 (not (string-match "~" (expand-file-name (concat "~" name))))
1092 (setq name (concat "mailto:" name)))
1094 (and (ffap-url-p name) name)
1095 ))))
1097 (defvar ffap-gopher-regexp
1098 "^.*\\<\\(Type\\|Name\\|Path\\|Host\\|Port\\) *= *\\(.*\\) *$"
1099 "Regexp matching a line in a gopher bookmark (maybe indented).
1100 The two subexpressions are the KEY and VALUE.")
1102 (defun ffap-gopher-at-point ()
1103 "If point is inside a gopher bookmark block, return its URL."
1104 ;; `gopher-parse-bookmark' from gopher.el is not so robust
1105 (save-excursion
1106 (beginning-of-line)
1107 (if (looking-at ffap-gopher-regexp)
1108 (progn
1109 (while (and (looking-at ffap-gopher-regexp) (not (bobp)))
1110 (forward-line -1))
1111 (or (looking-at ffap-gopher-regexp) (forward-line 1))
1112 (let ((type "1") path host (port "70"))
1113 (while (looking-at ffap-gopher-regexp)
1114 (let ((var (intern
1115 (downcase
1116 (buffer-substring (match-beginning 1)
1117 (match-end 1)))))
1118 (val (buffer-substring (match-beginning 2)
1119 (match-end 2))))
1120 (set var val)
1121 (forward-line 1)))
1122 (if (and path (string-match "^ftp:.*@" path))
1123 (concat "ftp://"
1124 (substring path 4 (1- (match-end 0)))
1125 (substring path (match-end 0)))
1126 (and (= (length type) 1)
1127 host;; (ffap-machine-p host)
1128 (concat "gopher://" host
1129 (if (equal port "70") "" (concat ":" port))
1130 "/" type path))))))))
1132 (defvar ffap-ftp-sans-slash-regexp
1133 (and
1134 ffap-ftp-regexp
1135 ;; Note: by now, we know it is not an url.
1136 ;; Icky regexp avoids: default: 123: foo::bar cs:pub
1137 ;; It does match on: mic@cs: cs:/pub mathcs.emory.edu: (point at end)
1138 "\\`\\([^:@]+@[^:@]+:\\|[^@.:]+\\.[^@:]+:\\|[^:]+:[~/]\\)\\([^:]\\|\\'\\)")
1139 "Strings matching this are coerced to ftp file names by ffap.
1140 That is, ffap just prepends \"/\". Set to nil to disable.")
1142 (defun ffap-file-at-point ()
1143 "Return filename from around point if it exists, or nil.
1144 Existence test is skipped for names that look remote.
1145 If the filename is not obvious, it also tries `ffap-alist',
1146 which may actually result in an URL rather than a filename."
1147 ;; Note: this function does not need to look for url's, just
1148 ;; filenames. On the other hand, it is responsible for converting
1149 ;; a pseudo-url "site.com://dir" to an ftp file name
1150 (let* ((case-fold-search t) ; url prefixes are case-insensitive
1151 (data (match-data))
1152 (string (ffap-string-at-point)) ; uses mode alist
1153 (name
1154 (or (condition-case nil
1155 (and (not (string-match "//" string)) ; foo.com://bar
1156 (substitute-in-file-name string))
1157 (error nil))
1158 string))
1159 (abs (file-name-absolute-p name))
1160 (default-directory default-directory)
1161 (oname name))
1162 (unwind-protect
1163 (cond
1164 ;; Immediate rejects (/ and // and /* are too common in C/C++):
1165 ((member name '("" "/" "//" "/*" ".")) nil)
1166 ;; Immediately test local filenames. If default-directory is
1167 ;; remote, you probably already have a connection.
1168 ((and (not abs) (ffap-file-exists-string name)))
1169 ;; Try stripping off line numbers; good for compilation/grep output.
1170 ((and (not abs) (string-match ":[0-9]" name)
1171 (ffap-file-exists-string (substring name 0 (match-beginning 0)))))
1172 ;; Try stripping off prominent (non-root - #) shell prompts
1173 ;; if the ffap-shell-prompt-regexp is non-nil.
1174 ((and ffap-shell-prompt-regexp
1175 (not abs) (string-match ffap-shell-prompt-regexp name)
1176 (ffap-file-exists-string (substring name (match-end 0)))))
1177 ;; Accept remote names without actual checking (too slow):
1178 ((and abs (ffap-file-remote-p name)))
1179 ;; Ok, not remote, try the existence test even if it is absolute:
1180 ((and abs (ffap-file-exists-string name)))
1181 ;; Try stripping off line numbers.
1182 ((and abs (string-match ":[0-9]" name)
1183 (ffap-file-exists-string (substring name 0 (match-beginning 0)))))
1184 ;; If it contains a colon, get rid of it (and return if exists)
1185 ((and (string-match path-separator name)
1186 (setq name (ffap-string-at-point 'nocolon))
1187 (ffap-file-exists-string name)))
1188 ;; File does not exist, try the alist:
1189 ((let ((alist ffap-alist) tem try case-fold-search)
1190 (while (and alist (not try))
1191 (setq tem (car alist) alist (cdr alist))
1192 (if (or (eq major-mode (car tem))
1193 (and (stringp (car tem))
1194 (string-match (car tem) name)))
1195 (and (setq try
1196 (condition-case nil
1197 (funcall (cdr tem) name)
1198 (error nil)))
1199 (setq try (or
1200 (ffap-url-p try) ; not a file!
1201 (ffap-file-remote-p try)
1202 (ffap-file-exists-string try))))))
1203 try))
1204 ;; Try adding a leading "/" (common omission in ftp file names).
1205 ;; Note that this uses oname, which still has any colon part.
1206 ;; This should have a lower priority than the alist stuff,
1207 ;; else it matches things like "ffap.el:1234:56:Warning".
1208 ((and (not abs)
1209 ffap-ftp-sans-slash-regexp
1210 (string-match ffap-ftp-sans-slash-regexp oname)
1211 (ffap-file-remote-p (concat "/" oname))))
1212 ;; Alist failed? Try to guess an active remote connection
1213 ;; from buffer variables, and try once more, both as an
1214 ;; absolute and relative file name on that remote host.
1215 ((let* (ffap-rfs-regexp ; suppress
1216 (remote-dir
1217 (cond
1218 ((ffap-file-remote-p default-directory))
1219 ((and (eq major-mode 'internal-ange-ftp-mode)
1220 (string-match "^\\*ftp \\(.*\\)@\\(.*\\)\\*$"
1221 (buffer-name)))
1222 (concat "/" (substring (buffer-name) 5 -1) ":"))
1223 ;; This is too often a bad idea:
1224 ;;((and (eq major-mode 'w3-mode)
1225 ;; (stringp url-current-server))
1226 ;; (host-to-ange-path url-current-server))
1228 (and remote-dir
1230 (and (string-match "\\`\\(/?~?ftp\\)/" name)
1231 (ffap-file-exists-string
1232 (ffap-replace-file-component
1233 remote-dir (substring name (match-end 1)))))
1234 (ffap-file-exists-string
1235 (ffap-replace-file-component remote-dir name))))))
1236 ((and ffap-dired-wildcards
1237 (string-match ffap-dired-wildcards name)
1239 (ffap-file-exists-string (file-name-directory
1240 (directory-file-name name)))
1241 name))
1242 ;; Try all parent directories by deleting the trailing directory
1243 ;; name until existing directory is found or name stops changing
1244 ((let ((dir name))
1245 (while (and dir
1246 (not (ffap-file-exists-string dir))
1247 (not (equal dir (setq dir (file-name-directory
1248 (directory-file-name dir)))))))
1249 (ffap-file-exists-string dir)))
1251 (set-match-data data))))
1253 ;;; Prompting (`ffap-read-file-or-url'):
1255 ;; We want to complete filenames as in read-file-name, but also url's
1256 ;; which read-file-name-internal would truncate at the "//" string.
1257 ;; The solution here is to replace read-file-name-internal with
1258 ;; `ffap-read-file-or-url-internal', which checks the minibuffer
1259 ;; contents before attempting to complete filenames.
1261 (defun ffap-read-file-or-url (prompt guess)
1262 "Read file or URL from minibuffer, with PROMPT and initial GUESS."
1263 (or guess (setq guess default-directory))
1264 (let (dir)
1265 ;; Tricky: guess may have or be a local directory, like "w3/w3.elc"
1266 ;; or "w3/" or "../el/ffap.el" or "../../../"
1267 (or (ffap-url-p guess)
1268 (progn
1269 (or (ffap-file-remote-p guess)
1270 (setq guess
1271 (abbreviate-file-name (expand-file-name guess))
1273 (setq dir (file-name-directory guess))))
1274 (let ((minibuffer-completing-file-name t)
1275 (completion-ignore-case read-file-name-completion-ignore-case)
1276 (fnh-elem (cons ffap-url-regexp 'url-file-handler)))
1277 ;; Explain to `rfn-eshadow' that we can use URLs here.
1278 (push fnh-elem file-name-handler-alist)
1279 (unwind-protect
1280 (setq guess
1281 (let ((default-directory (if dir (expand-file-name dir)
1282 default-directory)))
1283 (completing-read
1284 prompt
1285 'ffap-read-file-or-url-internal
1288 (if dir (cons guess (length dir)) guess)
1289 (list 'file-name-history)
1290 (and buffer-file-name
1291 (abbreviate-file-name buffer-file-name)))))
1292 ;; Remove the special handler manually. We used to just let-bind
1293 ;; file-name-handler-alist to preserve its value, but that caused
1294 ;; other modifications to be lost (e.g. when Tramp gets loaded
1295 ;; during the completing-read call).
1296 (setq file-name-handler-alist (delq fnh-elem file-name-handler-alist))))
1297 ;; Do file substitution like (interactive "F"), suggested by MCOOK.
1298 (or (ffap-url-p guess) (setq guess (substitute-in-file-name guess)))
1299 ;; Should not do it on url's, where $ is a common (VMS?) character.
1300 ;; Note: upcoming url.el package ought to handle this automatically.
1301 guess))
1303 (defun ffap-read-url-internal (string pred action)
1304 "Complete URLs from history, treating given string as valid."
1305 (let ((hist (ffap-symbol-value 'url-global-history-hash-table)))
1306 (cond
1307 ((not action)
1308 (or (try-completion string hist pred) string))
1309 ((eq action t)
1310 (or (all-completions string hist pred) (list string)))
1311 ;; action == lambda, documented where? Tests whether string is a
1312 ;; valid "match". Let us always say yes.
1313 (t t))))
1315 (defun ffap-read-file-or-url-internal (string pred action)
1316 (unless string ;Why would this ever happen?
1317 (setq string default-directory))
1318 (if (ffap-url-p string)
1319 (ffap-read-url-internal string pred action)
1320 (read-file-name-internal string pred action)))
1322 ;; The rest of this page is just to work with package complete.el.
1323 ;; This code assumes that you load ffap.el after complete.el.
1325 ;; We must inform complete about whether our completion function
1326 ;; will do filename style completion.
1328 (defun ffap-complete-as-file-p ()
1329 ;; Will `minibuffer-completion-table' complete the minibuffer
1330 ;; contents as a filename? Assumes the minibuffer is current.
1331 ;; Note: t and non-nil mean somewhat different reasons.
1332 (if (eq minibuffer-completion-table 'ffap-read-file-or-url-internal)
1333 (not (ffap-url-p (buffer-string))) ; t
1334 (and minibuffer-completing-file-name '(t)))) ;list
1336 (and
1337 (featurep 'complete)
1338 (if (boundp 'PC-completion-as-file-name-predicate)
1339 ;; modern version of complete.el, just set the variable:
1340 (setq PC-completion-as-file-name-predicate 'ffap-complete-as-file-p)))
1343 ;;; Highlighting (`ffap-highlight'):
1345 ;; Based on overlay highlighting in Emacs 19.28 isearch.el.
1347 (defvar ffap-highlight t
1348 "If non-nil, ffap highlights the current buffer substring.")
1350 (defface ffap
1351 '((t :inherit highlight))
1352 "Face used to highlight the current buffer substring."
1353 :group 'ffap
1354 :version "22.1")
1356 (defvar ffap-highlight-overlay nil
1357 "Overlay used by `ffap-highlight'.")
1359 (defun ffap-highlight (&optional remove)
1360 "If `ffap-highlight' is set, highlight the guess in this buffer.
1361 That is, the last buffer substring found by `ffap-string-at-point'.
1362 Optional argument REMOVE means to remove any such highlighting.
1363 Uses the face `ffap' if it is defined, or else `highlight'."
1364 (cond
1365 (remove
1366 (and ffap-highlight-overlay
1367 (delete-overlay ffap-highlight-overlay))
1369 ((not ffap-highlight) nil)
1370 (ffap-highlight-overlay
1371 (move-overlay
1372 ffap-highlight-overlay
1373 (car ffap-string-at-point-region)
1374 (nth 1 ffap-string-at-point-region)
1375 (current-buffer)))
1377 (setq ffap-highlight-overlay
1378 (apply 'make-overlay ffap-string-at-point-region))
1379 (overlay-put ffap-highlight-overlay 'face 'ffap))))
1382 ;;; Main Entrance (`find-file-at-point' == `ffap'):
1384 (defun ffap-guesser ()
1385 "Return file or URL or nil, guessed from text around point."
1386 (or (and ffap-url-regexp
1387 (ffap-fixup-url (or (ffap-url-at-point)
1388 (ffap-gopher-at-point))))
1389 (ffap-file-at-point) ; may yield url!
1390 (ffap-fixup-machine (ffap-machine-at-point))))
1392 (defun ffap-prompter (&optional guess)
1393 ;; Does guess and prompt step for find-file-at-point.
1394 ;; Extra complication for the temporary highlighting.
1395 (unwind-protect
1396 ;; This catch will let ffap-alist entries do their own prompting
1397 ;; and then maybe skip over this prompt (ff-paths, for example).
1398 (catch 'ffap-prompter
1399 (ffap-read-file-or-url
1400 (if ffap-url-regexp "Find file or URL: " "Find file: ")
1401 (prog1
1402 (let ((mark-active nil))
1403 ;; Don't use the region here, since it can be something
1404 ;; completely unwieldy. If the user wants that, she could
1405 ;; use M-w before and then C-y. --Stef
1406 (setq guess (or guess (ffap-guesser)))) ; using ffap-alist here
1407 (and guess (ffap-highlight))
1409 (ffap-highlight t)))
1411 ;;;###autoload
1412 (defun find-file-at-point (&optional filename)
1413 "Find FILENAME, guessing a default from text around point.
1414 If `ffap-url-regexp' is not nil, the FILENAME may also be an URL.
1415 With a prefix, this command behaves exactly like `ffap-file-finder'.
1416 If `ffap-require-prefix' is set, the prefix meaning is reversed.
1417 See also the variables `ffap-dired-wildcards', `ffap-newfile-prompt',
1418 and the functions `ffap-file-at-point' and `ffap-url-at-point'."
1419 (interactive)
1420 (if (and (called-interactively-p 'interactive)
1421 (if ffap-require-prefix (not current-prefix-arg)
1422 current-prefix-arg))
1423 ;; Do exactly the ffap-file-finder command, even the prompting:
1424 (let (current-prefix-arg) ; we already interpreted it
1425 (call-interactively ffap-file-finder))
1426 (or filename (setq filename (ffap-prompter)))
1427 (cond
1428 ((ffap-url-p filename)
1429 (let (current-prefix-arg) ; w3 2.3.25 bug, reported by KPC
1430 (funcall ffap-url-fetcher filename)))
1431 ((and ffap-pass-wildcards-to-dired
1432 ffap-dired-wildcards
1433 (string-match ffap-dired-wildcards filename))
1434 (funcall ffap-directory-finder filename))
1435 ((and ffap-dired-wildcards
1436 (string-match ffap-dired-wildcards filename)
1437 find-file-wildcards
1438 ;; Check if it's find-file that supports wildcards arg
1439 (memq ffap-file-finder '(find-file find-alternate-file)))
1440 (funcall ffap-file-finder (expand-file-name filename) t))
1441 ((or (not ffap-newfile-prompt)
1442 (file-exists-p filename)
1443 (y-or-n-p "File does not exist, create buffer? "))
1444 (funcall ffap-file-finder
1445 ;; expand-file-name fixes "~/~/.emacs" bug sent by CHUCKR.
1446 (expand-file-name filename)))
1447 ;; User does not want to find a non-existent file:
1448 ((signal 'file-error (list "Opening file buffer"
1449 "no such file or directory"
1450 filename))))))
1452 ;; Shortcut: allow {M-x ffap} rather than {M-x find-file-at-point}.
1453 ;;;###autoload
1454 (defalias 'ffap 'find-file-at-point)
1457 ;;; Menu support (`ffap-menu'):
1459 (defvar ffap-menu-regexp nil
1460 "*If non-nil, overrides `ffap-next-regexp' during `ffap-menu'.
1461 Make this more restrictive for faster menu building.
1462 For example, try \":/\" for URL (and some ftp) references.")
1464 (defvar ffap-menu-alist nil
1465 "Buffer local cache of menu presented by `ffap-menu'.")
1466 (make-variable-buffer-local 'ffap-menu-alist)
1468 (defvar ffap-menu-text-plist
1469 (cond
1470 ((display-mouse-p) '(face bold mouse-face highlight)) ; keymap <mousy-map>
1471 (t nil))
1472 "Text properties applied to strings found by `ffap-menu-rescan'.
1473 These properties may be used to fontify the menu references.")
1475 ;;;###autoload
1476 (defun ffap-menu (&optional rescan)
1477 "Put up a menu of files and URLs mentioned in this buffer.
1478 Then set mark, jump to choice, and try to fetch it. The menu is
1479 cached in `ffap-menu-alist', and rebuilt by `ffap-menu-rescan'.
1480 The optional RESCAN argument \(a prefix, interactively\) forces
1481 a rebuild. Searches with `ffap-menu-regexp'."
1482 (interactive "P")
1483 ;; (require 'imenu) -- no longer used, but roughly emulated
1484 (if (or (not ffap-menu-alist) rescan
1485 ;; or if the first entry is wrong:
1486 (and ffap-menu-alist
1487 (let ((first (car ffap-menu-alist)))
1488 (save-excursion
1489 (goto-char (cdr first))
1490 (not (equal (car first) (ffap-guesser)))))))
1491 (ffap-menu-rescan))
1492 ;; Tail recursive:
1493 (ffap-menu-ask
1494 (if ffap-url-regexp "Find file or URL" "Find file")
1495 (cons (cons "*Rescan Buffer*" -1) ffap-menu-alist)
1496 'ffap-menu-cont))
1498 (defun ffap-menu-cont (choice) ; continuation of ffap-menu
1499 (if (< (cdr choice) 0)
1500 (ffap-menu t) ; *Rescan*
1501 (push-mark)
1502 (goto-char (cdr choice))
1503 ;; Momentary highlight:
1504 (unwind-protect
1505 (progn
1506 (and ffap-highlight (ffap-guesser) (ffap-highlight))
1507 (sit-for 0) ; display
1508 (find-file-at-point (car choice)))
1509 (ffap-highlight t))))
1511 (defun ffap-menu-ask (title alist cont)
1512 "Prompt from a menu of choices, and then apply some action.
1513 Arguments are TITLE, ALIST, and CONT \(a continuation function\).
1514 This uses either a menu or the minibuffer depending on invocation.
1515 The TITLE string is used as either the prompt or menu title.
1516 Each ALIST entry looks like (STRING . DATA) and defines one choice.
1517 Function CONT is applied to the entry chosen by the user."
1518 ;; Note: this function is used with a different continuation
1519 ;; by the ffap-url add-on package.
1520 ;; Could try rewriting to use easymenu.el or lmenu.el.
1521 (let (choice)
1522 (cond
1523 ;; Emacs mouse:
1524 ((and (fboundp 'x-popup-menu) (ffap-mouse-event))
1525 (setq choice
1526 (x-popup-menu
1528 (list "" (cons title
1529 (mapcar (lambda (i) (cons (car i) i))
1530 alist))))))
1531 ;; minibuffer with completion buffer:
1533 (let ((minibuffer-setup-hook 'minibuffer-completion-help))
1534 ;; Bug: prompting may assume unique strings, no "".
1535 (setq choice
1536 (completing-read
1537 (format "%s (default %s): " title (car (car alist)))
1538 alist nil t
1539 ;; (cons (car (car alist)) 0)
1540 nil)))
1541 (sit-for 0) ; redraw original screen
1542 ;; Convert string to its entry, or else the default:
1543 (setq choice (or (assoc choice alist) (car alist)))))
1544 (if choice
1545 (funcall cont choice)
1546 (message "No choice made!") ; possible with menus
1547 nil)))
1549 (defun ffap-menu-rescan ()
1550 "Search buffer for `ffap-menu-regexp' to build `ffap-menu-alist'.
1551 Applies `ffap-menu-text-plist' text properties at all matches."
1552 (interactive)
1553 (let ((ffap-next-regexp (or ffap-menu-regexp ffap-next-regexp))
1554 (range (- (point-max) (point-min)))
1555 (mod (buffer-modified-p)) ; was buffer modified?
1556 ;; inhibit-read-only works on read-only text properties
1557 ;; as well as read-only buffers.
1558 (inhibit-read-only t) ; to set text-properties
1559 item
1560 ;; Avoid repeated searches of the *mode-alist:
1561 (major-mode (if (assq major-mode ffap-string-at-point-mode-alist)
1562 major-mode
1563 'file)))
1564 (setq ffap-menu-alist nil)
1565 (unwind-protect
1566 (save-excursion
1567 (goto-char (point-min))
1568 (while (setq item (ffap-next-guess))
1569 (setq ffap-menu-alist (cons (cons item (point)) ffap-menu-alist))
1570 (add-text-properties (car ffap-string-at-point-region) (point)
1571 ffap-menu-text-plist)
1572 (message "Scanning...%2d%% <%s>"
1573 (/ (* 100 (- (point) (point-min))) range) item)))
1574 (or mod (restore-buffer-modified-p nil))))
1575 (message "Scanning...done")
1576 ;; Remove duplicates.
1577 (setq ffap-menu-alist ; sort by item
1578 (sort ffap-menu-alist
1579 (function
1580 (lambda (a b) (string-lessp (car a) (car b))))))
1581 (let ((ptr ffap-menu-alist)) ; remove duplicates
1582 (while (cdr ptr)
1583 (if (equal (car (car ptr)) (car (car (cdr ptr))))
1584 (setcdr ptr (cdr (cdr ptr)))
1585 (setq ptr (cdr ptr)))))
1586 (setq ffap-menu-alist ; sort by position
1587 (sort ffap-menu-alist
1588 (function
1589 (lambda (a b) (< (cdr a) (cdr b)))))))
1592 ;;; Mouse Support (`ffap-at-mouse'):
1594 ;; See the suggested binding in ffap-bindings (near eof).
1596 (defvar ffap-at-mouse-fallback nil ; ffap-menu? too time-consuming
1597 "Command invoked by `ffap-at-mouse' if nothing found at click, or nil.
1598 Ignored when `ffap-at-mouse' is called programmatically.")
1599 (put 'ffap-at-mouse-fallback 'risky-local-variable t)
1601 ;;;###autoload
1602 (defun ffap-at-mouse (e)
1603 "Find file or URL guessed from text around mouse click.
1604 Interactively, calls `ffap-at-mouse-fallback' if no guess is found.
1605 Return value:
1606 * if a guess string is found, return it (after finding it)
1607 * if the fallback is called, return whatever it returns
1608 * otherwise, nil"
1609 (interactive "e")
1610 (let ((guess
1611 ;; Maybe less surprising without the save-excursion?
1612 (save-excursion
1613 (mouse-set-point e)
1614 ;; Would prefer to do nothing unless click was *on* text. How
1615 ;; to tell that the click was beyond the end of current line?
1616 (ffap-guesser))))
1617 (cond
1618 (guess
1619 (set-buffer (ffap-event-buffer e))
1620 (ffap-highlight)
1621 (unwind-protect
1622 (progn
1623 (sit-for 0) ; display
1624 (message "Finding `%s'" guess)
1625 (find-file-at-point guess)
1626 guess) ; success: return non-nil
1627 (ffap-highlight t)))
1628 ((called-interactively-p 'interactive)
1629 (if ffap-at-mouse-fallback
1630 (call-interactively ffap-at-mouse-fallback)
1631 (message "No file or URL found at mouse click.")
1632 nil)) ; no fallback, return nil
1633 ;; failure: return nil
1637 ;;; ffap-other-*, ffap-read-only-*, ffap-alternate-* commands:
1639 ;; There could be a real `ffap-noselect' function, but we would need
1640 ;; at least two new user variables, and there is no w3-fetch-noselect.
1641 ;; So instead, we just fake it with a slow save-window-excursion.
1643 (defun ffap-other-window ()
1644 "Like `ffap', but put buffer in another window.
1645 Only intended for interactive use."
1646 (interactive)
1647 (let (value)
1648 (switch-to-buffer-other-window
1649 (save-window-excursion
1650 (setq value (call-interactively 'ffap))
1651 (unless (or (bufferp value) (bufferp (car-safe value)))
1652 (setq value (current-buffer)))
1653 (current-buffer)))
1654 value))
1656 (defun ffap-other-frame ()
1657 "Like `ffap', but put buffer in another frame.
1658 Only intended for interactive use."
1659 (interactive)
1660 ;; Extra code works around dedicated windows (noted by JENS, 7/96):
1661 (let* ((win (selected-window))
1662 (wdp (window-dedicated-p win))
1663 value)
1664 (unwind-protect
1665 (progn
1666 (set-window-dedicated-p win nil)
1667 (switch-to-buffer-other-frame
1668 (save-window-excursion
1669 (setq value (call-interactively 'ffap))
1670 (unless (or (bufferp value) (bufferp (car-safe value)))
1671 (setq value (current-buffer)))
1672 (current-buffer))))
1673 (set-window-dedicated-p win wdp))
1674 value))
1676 (defun ffap-read-only ()
1677 "Like `ffap', but mark buffer as read-only.
1678 Only intended for interactive use."
1679 (interactive)
1680 (let ((value (call-interactively 'ffap)))
1681 (unless (or (bufferp value) (bufferp (car-safe value)))
1682 (setq value (current-buffer)))
1683 (mapc (lambda (b) (with-current-buffer b (toggle-read-only 1)))
1684 (if (listp value) value (list value)))
1685 value))
1687 (defun ffap-read-only-other-window ()
1688 "Like `ffap', but put buffer in another window and mark as read-only.
1689 Only intended for interactive use."
1690 (interactive)
1691 (let ((value (ffap-other-window)))
1692 (mapc (lambda (b) (with-current-buffer b (toggle-read-only 1)))
1693 (if (listp value) value (list value)))
1694 value))
1696 (defun ffap-read-only-other-frame ()
1697 "Like `ffap', but put buffer in another frame and mark as read-only.
1698 Only intended for interactive use."
1699 (interactive)
1700 (let ((value (ffap-other-frame)))
1701 (mapc (lambda (b) (with-current-buffer b (toggle-read-only 1)))
1702 (if (listp value) value (list value)))
1703 value))
1705 (defun ffap-alternate-file ()
1706 "Like `ffap' and `find-alternate-file'.
1707 Only intended for interactive use."
1708 (interactive)
1709 (let ((ffap-file-finder 'find-alternate-file))
1710 (call-interactively 'ffap)))
1712 (defun ffap-alternate-file-other-window ()
1713 "Like `ffap' and `find-alternate-file-other-window'.
1714 Only intended for interactive use."
1715 (interactive)
1716 (let ((ffap-file-finder 'find-alternate-file-other-window))
1717 (call-interactively 'ffap)))
1719 (defun ffap-literally ()
1720 "Like `ffap' and `find-file-literally'.
1721 Only intended for interactive use."
1722 (interactive)
1723 (let ((ffap-file-finder 'find-file-literally))
1724 (call-interactively 'ffap)))
1726 (defalias 'find-file-literally-at-point 'ffap-literally)
1729 ;;; Bug Reporter:
1731 (define-obsolete-function-alias 'ffap-bug 'report-emacs-bug "23.1")
1732 (define-obsolete-function-alias 'ffap-submit-bug 'report-emacs-bug "23.1")
1735 ;;; Hooks for Gnus, VM, Rmail:
1737 ;; If you do not like these bindings, write versions with whatever
1738 ;; bindings you would prefer.
1740 (defun ffap-ro-mode-hook ()
1741 "Bind `ffap-next' and `ffap-menu' to M-l and M-m, resp."
1742 (local-set-key "\M-l" 'ffap-next)
1743 (local-set-key "\M-m" 'ffap-menu)
1746 (defun ffap-gnus-hook ()
1747 "Bind `ffap-gnus-next' and `ffap-gnus-menu' to M-l and M-m, resp."
1748 (set (make-local-variable 'ffap-foo-at-bar-prefix) "news") ; message-id's
1749 ;; Note "l", "L", "m", "M" are taken:
1750 (local-set-key "\M-l" 'ffap-gnus-next)
1751 (local-set-key "\M-m" 'ffap-gnus-menu))
1753 (defvar gnus-summary-buffer)
1754 (defvar gnus-article-buffer)
1756 ;; This code is called from gnus.
1757 (declare-function gnus-summary-select-article "gnus-sum"
1758 (&optional all-headers force pseudo article))
1760 (declare-function gnus-configure-windows "gnus-win"
1761 (setting &optional force))
1763 (defun ffap-gnus-wrapper (form) ; used by both commands below
1764 (and (eq (current-buffer) (get-buffer gnus-summary-buffer))
1765 (gnus-summary-select-article)) ; get article of current line
1766 ;; Preserve selected buffer, but do not do save-window-excursion,
1767 ;; since we want to see any window created by the form. Temporarily
1768 ;; select the article buffer, so we can see any point movement.
1769 (let ((sb (window-buffer (selected-window))))
1770 (gnus-configure-windows 'article)
1771 (pop-to-buffer gnus-article-buffer)
1772 (widen)
1773 ;; Skip headers for ffap-gnus-next (which will wrap around)
1774 (if (eq (point) (point-min)) (search-forward "\n\n" nil t))
1775 (unwind-protect
1776 (eval form)
1777 (pop-to-buffer sb))))
1779 (defun ffap-gnus-next ()
1780 "Run `ffap-next' in the gnus article buffer."
1781 (interactive) (ffap-gnus-wrapper '(ffap-next nil t)))
1783 (defun ffap-gnus-menu ()
1784 "Run `ffap-menu' in the gnus article buffer."
1785 (interactive) (ffap-gnus-wrapper '(ffap-menu)))
1788 (defcustom dired-at-point-require-prefix nil
1789 "If set, reverses the prefix argument to `dired-at-point'.
1790 This is nil so neophytes notice ffap. Experts may prefer to disable
1791 ffap most of the time."
1792 :type 'boolean
1793 :group 'ffap
1794 :version "20.3")
1796 ;;;###autoload
1797 (defun dired-at-point (&optional filename)
1798 "Start Dired, defaulting to file at point. See `ffap'.
1799 If `dired-at-point-require-prefix' is set, the prefix meaning is reversed."
1800 (interactive)
1801 (if (and (called-interactively-p 'interactive)
1802 (if dired-at-point-require-prefix
1803 (not current-prefix-arg)
1804 current-prefix-arg))
1805 (let (current-prefix-arg) ; already interpreted
1806 (call-interactively ffap-directory-finder))
1807 (or filename (setq filename (dired-at-point-prompter)))
1808 (cond
1809 ((ffap-url-p filename)
1810 (funcall ffap-url-fetcher filename))
1811 ((and ffap-dired-wildcards
1812 (string-match ffap-dired-wildcards filename))
1813 (funcall ffap-directory-finder filename))
1814 ((file-exists-p filename)
1815 (if (file-directory-p filename)
1816 (funcall ffap-directory-finder
1817 (expand-file-name filename))
1818 (funcall ffap-directory-finder
1819 (concat (expand-file-name filename) "*"))))
1820 ((and (file-writable-p
1821 (or (file-name-directory (directory-file-name filename))
1822 filename))
1823 (y-or-n-p "Directory does not exist, create it? "))
1824 (make-directory filename)
1825 (funcall ffap-directory-finder filename))
1826 ((error "No such file or directory `%s'" filename)))))
1828 (defun dired-at-point-prompter (&optional guess)
1829 ;; Does guess and prompt step for find-file-at-point.
1830 ;; Extra complication for the temporary highlighting.
1831 (unwind-protect
1832 (ffap-read-file-or-url
1833 (cond
1834 ((eq ffap-directory-finder 'list-directory)
1835 "List directory (brief): ")
1836 (ffap-url-regexp "Dired file or URL: ")
1837 (t "Dired file: "))
1838 (prog1
1839 (setq guess (or guess
1840 (let ((guess (ffap-guesser)))
1841 (if (or (not guess)
1842 (ffap-url-p guess)
1843 (ffap-file-remote-p guess))
1844 guess
1845 (setq guess (abbreviate-file-name
1846 (expand-file-name guess)))
1847 (cond
1848 ;; Interpret local directory as a directory.
1849 ((file-directory-p guess)
1850 (file-name-as-directory guess))
1851 ;; Get directory component from local files.
1852 ((file-regular-p guess)
1853 (file-name-directory guess))
1854 (guess))))
1856 (and guess (ffap-highlight))))
1857 (ffap-highlight t)))
1859 ;;; ffap-dired-other-*, ffap-list-directory commands:
1861 (defun ffap-dired-other-window ()
1862 "Like `dired-at-point', but put buffer in another window.
1863 Only intended for interactive use."
1864 (interactive)
1865 (let (value)
1866 (switch-to-buffer-other-window
1867 (save-window-excursion
1868 (setq value (call-interactively 'dired-at-point))
1869 (current-buffer)))
1870 value))
1872 (defun ffap-dired-other-frame ()
1873 "Like `dired-at-point', but put buffer in another frame.
1874 Only intended for interactive use."
1875 (interactive)
1876 ;; Extra code works around dedicated windows (noted by JENS, 7/96):
1877 (let* ((win (selected-window))
1878 (wdp (window-dedicated-p win))
1879 value)
1880 (unwind-protect
1881 (progn
1882 (set-window-dedicated-p win nil)
1883 (switch-to-buffer-other-frame
1884 (save-window-excursion
1885 (setq value (call-interactively 'dired-at-point))
1886 (current-buffer))))
1887 (set-window-dedicated-p win wdp))
1888 value))
1890 (defun ffap-list-directory ()
1891 "Like `dired-at-point' and `list-directory'.
1892 Only intended for interactive use."
1893 (interactive)
1894 (let ((ffap-directory-finder 'list-directory))
1895 (call-interactively 'dired-at-point)))
1898 ;;; Hooks to put in `file-name-at-point-functions':
1900 ;;;###autoload
1901 (progn (defun ffap-guess-file-name-at-point ()
1902 "Try to get a file name at point.
1903 This hook is intended to be put in `file-name-at-point-functions'."
1904 (when (fboundp 'ffap-guesser)
1905 ;; Logic from `ffap-read-file-or-url' and `dired-at-point-prompter'.
1906 (let ((guess (ffap-guesser)))
1907 (setq guess
1908 (if (or (not guess)
1909 (and (fboundp 'ffap-url-p)
1910 (ffap-url-p guess))
1911 (and (fboundp 'ffap-file-remote-p)
1912 (ffap-file-remote-p guess)))
1913 guess
1914 (abbreviate-file-name (expand-file-name guess))))
1915 (when guess
1916 (if (file-directory-p guess)
1917 (file-name-as-directory guess)
1918 guess))))))
1921 ;;; Offer default global bindings (`ffap-bindings'):
1923 (defvar ffap-bindings
1925 (global-set-key [S-mouse-3] 'ffap-at-mouse)
1926 (global-set-key [C-S-mouse-3] 'ffap-menu)
1928 (global-set-key "\C-x\C-f" 'find-file-at-point)
1929 (global-set-key "\C-x\C-r" 'ffap-read-only)
1930 (global-set-key "\C-x\C-v" 'ffap-alternate-file)
1932 (global-set-key "\C-x4f" 'ffap-other-window)
1933 (global-set-key "\C-x5f" 'ffap-other-frame)
1934 (global-set-key "\C-x4r" 'ffap-read-only-other-window)
1935 (global-set-key "\C-x5r" 'ffap-read-only-other-frame)
1937 (global-set-key "\C-xd" 'dired-at-point)
1938 (global-set-key "\C-x4d" 'ffap-dired-other-window)
1939 (global-set-key "\C-x5d" 'ffap-dired-other-frame)
1940 (global-set-key "\C-x\C-d" 'ffap-list-directory)
1942 (add-hook 'gnus-summary-mode-hook 'ffap-gnus-hook)
1943 (add-hook 'gnus-article-mode-hook 'ffap-gnus-hook)
1944 (add-hook 'vm-mode-hook 'ffap-ro-mode-hook)
1945 (add-hook 'rmail-mode-hook 'ffap-ro-mode-hook)
1946 ;; (setq dired-x-hands-off-my-keys t) ; the default
1948 "List of binding forms evaluated by function `ffap-bindings'.
1949 A reasonable ffap installation needs just this one line:
1950 (ffap-bindings)
1951 Of course if you do not like these bindings, just roll your own!")
1953 ;;;###autoload
1954 (defun ffap-bindings ()
1955 "Evaluate the forms in variable `ffap-bindings'."
1956 (interactive)
1957 (eval (cons 'progn ffap-bindings)))
1960 (provide 'ffap)
1962 ;;; ffap.el ends here