1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978 |
- (define-obsolete-variable-alias 'ffap-version 'emacs-version "23.2")
- (defgroup ffap nil
- "Find file or URL at point."
-
- :group 'matching
- :group 'convenience)
- (defun ffap-symbol-value (sym &optional default)
- "Return value of symbol SYM, if bound, or DEFAULT otherwise."
- (if (boundp sym) (symbol-value sym) default))
- (defcustom ffap-shell-prompt-regexp
-
-
-
- "[$%><]*"
- "Paths matching this regexp are stripped off the shell prompt.
- If nil, ffap doesn't do shell prompt stripping."
- :type '(choice (const :tag "Disable" nil)
- (const :tag "Standard" "[$%><]*")
- regexp)
- :group 'ffap)
- (defcustom ffap-ftp-regexp
-
-
- "\\`/[^/:]+:"
- "File names matching this regexp are treated as remote ffap.
- If nil, ffap neither recognizes nor generates such names."
- :type '(choice (const :tag "Disable" nil)
- (const :tag "Standard" "\\`/[^/:]+:")
- regexp)
- :group 'ffap)
- (defcustom ffap-url-unwrap-local t
- "If non-nil, convert `file:' URL to local file name before prompting."
- :type 'boolean
- :group 'ffap)
- (defcustom ffap-url-unwrap-remote t
- "If non-nil, convert `ftp:' URL to remote file name before prompting.
- This is ignored if `ffap-ftp-regexp' is nil."
- :type 'boolean
- :group 'ffap)
- (defcustom ffap-ftp-default-user "anonymous"
- "User name in ftp file names generated by `ffap-host-to-path'.
- Note this name may be omitted if it equals the default
- \(either `efs-default-user' or `ange-ftp-default-user'\)."
- :type 'string
- :group 'ffap)
- (defcustom ffap-rfs-regexp
-
- "\\`/\\(afs\\|net\\)/."
-
- "Matching file names are treated as remote. Use nil to disable."
- :type 'regexp
- :group 'ffap)
- (defvar ffap-url-regexp
-
-
- (concat
- "\\`\\("
- "news\\(post\\)?:\\|mailto:\\|file:"
- "\\|"
- "\\(ftp\\|https?\\|telnet\\|gopher\\|www\\|wais\\)://"
- "\\)."
- )
- "Regexp matching URLs. Use nil to disable URL features in ffap.")
- (defcustom ffap-foo-at-bar-prefix "mailto"
- "Presumed URL prefix type of strings like \"<foo.9z@bar>\".
- Sensible values are nil, \"news\", or \"mailto\"."
- :type '(choice (const "mailto")
- (const "news")
- (const :tag "Disable" nil)
-
- )
- :group 'ffap)
- (defcustom ffap-dired-wildcards "[*?][^/]*\\'"
- "A regexp matching filename wildcard characters, or nil.
- If `find-file-at-point' gets a filename matching this pattern,
- and `ffap-pass-wildcards-to-dired' is nil, it passes it on to
- `find-file' with non-nil WILDCARDS argument, which expands
- wildcards and visits multiple files. To visit a file whose name
- contains wildcard characters you can suppress wildcard expansion
- by setting `find-file-wildcards'. If `find-file-at-point' gets a
- filename matching this pattern and `ffap-pass-wildcards-to-dired'
- is non-nil, it passes it on to `dired'.
- If `dired-at-point' gets a filename matching this pattern,
- it passes it on to `dired'."
- :type '(choice (const :tag "Disable" nil)
- (const :tag "Enable" "[*?][^/]*\\'")
-
- )
- :group 'ffap)
- (defcustom ffap-pass-wildcards-to-dired nil
- "If non-nil, pass filenames matching `ffap-dired-wildcards' to dired."
- :type 'boolean
- :group 'ffap)
- (defcustom ffap-newfile-prompt nil
-
-
- "Whether `find-file-at-point' prompts about a nonexistent file."
- :type 'boolean
- :group 'ffap)
- (defcustom ffap-require-prefix nil
-
- "If set, reverses the prefix argument to `find-file-at-point'.
- This is nil so neophytes notice ffap. Experts may prefer to disable
- ffap most of the time."
- :type 'boolean
- :group 'ffap)
- (defcustom ffap-file-finder 'find-file
- "The command called by `find-file-at-point' to find a file."
- :type 'function
- :group 'ffap)
- (put 'ffap-file-finder 'risky-local-variable t)
- (defcustom ffap-directory-finder 'dired
- "The command called by `dired-at-point' to find a directory."
- :type 'function
- :group 'ffap)
- (put 'ffap-directory-finder 'risky-local-variable t)
- (defcustom ffap-url-fetcher
- (if (fboundp 'browse-url)
- 'browse-url
- 'w3-fetch)
-
-
-
- "A function of one argument, called by ffap to fetch an URL.
- Reasonable choices are `w3-fetch' or a `browse-url-*' function.
- For a fancy alternative, get `ffap-url.el'."
- :type '(choice (const w3-fetch)
- (const browse-url)
- (const browse-url-netscape)
- (const browse-url-mosaic)
- function)
- :group 'ffap)
- (put 'ffap-url-fetcher 'risky-local-variable t)
- (defun ffap-mouse-event ()
- (and (listp last-nonmenu-event) last-nonmenu-event))
- (defun ffap-event-buffer (event)
- (window-buffer (car (event-start event))))
- (defcustom ffap-next-regexp
-
-
-
-
-
-
- "[/:.~[:alpha:]]/\\|@[[:alpha:]][-[:alnum:]]*\\."
- "Regular expression governing movements of `ffap-next'."
- :type 'regexp
- :group 'ffap)
- (defvar ffap-next-guess nil
- "Last value returned by `ffap-next-guess'.")
- (defvar ffap-string-at-point-region '(1 1)
- "List (BEG END), last region returned by `ffap-string-at-point'.")
- (defun ffap-next-guess (&optional back lim)
- "Move point to next file or URL, and return it as a string.
- If nothing is found, leave point at limit and return nil.
- Optional BACK argument makes search backwards.
- Optional LIM argument limits the search.
- Only considers strings that match `ffap-next-regexp'."
- (or lim (setq lim (if back (point-min) (point-max))))
- (let (guess)
- (while (not (or guess (eq (point) lim)))
- (funcall (if back 're-search-backward 're-search-forward)
- ffap-next-regexp lim 'move)
- (setq guess (ffap-guesser)))
-
- (goto-char (nth (if back 0 1) ffap-string-at-point-region))
- (setq ffap-next-guess guess)))
- (defun ffap-next (&optional back wrap)
- "Search buffer for next file or URL, and run ffap.
- Optional argument BACK says to search backwards.
- Optional argument WRAP says to try wrapping around if necessary.
- Interactively: use a single prefix to search backwards,
- double prefix to wrap forward, triple to wrap backwards.
- Actual search is done by `ffap-next-guess'."
- (interactive
- (cdr (assq (prefix-numeric-value current-prefix-arg)
- '((1) (4 t) (16 nil t) (64 t t)))))
- (let ((pt (point))
- (guess (ffap-next-guess back)))
-
- (and (not guess) wrap
- (goto-char (if back (point-max) (point-min)))
- (setq guess (ffap-next-guess back pt)))
- (if guess
- (progn
- (sit-for 0)
- (find-file-at-point (ffap-prompter guess)))
- (goto-char pt)
- (message "No %sfiles or URL's found"
- (if wrap "" "more ")))))
- (defun ffap-next-url (&optional back wrap)
- "Like `ffap-next', but search with `ffap-url-regexp'."
- (interactive)
- (let ((ffap-next-regexp ffap-url-regexp))
- (if (called-interactively-p 'interactive)
- (call-interactively 'ffap-next)
- (ffap-next back wrap))))
- (defcustom ffap-machine-p-local 'reject
- "What `ffap-machine-p' does with hostnames that have no domain.
- Value should be a symbol, one of `ping', `accept', and `reject'."
- :type '(choice (const ping)
- (const accept)
- (const reject))
- :group 'ffap)
- (defcustom ffap-machine-p-known 'ping
- "What `ffap-machine-p' does with hostnames that have a known domain.
- Value should be a symbol, one of `ping', `accept', and `reject'.
- See `mail-extr.el' for the known domains."
- :type '(choice (const ping)
- (const accept)
- (const reject))
- :group 'ffap)
- (defcustom ffap-machine-p-unknown 'reject
- "What `ffap-machine-p' does with hostnames that have an unknown domain.
- Value should be a symbol, one of `ping', `accept', and `reject'.
- See `mail-extr.el' for the known domains."
- :type '(choice (const ping)
- (const accept)
- (const reject))
- :group 'ffap)
- (defun ffap-what-domain (domain)
-
- (require 'mail-extr)
- (let ((ob (or (ffap-symbol-value 'mail-extr-all-top-level-domains)
- (ffap-symbol-value 'all-top-level-domains))))
- (and ob (get (intern-soft (downcase domain) ob) 'domain-name))))
- (defun ffap-machine-p (host &optional service quiet strategy)
- "Decide whether HOST is the name of a real, reachable machine.
- Depending on the domain (none, known, or unknown), follow the strategy
- named by the variable `ffap-machine-p-local', `ffap-machine-p-known',
- or `ffap-machine-p-unknown'. Pinging uses `open-network-stream'.
- Optional SERVICE specifies the port used \(default \"discard\"\).
- Optional QUIET flag suppresses the \"Pinging...\" message.
- Optional STRATEGY overrides the three variables above.
- Returned values:
- t means that HOST answered.
- 'accept means the relevant variable told us to accept.
- \"mesg\" means HOST exists, but does not respond for some reason."
-
-
-
-
-
-
-
- (if (or (string-match "[^-[:alnum:].]" host)
- (not (string-match "[^0-9]" host)))
- nil
- (let* ((domain
- (and (string-match "\\.[^.]*$" host)
- (downcase (substring host (1+ (match-beginning 0))))))
- (what-domain (if domain (ffap-what-domain domain) "Local")))
- (or strategy
- (setq strategy
- (cond ((not domain) ffap-machine-p-local)
- ((not what-domain) ffap-machine-p-unknown)
- (t ffap-machine-p-known))))
- (cond
- ((eq strategy 'accept) 'accept)
- ((eq strategy 'reject) nil)
- ((not (fboundp 'open-network-stream)) nil)
-
- (t
- (or quiet
- (if (stringp what-domain)
- (message "Pinging %s (%s)..." host what-domain)
- (message "Pinging %s ..." host)))
- (condition-case error
- (progn
- (delete-process
- (open-network-stream
- "ffap-machine-p" nil host (or service "discard")))
- t)
- (error
- (let ((mesg (car (cdr error))))
- (cond
-
- ((string-match "^Unknown host" mesg) nil)
- ((string-match "not responding$" mesg) mesg)
-
-
-
-
-
-
-
- ((equal mesg "connection failed")
- (if (equal (nth 2 error) "permission denied")
- nil
-
- (nth 2 error)))
-
- (t (signal (car error) (cdr error))))))))))))
- (defun ffap-replace-file-component (fullname name)
- "In remote FULLNAME, replace path with NAME. May return nil."
-
- (let (found)
- (mapc
- (function (lambda (sym) (and (fboundp sym) (setq found sym))))
- '(
- efs-replace-path-component
- ange-ftp-replace-path-component
- ange-ftp-replace-name-component
- ))
- (and found
- (fset 'ffap-replace-file-component found)
- (funcall found fullname name))))
- (defun ffap-file-suffix (file)
- "Return trailing `.foo' suffix of FILE, or nil if none."
- (let ((pos (string-match "\\.[^./]*\\'" file)))
- (and pos (substring file pos nil))))
- (defvar ffap-compression-suffixes '(".gz" ".Z")
- "List of suffixes tried by `ffap-file-exists-string'.")
- (defun ffap-file-exists-string (file &optional nomodify)
-
-
-
-
- "Return FILE (maybe modified) if the file exists, else nil.
- When using jka-compr (a.k.a. `auto-compression-mode'), the returned
- name may have a suffix added from `ffap-compression-suffixes'.
- The optional NOMODIFY argument suppresses the extra search."
- (cond
- ((not file) nil)
- ((file-exists-p file) file)
-
- (nomodify nil)
- ((not (rassq 'jka-compr-handler file-name-handler-alist)) nil)
- ((member (ffap-file-suffix file) ffap-compression-suffixes) nil)
- (t
- (let ((list ffap-compression-suffixes) try ret)
- (while list
- (if (file-exists-p (setq try (concat file (car list))))
- (setq ret try list nil)
- (setq list (cdr list))))
- ret))))
- (defun ffap-file-remote-p (filename)
- "If FILENAME looks remote, return it (maybe slightly improved)."
-
-
-
- (or (and ffap-ftp-regexp
- (string-match ffap-ftp-regexp filename)
-
-
- (if (string-match "//" filename)
-
- (concat (substring filename 0 (1+ (match-beginning 0)))
- (substring filename (match-end 0)))
- filename))
- (and ffap-rfs-regexp
- (string-match ffap-rfs-regexp filename)
- filename)))
- (defun ffap-machine-at-point ()
- "Return machine name at point if it exists, or nil."
- (let ((mach (ffap-string-at-point 'machine)))
- (and (ffap-machine-p mach) mach)))
- (defsubst ffap-host-to-filename (host)
- "Convert HOST to something like \"/USER@HOST:\" or \"/HOST:\".
- Looks at `ffap-ftp-default-user', returns \"\" for \"localhost\"."
- (if (equal host "localhost")
- ""
- (let ((user ffap-ftp-default-user))
-
- (if (or (equal user (ffap-symbol-value 'ange-ftp-default-user))
- (equal user (ffap-symbol-value 'efs-default-user)))
- (setq user nil))
- (concat "/" user (and user "@") host ":"))))
- (defun ffap-fixup-machine (mach)
-
- (cond
- ((not (and ffap-url-regexp (stringp mach))) nil)
-
- ((string-match "\\`gopher[-.]" mach)
- (concat "gopher://" mach "/"))
-
- ((and (string-match "\\`w\\(ww\\|eb\\)[-.]" mach))
- (concat "http://" mach "/"))
-
- (ffap-ftp-regexp (ffap-host-to-filename mach))
- ))
- (defvar ffap-newsgroup-regexp "^[[:lower:]]+\\.[-+[:lower:]_0-9.]+$"
- "Strings not matching this fail `ffap-newsgroup-p'.")
- (defvar ffap-newsgroup-heads
- '("alt" "comp" "gnu" "misc" "news" "sci" "soc" "talk")
- "Used by `ffap-newsgroup-p' if gnus is not running.")
- (defun ffap-newsgroup-p (string)
- "Return STRING if it looks like a newsgroup name, else nil."
- (and
- (string-match ffap-newsgroup-regexp string)
- (let ((htbs '(gnus-active-hashtb gnus-newsrc-hashtb gnus-killed-hashtb))
- (heads ffap-newsgroup-heads)
- htb ret)
- (while htbs
- (setq htb (car htbs) htbs (cdr htbs))
- (condition-case nil
- (progn
-
-
- (and (symbol-value htb)
- (intern-soft string (symbol-value htb))
- (setq ret string htbs nil))
-
- (setq heads nil))
- (error nil)))
- (or ret (not heads)
- (let ((head (string-match "\\`\\([[:lower:]]+\\)\\." string)))
- (and head (setq head (substring string 0 (match-end 1)))
- (member head heads)
- (setq ret string))))
-
- ret)))
- (defsubst ffap-url-p (string)
- "If STRING looks like an URL, return it (maybe improved), else nil."
- (let ((case-fold-search t))
- (and ffap-url-regexp (string-match ffap-url-regexp string)
-
- string)))
- (defsubst ffap-url-unwrap-local (url)
- "Return URL as a local file, or nil. Ignores `ffap-url-regexp'."
- (and (string-match "\\`\\(file\\|ftp\\):/?\\([^/]\\|\\'\\)" url)
- (substring url (1+ (match-end 1)))))
- (defsubst ffap-url-unwrap-remote (url)
- "Return URL as a remote file, or nil. Ignores `ffap-url-regexp'."
- (and (string-match "\\`\\(ftp\\|file\\)://\\([^:/]+\\):?\\(/.*\\)" url)
- (concat
- (ffap-host-to-filename (substring url (match-beginning 2) (match-end 2)))
- (substring url (match-beginning 3) (match-end 3)))))
- (defun ffap-fixup-url (url)
- "Clean up URL and return it, maybe as a file name."
- (cond
- ((not (stringp url)) nil)
- ((and ffap-url-unwrap-local (ffap-url-unwrap-local url)))
- ((and ffap-url-unwrap-remote ffap-ftp-regexp
- (ffap-url-unwrap-remote url)))
-
- (url)))
- (defun ffap-list-env (env &optional empty)
- "Return a list of strings parsed from environment variable ENV.
- Optional EMPTY is the default list if \(getenv ENV\) is undefined, and
- also is substituted for the first empty-string component, if there is one.
- Uses `path-separator' to separate the path into substrings."
-
-
-
-
- (if (or empty (getenv env))
- (let ((start 0) match dir ret)
- (setq env (concat (getenv env) path-separator))
- (while (setq match (string-match path-separator env start))
- (setq dir (substring env start match) start (1+ match))
-
- (setq ret (cons dir ret)))
- (setq ret (nreverse ret))
- (and empty (setq match (member "" ret))
- (progn
- (setcdr match (append (cdr-safe empty) (cdr match)))
- (setcar match (or (car-safe empty) empty))))
- ret)))
- (defun ffap-reduce-path (path)
- "Remove duplicates and non-directories from PATH list."
- (let (ret tem)
- (while path
- (setq tem path path (cdr path))
- (if (equal (car tem) ".") (setcar tem ""))
- (or (member (car tem) ret)
- (not (file-directory-p (car tem)))
- (progn (setcdr tem ret) (setq ret tem))))
- (nreverse ret)))
- (defun ffap-all-subdirs (dir &optional depth)
- "Return list of all subdirectories under DIR, starting with itself.
- Directories beginning with \".\" are ignored, and directory symlinks
- are listed but never searched (to avoid loops).
- Optional DEPTH limits search depth."
- (and (file-exists-p dir)
- (ffap-all-subdirs-loop (expand-file-name dir) (or depth -1))))
- (defun ffap-all-subdirs-loop (dir depth)
- (setq depth (1- depth))
- (cons dir
- (and (not (eq depth -1))
- (apply 'nconc
- (mapcar
- (function
- (lambda (d)
- (cond
- ((not (file-directory-p d)) nil)
- ((file-symlink-p d) (list d))
- (t (ffap-all-subdirs-loop d depth)))))
- (directory-files dir t "\\`[^.]")
- )))))
- (defvar ffap-kpathsea-depth 1
- "Bound on depth of subdirectory search in `ffap-kpathsea-expand-path'.
- Set to 0 to avoid all searching, or nil for no limit.")
- (defun ffap-kpathsea-expand-path (path)
- "Replace each \"//\"-suffixed dir in PATH by a list of its subdirs.
- The subdirs begin with the original directory, and the depth of the
- search is bounded by `ffap-kpathsea-depth'. This is intended to mimic
- kpathsea, a library used by some versions of TeX."
- (apply 'nconc
- (mapcar
- (function
- (lambda (dir)
- (if (string-match "[^/]//\\'" dir)
- (ffap-all-subdirs (substring dir 0 -2) ffap-kpathsea-depth)
- (list dir))))
- path)))
- (defun ffap-locate-file (file nosuffix path)
-
-
-
- "A generic path-searching function.
- Returns the name of file in PATH, or nil.
- Optional NOSUFFIX, if nil or t, is like the fourth argument
- for `load': whether to try the suffixes (\".elc\" \".el\" \"\").
- If a nonempty list, it is a list of suffixes to try instead.
- PATH is a list of directories.
- This uses `ffap-file-exists-string', which may try adding suffixes from
- `ffap-compression-suffixes'."
- (if (file-name-absolute-p file)
- (setq path (list (file-name-directory file))
- file (file-name-nondirectory file)))
- (let ((dir-ok (equal "" (file-name-nondirectory file)))
- (suffixes-to-try
- (cond
- ((consp nosuffix) nosuffix)
- (nosuffix '(""))
- (t '(".elc" ".el" ""))))
- suffixes try found)
- (while path
- (setq suffixes suffixes-to-try)
- (while suffixes
- (setq try (ffap-file-exists-string
- (expand-file-name
- (concat file (car suffixes)) (car path))))
- (if (and try (or dir-ok (not (file-directory-p try))))
- (setq found try suffixes nil path nil)
- (setq suffixes (cdr suffixes))))
- (setq path (cdr path)))
- found))
- (defvar ffap-alist
- '(
- ("" . ffap-completable)
- ("\\.info\\'" . ffap-info)
- ("\\`info/" . ffap-info-2)
- ("\\`[-[:lower:]]+\\'" . ffap-info-3)
- ("\\.elc?\\'" . ffap-el)
- (emacs-lisp-mode . ffap-el-mode)
-
- (finder-mode . ffap-el-mode)
- (help-mode . ffap-el-mode)
- (c++-mode . ffap-c-mode)
- (cc-mode . ffap-c-mode)
- ("\\.\\([chCH]\\|cc\\|hh\\)\\'" . ffap-c-mode)
- (fortran-mode . ffap-fortran-mode)
- ("\\.[fF]\\'" . ffap-fortran-mode)
- (tex-mode . ffap-tex-mode)
- (latex-mode . ffap-latex-mode)
- ("\\.\\(tex\\|sty\\|doc\\|cls\\)\\'" . ffap-tex)
- ("\\.bib\\'" . ffap-bib)
- ("\\`\\." . ffap-home)
- ("\\`~/" . ffap-lcd)
-
-
-
- ("\\`[Rr][Ff][Cc][-#]?\\([0-9]+\\)"
- . ffap-rfc)
- (dired-mode . ffap-dired)
- )
- "Alist of \(KEY . FUNCTION\) pairs parsed by `ffap-file-at-point'.
- If string NAME at point (maybe \"\") is not a file or URL, these pairs
- specify actions to try creating such a string. A pair matches if either
- KEY is a symbol, and it equals `major-mode', or
- KEY is a string, it should match NAME as a regexp.
- On a match, \(FUNCTION NAME\) is called and should return a file, an
- URL, or nil. If nil, search the alist for further matches.")
- (put 'ffap-alist 'risky-local-variable t)
- (defun ffap-completable (name)
- (let* ((dir (or (file-name-directory name) default-directory))
- (cmp (file-name-completion (file-name-nondirectory name) dir)))
- (and cmp (concat dir cmp))))
- (defun ffap-home (name) (ffap-locate-file name t '("~")))
- (defun ffap-info (name)
- (ffap-locate-file
- name '("" ".info")
- (or (ffap-symbol-value 'Info-directory-list)
- (ffap-symbol-value 'Info-default-directory-list)
- )))
- (defun ffap-info-2 (name) (ffap-info (substring name 5)))
- (defun ffap-info-3 (name)
-
- (and (equal (ffap-string-around) "()") (ffap-info name)))
- (defun ffap-el (name) (ffap-locate-file name t load-path))
- (defun ffap-el-mode (name)
-
-
- (and (not (string-match "\\.el\\'" name))
- (ffap-locate-file name '(".el") load-path)))
- (defvar ffap-c-path
- (let ((arch (with-temp-buffer
- (when (eq 0 (ignore-errors
- (call-process "gcc" nil '(t nil) nil
- "-print-multiarch")))
- (goto-char (point-min))
- (buffer-substring (point) (line-end-position)))))
- (base '("/usr/include" "/usr/local/include")))
- (if (zerop (length arch))
- base
- (append base (list (expand-file-name arch "/usr/include")))))
- "List of directories to search for include files.")
- (defun ffap-c-mode (name)
- (ffap-locate-file name t ffap-c-path))
- (defvar ffap-fortran-path '("../include" "/usr/include"))
- (defun ffap-fortran-mode (name)
- (ffap-locate-file name t ffap-fortran-path))
- (defvar ffap-tex-path
- t
- "Path where `ffap-tex-mode' looks for TeX files.
- If t, `ffap-tex-init' will initialize this when needed.")
- (defun ffap-tex-init ()
-
- (and (eq t ffap-tex-path)
-
- (message "Initializing ffap-tex-path ...")
- (setq ffap-tex-path
- (ffap-reduce-path
- (cons
- "."
- (ffap-kpathsea-expand-path
- (append
- (ffap-list-env "TEXINPUTS")
-
- (ffap-symbol-value
- 'TeX-macro-global
- '("/usr/local/lib/tex/macros"
- "/usr/local/lib/tex/inputs")))))))))
- (defun ffap-tex-mode (name)
- (ffap-tex-init)
- (ffap-locate-file name '(".tex" "") ffap-tex-path))
- (defun ffap-latex-mode (name)
- (ffap-tex-init)
-
- (ffap-locate-file name '(".cls" ".sty" ".tex" "") ffap-tex-path))
- (defun ffap-tex (name)
- (ffap-tex-init)
- (ffap-locate-file name t ffap-tex-path))
- (defvar ffap-bib-path
- (ffap-list-env "BIBINPUTS"
- (ffap-reduce-path
- '(
-
- "/usr/local/lib/tex/macros/bib"
- "/usr/lib/texmf/bibtex/bib"
- ))))
- (defun ffap-bib (name)
- (ffap-locate-file name t ffap-bib-path))
- (defun ffap-dired (name)
- (let ((pt (point)) try)
- (save-excursion
- (and (progn
- (beginning-of-line)
- (looking-at " *[-d]r[-w][-x][-r][-w][-x][-r][-w][-x] "))
- (re-search-backward "^ *$" nil t)
- (re-search-forward "^ *\\([^ \t\n:]*\\):\n *total " pt t)
- (file-exists-p
- (setq try
- (expand-file-name
- name
- (buffer-substring
- (match-beginning 1) (match-end 1)))))
- try))))
- (defun ffap-lcd (name)
-
- (and
- (or
-
- (string-match "Lisp Code Dir" (buffer-name))
-
-
- (member (ffap-string-around) '("||" "|\n")))
- (concat
-
- (ffap-host-to-filename
- (ffap-symbol-value 'elisp-archive-host
- "archive.cis.ohio-state.edu"))
- (file-name-as-directory
- (ffap-symbol-value 'elisp-archive-directory
- "/pub/gnu/emacs/elisp-archive/"))
- (substring name 2))))
- (defcustom ffap-rfc-path
- (concat (ffap-host-to-filename "ftp.rfc-editor.org") "/in-notes/rfc%s.txt")
- "A `format' string making a filename for RFC documents.
- This can be an ange-ftp or tramp remote filename to download, or
- a local filename if you have full set of RFCs locally. See also
- `ffap-rfc-directories'."
- :type 'string
- :version "23.1"
- :group 'ffap)
- (defcustom ffap-rfc-directories nil
- "A list of directories to look for RFC files.
- If a given RFC isn't in these then `ffap-rfc-path' is offered."
- :type '(repeat directory)
- :version "23.1"
- :group 'ffap)
- (defun ffap-rfc (name)
- (let ((num (match-string 1 name)))
- (or (ffap-locate-file (format "rfc%s.txt" num) t ffap-rfc-directories)
- (format ffap-rfc-path num))))
- (defvar ffap-string-at-point-mode-alist
- '(
-
-
-
-
- (file "--:\\\\$+<>@-Z_[:alpha:]~*?" "<@" "@>;.,!:")
-
- (url "--:=&?$+@-Z_[:alpha:]~#,%;*" "^[:alnum:]" ":;.,!?")
-
- (nocolon "--9$+<>@-Z_[:alpha:]~" "<@" "@>;.,!?")
-
- (machine "-[:alnum:]." "" ".")
-
- (math-mode ",-:$+<>@-Z_[:lower:]~`" "<" "@>;.,!?`:")
- )
- "Alist of \(MODE CHARS BEG END\), where MODE is a symbol,
- possibly a major-mode name, or one of the symbol
- `file', `url', `machine', and `nocolon'.
- `ffap-string-at-point' uses the data fields as follows:
- 1. find a maximal string of CHARS around point,
- 2. strip BEG chars before point from the beginning,
- 3. Strip END chars after point from the end.")
- (defvar ffap-string-at-point nil
-
- "Last string returned by `ffap-string-at-point'.")
- (defun ffap-string-at-point (&optional mode)
- "Return a string of characters from around point.
- MODE (defaults to value of `major-mode') is a symbol used to look up string
- syntax parameters in `ffap-string-at-point-mode-alist'.
- If MODE is not found, we use `file' instead of MODE.
- If the region is active, return a string from the region.
- Sets `ffap-string-at-point' and `ffap-string-at-point-region'."
- (let* ((args
- (cdr
- (or (assq (or mode major-mode) ffap-string-at-point-mode-alist)
- (assq 'file ffap-string-at-point-mode-alist))))
- (pt (point))
- (str
- (if (and transient-mark-mode mark-active)
- (buffer-substring
- (setcar ffap-string-at-point-region (region-beginning))
- (setcar (cdr ffap-string-at-point-region) (region-end)))
- (buffer-substring
- (save-excursion
- (skip-chars-backward (car args))
- (skip-chars-forward (nth 1 args) pt)
- (setcar ffap-string-at-point-region (point)))
- (save-excursion
- (skip-chars-forward (car args))
- (skip-chars-backward (nth 2 args) pt)
- (setcar (cdr ffap-string-at-point-region) (point)))))))
- (set-text-properties 0 (length str) nil str)
- (setq ffap-string-at-point str)))
- (defun ffap-string-around ()
-
- "Return string of two chars around last `ffap-string-at-point'.
- Assumes the buffer has not changed."
- (save-excursion
- (format "%c%c"
- (progn
- (goto-char (car ffap-string-at-point-region))
- (preceding-char))
- (progn
- (goto-char (nth 1 ffap-string-at-point-region))
- (following-char))
- )))
- (defun ffap-copy-string-as-kill (&optional mode)
-
- "Call `ffap-string-at-point', and copy result to `kill-ring'."
- (interactive)
- (let ((str (ffap-string-at-point mode)))
- (if (equal "" str)
- (message "No string found around point.")
- (kill-new str)
-
- (message "Copied to kill ring: %s" str))))
- (declare-function w3-view-this-url "ext:w3" (&optional no-show))
- (defun ffap-url-at-point ()
- "Return URL from around point if it exists, or nil."
-
-
-
-
- (and
- ffap-url-regexp
- (or
-
- (and (eq major-mode 'w3-mode)
-
- (w3-view-this-url t))
-
- (let ((name (ffap-string-at-point 'url)))
- (cond
- ((string-match "^url:" name) (setq name (substring name 4)))
- ((and (string-match "\\`[^:</>@]+@[^:</>@]+[[:alnum:]]\\'" name)
-
-
-
- (let ((prefix (if (and (equal (ffap-string-around) "<>")
-
- (string-match "[$.0-9].*[$.0-9].*@" name))
-
- ffap-foo-at-bar-prefix
- "mailto")))
- (and prefix (setq name (concat prefix ":" name))))))
- ((ffap-newsgroup-p name) (setq name (concat "news:" name)))
- ((and (string-match "\\`[[:alnum:]]+\\'" name)
- (equal (ffap-string-around) "<>")
-
- (not (string-match "~" (expand-file-name (concat "~" name))))
- )
- (setq name (concat "mailto:" name)))
- )
- (and (ffap-url-p name) name)
- ))))
- (defvar ffap-gopher-regexp
- "^.*\\<\\(Type\\|Name\\|Path\\|Host\\|Port\\) *= *\\(.*\\) *$"
- "Regexp matching a line in a gopher bookmark (maybe indented).
- The two subexpressions are the KEY and VALUE.")
- (defun ffap-gopher-at-point ()
- "If point is inside a gopher bookmark block, return its URL."
-
- (save-excursion
- (beginning-of-line)
- (if (looking-at ffap-gopher-regexp)
- (progn
- (while (and (looking-at ffap-gopher-regexp) (not (bobp)))
- (forward-line -1))
- (or (looking-at ffap-gopher-regexp) (forward-line 1))
- (let ((type "1") path host (port "70"))
- (while (looking-at ffap-gopher-regexp)
- (let ((var (intern
- (downcase
- (buffer-substring (match-beginning 1)
- (match-end 1)))))
- (val (buffer-substring (match-beginning 2)
- (match-end 2))))
- (set var val)
- (forward-line 1)))
- (if (and path (string-match "^ftp:.*@" path))
- (concat "ftp://"
- (substring path 4 (1- (match-end 0)))
- (substring path (match-end 0)))
- (and (= (length type) 1)
- host;; (ffap-machine-p host)
- (concat "gopher://" host
- (if (equal port "70") "" (concat ":" port))
- "/" type path))))))))
- (defvar ffap-ftp-sans-slash-regexp
- (and
- ffap-ftp-regexp
-
-
-
- "\\`\\([^:@]+@[^:@]+:\\|[^@.:]+\\.[^@:]+:\\|[^:]+:[~/]\\)\\([^:]\\|\\'\\)")
- "Strings matching this are coerced to ftp file names by ffap.
- That is, ffap just prepends \"/\". Set to nil to disable.")
- (defun ffap-file-at-point ()
- "Return filename from around point if it exists, or nil.
- Existence test is skipped for names that look remote.
- If the filename is not obvious, it also tries `ffap-alist',
- which may actually result in an URL rather than a filename."
-
-
-
- (let* ((case-fold-search t)
- (data (match-data))
- (string (ffap-string-at-point))
- (name
- (or (condition-case nil
- (and (not (string-match "//" string))
- (substitute-in-file-name string))
- (error nil))
- string))
- (abs (file-name-absolute-p name))
- (default-directory default-directory)
- (oname name))
- (unwind-protect
- (cond
-
- ((member name '("" "/" "//" "/*" ".")) nil)
-
-
- ((and (not abs) (ffap-file-exists-string name)))
-
- ((and (not abs) (string-match ":[0-9]" name)
- (ffap-file-exists-string (substring name 0 (match-beginning 0)))))
-
-
- ((and ffap-shell-prompt-regexp
- (not abs) (string-match ffap-shell-prompt-regexp name)
- (ffap-file-exists-string (substring name (match-end 0)))))
-
- ((and abs (ffap-file-remote-p name)))
-
- ((and abs (ffap-file-exists-string name)))
-
- ((and abs (string-match ":[0-9]" name)
- (ffap-file-exists-string (substring name 0 (match-beginning 0)))))
-
- ((and (string-match path-separator name)
- (setq name (ffap-string-at-point 'nocolon))
- (ffap-file-exists-string name)))
-
- ((let ((alist ffap-alist) tem try case-fold-search)
- (while (and alist (not try))
- (setq tem (car alist) alist (cdr alist))
- (if (or (eq major-mode (car tem))
- (and (stringp (car tem))
- (string-match (car tem) name)))
- (and (setq try
- (condition-case nil
- (funcall (cdr tem) name)
- (error nil)))
- (setq try (or
- (ffap-url-p try)
- (ffap-file-remote-p try)
- (ffap-file-exists-string try))))))
- try))
-
-
-
-
- ((and (not abs)
- ffap-ftp-sans-slash-regexp
- (string-match ffap-ftp-sans-slash-regexp oname)
- (ffap-file-remote-p (concat "/" oname))))
-
-
-
- ((let* (ffap-rfs-regexp
- (remote-dir
- (cond
- ((ffap-file-remote-p default-directory))
- ((and (eq major-mode 'internal-ange-ftp-mode)
- (string-match "^\\*ftp \\(.*\\)@\\(.*\\)\\*$"
- (buffer-name)))
- (concat "/" (substring (buffer-name) 5 -1) ":"))
-
-
-
-
- )))
- (and remote-dir
- (or
- (and (string-match "\\`\\(/?~?ftp\\)/" name)
- (ffap-file-exists-string
- (ffap-replace-file-component
- remote-dir (substring name (match-end 1)))))
- (ffap-file-exists-string
- (ffap-replace-file-component remote-dir name))))))
- ((and ffap-dired-wildcards
- (string-match ffap-dired-wildcards name)
- abs
- (ffap-file-exists-string (file-name-directory
- (directory-file-name name)))
- name))
-
-
- ((let ((dir name))
- (while (and dir
- (not (ffap-file-exists-string dir))
- (not (equal dir (setq dir (file-name-directory
- (directory-file-name dir)))))))
- (ffap-file-exists-string dir)))
- )
- (set-match-data data))))
- (defun ffap-read-file-or-url (prompt guess)
- "Read file or URL from minibuffer, with PROMPT and initial GUESS."
- (or guess (setq guess default-directory))
- (let (dir)
-
-
- (or (ffap-url-p guess)
- (progn
- (or (ffap-file-remote-p guess)
- (setq guess
- (abbreviate-file-name (expand-file-name guess))
- ))
- (setq dir (file-name-directory guess))))
- (let ((minibuffer-completing-file-name t)
- (completion-ignore-case read-file-name-completion-ignore-case)
- (fnh-elem (cons ffap-url-regexp 'url-file-handler)))
-
- (push fnh-elem file-name-handler-alist)
- (unwind-protect
- (setq guess
- (let ((default-directory (if dir (expand-file-name dir)
- default-directory)))
- (completing-read
- prompt
- 'ffap-read-file-or-url-internal
- nil
- nil
- (if dir (cons guess (length dir)) guess)
- (list 'file-name-history)
- (and buffer-file-name
- (abbreviate-file-name buffer-file-name)))))
-
-
-
-
- (setq file-name-handler-alist (delq fnh-elem file-name-handler-alist))))
-
- (or (ffap-url-p guess) (setq guess (substitute-in-file-name guess)))
-
-
- guess))
- (defun ffap-read-url-internal (string pred action)
- "Complete URLs from history, treating given string as valid."
- (let ((hist (ffap-symbol-value 'url-global-history-hash-table)))
- (cond
- ((not action)
- (or (try-completion string hist pred) string))
- ((eq action t)
- (or (all-completions string hist pred) (list string)))
-
-
- (t t))))
- (defun ffap-read-file-or-url-internal (string pred action)
- (unless string
- (setq string default-directory))
- (if (ffap-url-p string)
- (ffap-read-url-internal string pred action)
- (read-file-name-internal string pred action)))
- (defun ffap-complete-as-file-p ()
-
-
-
- (if (eq minibuffer-completion-table 'ffap-read-file-or-url-internal)
- (not (ffap-url-p (buffer-string)))
- (and minibuffer-completing-file-name '(t))))
- (and
- (featurep 'complete)
- (if (boundp 'PC-completion-as-file-name-predicate)
-
- (setq PC-completion-as-file-name-predicate 'ffap-complete-as-file-p)))
- (defvar ffap-highlight t
- "If non-nil, ffap highlights the current buffer substring.")
- (defface ffap
- '((t :inherit highlight))
- "Face used to highlight the current buffer substring."
- :group 'ffap
- :version "22.1")
- (defvar ffap-highlight-overlay nil
- "Overlay used by `ffap-highlight'.")
- (defun ffap-highlight (&optional remove)
- "If `ffap-highlight' is set, highlight the guess in this buffer.
- That is, the last buffer substring found by `ffap-string-at-point'.
- Optional argument REMOVE means to remove any such highlighting.
- Uses the face `ffap' if it is defined, or else `highlight'."
- (cond
- (remove
- (and ffap-highlight-overlay
- (delete-overlay ffap-highlight-overlay))
- )
- ((not ffap-highlight) nil)
- (ffap-highlight-overlay
- (move-overlay
- ffap-highlight-overlay
- (car ffap-string-at-point-region)
- (nth 1 ffap-string-at-point-region)
- (current-buffer)))
- (t
- (setq ffap-highlight-overlay
- (apply 'make-overlay ffap-string-at-point-region))
- (overlay-put ffap-highlight-overlay 'face 'ffap))))
- (defun ffap-guesser ()
- "Return file or URL or nil, guessed from text around point."
- (or (and ffap-url-regexp
- (ffap-fixup-url (or (ffap-url-at-point)
- (ffap-gopher-at-point))))
- (ffap-file-at-point)
- (ffap-fixup-machine (ffap-machine-at-point))))
- (defun ffap-prompter (&optional guess)
-
-
- (unwind-protect
-
-
- (catch 'ffap-prompter
- (ffap-read-file-or-url
- (if ffap-url-regexp "Find file or URL: " "Find file: ")
- (prog1
- (let ((mark-active nil))
-
-
-
- (setq guess (or guess (ffap-guesser))))
- (and guess (ffap-highlight))
- )))
- (ffap-highlight t)))
- (defun find-file-at-point (&optional filename)
- "Find FILENAME, guessing a default from text around point.
- If `ffap-url-regexp' is not nil, the FILENAME may also be an URL.
- With a prefix, this command behaves exactly like `ffap-file-finder'.
- If `ffap-require-prefix' is set, the prefix meaning is reversed.
- See also the variables `ffap-dired-wildcards', `ffap-newfile-prompt',
- and the functions `ffap-file-at-point' and `ffap-url-at-point'."
- (interactive)
- (if (and (called-interactively-p 'interactive)
- (if ffap-require-prefix (not current-prefix-arg)
- current-prefix-arg))
-
- (let (current-prefix-arg)
- (call-interactively ffap-file-finder))
- (or filename (setq filename (ffap-prompter)))
- (cond
- ((ffap-url-p filename)
- (let (current-prefix-arg)
- (funcall ffap-url-fetcher filename)))
- ((and ffap-pass-wildcards-to-dired
- ffap-dired-wildcards
- (string-match ffap-dired-wildcards filename))
- (funcall ffap-directory-finder filename))
- ((and ffap-dired-wildcards
- (string-match ffap-dired-wildcards filename)
- find-file-wildcards
-
- (memq ffap-file-finder '(find-file find-alternate-file)))
- (funcall ffap-file-finder (expand-file-name filename) t))
- ((or (not ffap-newfile-prompt)
- (file-exists-p filename)
- (y-or-n-p "File does not exist, create buffer? "))
- (funcall ffap-file-finder
-
- (expand-file-name filename)))
-
- ((signal 'file-error (list "Opening file buffer"
- "no such file or directory"
- filename))))))
- (defalias 'ffap 'find-file-at-point)
- (defvar ffap-menu-regexp nil
- "*If non-nil, overrides `ffap-next-regexp' during `ffap-menu'.
- Make this more restrictive for faster menu building.
- For example, try \":/\" for URL (and some ftp) references.")
- (defvar ffap-menu-alist nil
- "Buffer local cache of menu presented by `ffap-menu'.")
- (make-variable-buffer-local 'ffap-menu-alist)
- (defvar ffap-menu-text-plist
- (cond
- ((display-mouse-p) '(face bold mouse-face highlight))
- (t nil))
- "Text properties applied to strings found by `ffap-menu-rescan'.
- These properties may be used to fontify the menu references.")
- (defun ffap-menu (&optional rescan)
- "Put up a menu of files and URLs mentioned in this buffer.
- Then set mark, jump to choice, and try to fetch it. The menu is
- cached in `ffap-menu-alist', and rebuilt by `ffap-menu-rescan'.
- The optional RESCAN argument \(a prefix, interactively\) forces
- a rebuild. Searches with `ffap-menu-regexp'."
- (interactive "P")
-
- (if (or (not ffap-menu-alist) rescan
-
- (and ffap-menu-alist
- (let ((first (car ffap-menu-alist)))
- (save-excursion
- (goto-char (cdr first))
- (not (equal (car first) (ffap-guesser)))))))
- (ffap-menu-rescan))
-
- (ffap-menu-ask
- (if ffap-url-regexp "Find file or URL" "Find file")
- (cons (cons "*Rescan Buffer*" -1) ffap-menu-alist)
- 'ffap-menu-cont))
- (defun ffap-menu-cont (choice)
- (if (< (cdr choice) 0)
- (ffap-menu t)
- (push-mark)
- (goto-char (cdr choice))
-
- (unwind-protect
- (progn
- (and ffap-highlight (ffap-guesser) (ffap-highlight))
- (sit-for 0)
- (find-file-at-point (car choice)))
- (ffap-highlight t))))
- (defun ffap-menu-ask (title alist cont)
- "Prompt from a menu of choices, and then apply some action.
- Arguments are TITLE, ALIST, and CONT \(a continuation function\).
- This uses either a menu or the minibuffer depending on invocation.
- The TITLE string is used as either the prompt or menu title.
- Each ALIST entry looks like (STRING . DATA) and defines one choice.
- Function CONT is applied to the entry chosen by the user."
-
-
-
- (let (choice)
- (cond
-
- ((and (fboundp 'x-popup-menu) (ffap-mouse-event))
- (setq choice
- (x-popup-menu
- t
- (list "" (cons title
- (mapcar (lambda (i) (cons (car i) i))
- alist))))))
-
- (t
- (let ((minibuffer-setup-hook 'minibuffer-completion-help))
-
- (setq choice
- (completing-read
- (format "%s (default %s): " title (car (car alist)))
- alist nil t
-
- nil)))
- (sit-for 0)
-
- (setq choice (or (assoc choice alist) (car alist)))))
- (if choice
- (funcall cont choice)
- (message "No choice made!")
- nil)))
- (defun ffap-menu-rescan ()
- "Search buffer for `ffap-menu-regexp' to build `ffap-menu-alist'.
- Applies `ffap-menu-text-plist' text properties at all matches."
- (interactive)
- (let ((ffap-next-regexp (or ffap-menu-regexp ffap-next-regexp))
- (range (- (point-max) (point-min)))
- (mod (buffer-modified-p))
-
-
- (inhibit-read-only t)
- item
-
- (major-mode (if (assq major-mode ffap-string-at-point-mode-alist)
- major-mode
- 'file)))
- (setq ffap-menu-alist nil)
- (unwind-protect
- (save-excursion
- (goto-char (point-min))
- (while (setq item (ffap-next-guess))
- (setq ffap-menu-alist (cons (cons item (point)) ffap-menu-alist))
- (add-text-properties (car ffap-string-at-point-region) (point)
- ffap-menu-text-plist)
- (message "Scanning...%2d%% <%s>"
- (/ (* 100 (- (point) (point-min))) range) item)))
- (or mod (restore-buffer-modified-p nil))))
- (message "Scanning...done")
-
- (setq ffap-menu-alist
- (sort ffap-menu-alist
- (function
- (lambda (a b) (string-lessp (car a) (car b))))))
- (let ((ptr ffap-menu-alist))
- (while (cdr ptr)
- (if (equal (car (car ptr)) (car (car (cdr ptr))))
- (setcdr ptr (cdr (cdr ptr)))
- (setq ptr (cdr ptr)))))
- (setq ffap-menu-alist
- (sort ffap-menu-alist
- (function
- (lambda (a b) (< (cdr a) (cdr b)))))))
- (defvar ffap-at-mouse-fallback nil
- "Command invoked by `ffap-at-mouse' if nothing found at click, or nil.
- Ignored when `ffap-at-mouse' is called programmatically.")
- (put 'ffap-at-mouse-fallback 'risky-local-variable t)
- (defun ffap-at-mouse (e)
- "Find file or URL guessed from text around mouse click.
- Interactively, calls `ffap-at-mouse-fallback' if no guess is found.
- Return value:
- * if a guess string is found, return it (after finding it)
- * if the fallback is called, return whatever it returns
- * otherwise, nil"
- (interactive "e")
- (let ((guess
-
- (save-excursion
- (mouse-set-point e)
-
-
- (ffap-guesser))))
- (cond
- (guess
- (set-buffer (ffap-event-buffer e))
- (ffap-highlight)
- (unwind-protect
- (progn
- (sit-for 0)
- (message "Finding `%s'" guess)
- (find-file-at-point guess)
- guess)
- (ffap-highlight t)))
- ((called-interactively-p 'interactive)
- (if ffap-at-mouse-fallback
- (call-interactively ffap-at-mouse-fallback)
- (message "No file or URL found at mouse click.")
- nil))
-
- )))
- (defun ffap-other-window ()
- "Like `ffap', but put buffer in another window.
- Only intended for interactive use."
- (interactive)
- (let (value)
- (switch-to-buffer-other-window
- (save-window-excursion
- (setq value (call-interactively 'ffap))
- (unless (or (bufferp value) (bufferp (car-safe value)))
- (setq value (current-buffer)))
- (current-buffer)))
- value))
- (defun ffap-other-frame ()
- "Like `ffap', but put buffer in another frame.
- Only intended for interactive use."
- (interactive)
-
- (let* ((win (selected-window))
- (wdp (window-dedicated-p win))
- value)
- (unwind-protect
- (progn
- (set-window-dedicated-p win nil)
- (switch-to-buffer-other-frame
- (save-window-excursion
- (setq value (call-interactively 'ffap))
- (unless (or (bufferp value) (bufferp (car-safe value)))
- (setq value (current-buffer)))
- (current-buffer))))
- (set-window-dedicated-p win wdp))
- value))
- (defun ffap-read-only ()
- "Like `ffap', but mark buffer as read-only.
- Only intended for interactive use."
- (interactive)
- (let ((value (call-interactively 'ffap)))
- (unless (or (bufferp value) (bufferp (car-safe value)))
- (setq value (current-buffer)))
- (mapc (lambda (b) (with-current-buffer b (toggle-read-only 1)))
- (if (listp value) value (list value)))
- value))
- (defun ffap-read-only-other-window ()
- "Like `ffap', but put buffer in another window and mark as read-only.
- Only intended for interactive use."
- (interactive)
- (let ((value (ffap-other-window)))
- (mapc (lambda (b) (with-current-buffer b (toggle-read-only 1)))
- (if (listp value) value (list value)))
- value))
- (defun ffap-read-only-other-frame ()
- "Like `ffap', but put buffer in another frame and mark as read-only.
- Only intended for interactive use."
- (interactive)
- (let ((value (ffap-other-frame)))
- (mapc (lambda (b) (with-current-buffer b (toggle-read-only 1)))
- (if (listp value) value (list value)))
- value))
- (defun ffap-alternate-file ()
- "Like `ffap' and `find-alternate-file'.
- Only intended for interactive use."
- (interactive)
- (let ((ffap-file-finder 'find-alternate-file))
- (call-interactively 'ffap)))
- (defun ffap-alternate-file-other-window ()
- "Like `ffap' and `find-alternate-file-other-window'.
- Only intended for interactive use."
- (interactive)
- (let ((ffap-file-finder 'find-alternate-file-other-window))
- (call-interactively 'ffap)))
- (defun ffap-literally ()
- "Like `ffap' and `find-file-literally'.
- Only intended for interactive use."
- (interactive)
- (let ((ffap-file-finder 'find-file-literally))
- (call-interactively 'ffap)))
- (defalias 'find-file-literally-at-point 'ffap-literally)
- (define-obsolete-function-alias 'ffap-bug 'report-emacs-bug "23.1")
- (define-obsolete-function-alias 'ffap-submit-bug 'report-emacs-bug "23.1")
- (defun ffap-ro-mode-hook ()
- "Bind `ffap-next' and `ffap-menu' to M-l and M-m, resp."
- (local-set-key "\M-l" 'ffap-next)
- (local-set-key "\M-m" 'ffap-menu)
- )
- (defun ffap-gnus-hook ()
- "Bind `ffap-gnus-next' and `ffap-gnus-menu' to M-l and M-m, resp."
- (set (make-local-variable 'ffap-foo-at-bar-prefix) "news")
-
- (local-set-key "\M-l" 'ffap-gnus-next)
- (local-set-key "\M-m" 'ffap-gnus-menu))
- (defvar gnus-summary-buffer)
- (defvar gnus-article-buffer)
- (declare-function gnus-summary-select-article "gnus-sum"
- (&optional all-headers force pseudo article))
- (declare-function gnus-configure-windows "gnus-win"
- (setting &optional force))
- (defun ffap-gnus-wrapper (form)
- (and (eq (current-buffer) (get-buffer gnus-summary-buffer))
- (gnus-summary-select-article))
-
-
-
- (let ((sb (window-buffer (selected-window))))
- (gnus-configure-windows 'article)
- (pop-to-buffer gnus-article-buffer)
- (widen)
-
- (if (eq (point) (point-min)) (search-forward "\n\n" nil t))
- (unwind-protect
- (eval form)
- (pop-to-buffer sb))))
- (defun ffap-gnus-next ()
- "Run `ffap-next' in the gnus article buffer."
- (interactive) (ffap-gnus-wrapper '(ffap-next nil t)))
- (defun ffap-gnus-menu ()
- "Run `ffap-menu' in the gnus article buffer."
- (interactive) (ffap-gnus-wrapper '(ffap-menu)))
- (defcustom dired-at-point-require-prefix nil
- "If set, reverses the prefix argument to `dired-at-point'.
- This is nil so neophytes notice ffap. Experts may prefer to disable
- ffap most of the time."
- :type 'boolean
- :group 'ffap
- :version "20.3")
- (defun dired-at-point (&optional filename)
- "Start Dired, defaulting to file at point. See `ffap'.
- If `dired-at-point-require-prefix' is set, the prefix meaning is reversed."
- (interactive)
- (if (and (called-interactively-p 'interactive)
- (if dired-at-point-require-prefix
- (not current-prefix-arg)
- current-prefix-arg))
- (let (current-prefix-arg)
- (call-interactively ffap-directory-finder))
- (or filename (setq filename (dired-at-point-prompter)))
- (cond
- ((ffap-url-p filename)
- (funcall ffap-url-fetcher filename))
- ((and ffap-dired-wildcards
- (string-match ffap-dired-wildcards filename))
- (funcall ffap-directory-finder filename))
- ((file-exists-p filename)
- (if (file-directory-p filename)
- (funcall ffap-directory-finder
- (expand-file-name filename))
- (funcall ffap-directory-finder
- (concat (expand-file-name filename) "*"))))
- ((and (file-writable-p
- (or (file-name-directory (directory-file-name filename))
- filename))
- (y-or-n-p "Directory does not exist, create it? "))
- (make-directory filename)
- (funcall ffap-directory-finder filename))
- ((error "No such file or directory `%s'" filename)))))
- (defun dired-at-point-prompter (&optional guess)
-
-
- (unwind-protect
- (ffap-read-file-or-url
- (cond
- ((eq ffap-directory-finder 'list-directory)
- "List directory (brief): ")
- (ffap-url-regexp "Dired file or URL: ")
- (t "Dired file: "))
- (prog1
- (setq guess (or guess
- (let ((guess (ffap-guesser)))
- (if (or (not guess)
- (ffap-url-p guess)
- (ffap-file-remote-p guess))
- guess
- (setq guess (abbreviate-file-name
- (expand-file-name guess)))
- (cond
-
- ((file-directory-p guess)
- (file-name-as-directory guess))
-
- ((file-regular-p guess)
- (file-name-directory guess))
- (guess))))
- ))
- (and guess (ffap-highlight))))
- (ffap-highlight t)))
- (defun ffap-dired-other-window ()
- "Like `dired-at-point', but put buffer in another window.
- Only intended for interactive use."
- (interactive)
- (let (value)
- (switch-to-buffer-other-window
- (save-window-excursion
- (setq value (call-interactively 'dired-at-point))
- (current-buffer)))
- value))
- (defun ffap-dired-other-frame ()
- "Like `dired-at-point', but put buffer in another frame.
- Only intended for interactive use."
- (interactive)
-
- (let* ((win (selected-window))
- (wdp (window-dedicated-p win))
- value)
- (unwind-protect
- (progn
- (set-window-dedicated-p win nil)
- (switch-to-buffer-other-frame
- (save-window-excursion
- (setq value (call-interactively 'dired-at-point))
- (current-buffer))))
- (set-window-dedicated-p win wdp))
- value))
- (defun ffap-list-directory ()
- "Like `dired-at-point' and `list-directory'.
- Only intended for interactive use."
- (interactive)
- (let ((ffap-directory-finder 'list-directory))
- (call-interactively 'dired-at-point)))
- (progn (defun ffap-guess-file-name-at-point ()
- "Try to get a file name at point.
- This hook is intended to be put in `file-name-at-point-functions'."
- (when (fboundp 'ffap-guesser)
-
- (let ((guess (ffap-guesser)))
- (setq guess
- (if (or (not guess)
- (and (fboundp 'ffap-url-p)
- (ffap-url-p guess))
- (and (fboundp 'ffap-file-remote-p)
- (ffap-file-remote-p guess)))
- guess
- (abbreviate-file-name (expand-file-name guess))))
- (when guess
- (if (file-directory-p guess)
- (file-name-as-directory guess)
- guess))))))
- (defvar ffap-bindings
- '(
- (global-set-key [S-mouse-3] 'ffap-at-mouse)
- (global-set-key [C-S-mouse-3] 'ffap-menu)
- (global-set-key "\C-x\C-f" 'find-file-at-point)
- (global-set-key "\C-x\C-r" 'ffap-read-only)
- (global-set-key "\C-x\C-v" 'ffap-alternate-file)
- (global-set-key "\C-x4f" 'ffap-other-window)
- (global-set-key "\C-x5f" 'ffap-other-frame)
- (global-set-key "\C-x4r" 'ffap-read-only-other-window)
- (global-set-key "\C-x5r" 'ffap-read-only-other-frame)
- (global-set-key "\C-xd" 'dired-at-point)
- (global-set-key "\C-x4d" 'ffap-dired-other-window)
- (global-set-key "\C-x5d" 'ffap-dired-other-frame)
- (global-set-key "\C-x\C-d" 'ffap-list-directory)
- (add-hook 'gnus-summary-mode-hook 'ffap-gnus-hook)
- (add-hook 'gnus-article-mode-hook 'ffap-gnus-hook)
- (add-hook 'vm-mode-hook 'ffap-ro-mode-hook)
- (add-hook 'rmail-mode-hook 'ffap-ro-mode-hook)
-
- )
- "List of binding forms evaluated by function `ffap-bindings'.
- A reasonable ffap installation needs just this one line:
- (ffap-bindings)
- Of course if you do not like these bindings, just roll your own!")
- (defun ffap-bindings ()
- "Evaluate the forms in variable `ffap-bindings'."
- (interactive)
- (eval (cons 'progn ffap-bindings)))
- (provide 'ffap)
|