|
0
|
1 ;;!emacs
|
|
|
2 ;;
|
|
|
3 ;; FILE: hpath.el
|
|
|
4 ;; SUMMARY: Hyperbole support routines for handling UNIX paths.
|
|
|
5 ;; USAGE: GNU Emacs Lisp Library
|
|
|
6 ;; KEYWORDS: comm, hypermedia, unix
|
|
|
7 ;;
|
|
|
8 ;; AUTHOR: Bob Weiner
|
|
70
|
9 ;; ORG: Brown U.
|
|
0
|
10 ;;
|
|
|
11 ;; ORIG-DATE: 1-Nov-91 at 00:44:23
|
|
70
|
12 ;; LAST-MOD: 10-Oct-95 at 23:31:56 by Bob Weiner
|
|
|
13 ;;
|
|
|
14 ;; This file is part of Hyperbole.
|
|
|
15 ;; Available for use and distribution under the same terms as GNU Emacs.
|
|
|
16 ;;
|
|
|
17 ;; Copyright (C) 1991-1995, Free Software Foundation, Inc.
|
|
|
18 ;; Developed with support from Motorola Inc.
|
|
|
19 ;;
|
|
|
20 ;; DESCRIPTION:
|
|
|
21 ;; DESCRIP-END.
|
|
0
|
22
|
|
|
23 ;;; ************************************************************************
|
|
|
24 ;;; Public variables
|
|
|
25 ;;; ************************************************************************
|
|
|
26
|
|
|
27 (defvar hpath:rfc "/anonymous@ds.internic.net:rfc/rfc%s.txt"
|
|
|
28 "*String to be used in the call: (hpath:rfc rfc-num)
|
|
70
|
29 to create an path to the RFC document for 'rfc-num'.")
|
|
0
|
30
|
|
|
31 (defvar hpath:suffixes '(".gz" ".Z")
|
|
|
32 "*List of filename suffixes to add or remove within (hpath:exists-p) calls.")
|
|
|
33
|
|
|
34 (defvar hpath:tmp-prefix "/tmp/remote-"
|
|
|
35 "*Pathname prefix to attach to remote files copied locally for use with external viewers.")
|
|
|
36
|
|
|
37 ;;; ************************************************************************
|
|
|
38 ;;; Public functions
|
|
|
39 ;;; ************************************************************************
|
|
|
40
|
|
|
41 (defun hpath:absolute-to (path &optional default-dirs)
|
|
70
|
42 "Returns PATH as an absolute path relative to one directory from optional DEFAULT-DIRS or 'default-directory'.
|
|
0
|
43 Returns PATH unchanged when it is not a valid path or when DEFAULT-DIRS
|
|
|
44 is invalid. DEFAULT-DIRS when non-nil may be a single directory or a list of
|
|
|
45 directories. The first one in which PATH is found is used."
|
|
|
46 (if (not (and (stringp path) (hpath:is-p path nil t)))
|
|
|
47 path
|
|
|
48 (if (not (cond ((null default-dirs)
|
|
|
49 (setq default-dirs (cons default-directory nil)))
|
|
|
50 ((stringp default-dirs)
|
|
|
51 (setq default-dirs (cons default-dirs nil)))
|
|
|
52 ((listp default-dirs))
|
|
|
53 (t nil)))
|
|
|
54 path
|
|
|
55 (let ((rtn) dir)
|
|
|
56 (while (and default-dirs (null rtn))
|
|
|
57 (setq dir (expand-file-name
|
|
|
58 (file-name-as-directory (car default-dirs)))
|
|
|
59 rtn (expand-file-name path dir)
|
|
|
60 default-dirs (cdr default-dirs))
|
|
|
61 (or (file-exists-p rtn) (setq rtn nil)))
|
|
|
62 (or rtn path)))))
|
|
|
63
|
|
|
64 (defun hpath:ange-ftp-at-p ()
|
|
|
65 "Returns an ange-ftp pathname that point is within or nil.
|
|
70
|
66 See the 'ange-ftp' or 'efs' Elisp packages for pathname format details.
|
|
0
|
67 Always returns nil if (hpath:ange-ftp-available-p) returns nil."
|
|
|
68 (if (hpath:ange-ftp-available-p)
|
|
|
69 (let ((user (hpath:ange-ftp-default-user))
|
|
|
70 path)
|
|
|
71 (setq path
|
|
|
72 (save-excursion
|
|
|
73 (skip-chars-backward "^[ \t\n\"`'\(\{<")
|
|
|
74 (cond
|
|
|
75 ((hpath:url-at-p)
|
|
|
76 (if (string-equal
|
|
70
|
77 (buffer-substring (match-beginning 1) (match-end 1))
|
|
0
|
78 "ftp")
|
|
|
79 (concat
|
|
|
80 "/"
|
|
|
81 ;; user
|
|
70
|
82 (if (match-beginning 2)
|
|
0
|
83 (buffer-substring
|
|
70
|
84 (match-beginning 2) (match-end 2))
|
|
0
|
85 (concat user "@"))
|
|
|
86 ;; domain
|
|
|
87 (hpath:delete-trailer
|
|
70
|
88 (buffer-substring (match-beginning 3) (match-end 3)))
|
|
0
|
89 ":"
|
|
|
90 ;; path
|
|
70
|
91 (if (match-beginning 5)
|
|
|
92 (buffer-substring (match-beginning 5)
|
|
|
93 (match-end 5))))
|
|
0
|
94 ;; else ignore this other type of WWW path
|
|
|
95 ))
|
|
|
96 ;; user, domain and path
|
|
|
97 ((looking-at "/?[^/:@ \t\n\^M\"`']+@[^/:@ \t\n\^M\"`']+:[^]@ \t\n\^M\"`'\)\}]*")
|
|
|
98 (buffer-substring (match-beginning 0) (match-end 0)))
|
|
|
99 ;; @domain and path
|
|
|
100 ((looking-at "@[^/:@ \t\n\^M\"`']+:[^]@ \t\n\^M\"`'\)\}]*")
|
|
|
101 (concat "/" user (buffer-substring
|
|
|
102 (match-beginning 0) (match-end 0))))
|
|
|
103 ;; domain and path
|
|
|
104 ((and (looking-at
|
|
|
105 "/?\\(\\([^/:@ \t\n\^M\"`']+\\):[^]@:, \t\n\^M\"`'\)\}]*\\)[] \t\n\^M,.\"`'\)\}]")
|
|
|
106 (setq path (buffer-substring
|
|
|
107 (match-beginning 1) (match-end 1)))
|
|
|
108 (string-match "[^.]\\.[^.]"
|
|
|
109 (buffer-substring (match-beginning 2)
|
|
|
110 (match-end 2))))
|
|
|
111 (concat "/" user "@" path))
|
|
|
112 ;; host and path
|
|
|
113 ((and (looking-at
|
|
|
114 "/\\([^/:@ \t\n\^M\"`']+:[^]@:, \t\n\^M\"`'\)\}]*\\)")
|
|
|
115 (setq path (buffer-substring
|
|
|
116 (match-beginning 1) (match-end 1))))
|
|
|
117 (concat "/" user "@" path))
|
|
|
118 )))
|
|
|
119 (hpath:delete-trailer path))))
|
|
|
120
|
|
|
121 (defun hpath:ange-ftp-p (path)
|
|
|
122 "Returns non-nil iff PATH is an ange-ftp pathname.
|
|
70
|
123 See the 'ange-ftp' or 'efs' Elisp package for pathname format details.
|
|
0
|
124 Always returns nil if (hpath:ange-ftp-available-p) returns nil."
|
|
|
125 (and (stringp path)
|
|
|
126 (or (featurep 'ange-ftp) (featurep 'efs))
|
|
|
127 (let ((user (hpath:ange-ftp-default-user))
|
|
|
128 result)
|
|
|
129 (setq result
|
|
|
130 (cond
|
|
|
131 ((hpath:url-p path)
|
|
|
132 (if (string-equal
|
|
70
|
133 (substring path (match-beginning 1) (match-end 1))
|
|
0
|
134 "ftp")
|
|
|
135 (concat
|
|
|
136 "/"
|
|
|
137 ;; user
|
|
70
|
138 (if (match-beginning 2)
|
|
|
139 (substring path (match-beginning 2) (match-end 2))
|
|
0
|
140 (concat user "@"))
|
|
|
141 ;; domain
|
|
|
142 (hpath:delete-trailer
|
|
70
|
143 (substring path (match-beginning 3) (match-end 3)))
|
|
0
|
144 ":"
|
|
|
145 ;; path
|
|
70
|
146 (if (match-beginning 5)
|
|
|
147 (substring path (match-beginning 5)
|
|
|
148 (match-end 5))))
|
|
0
|
149 ;; else ignore this other type of WWW path
|
|
|
150 ))
|
|
|
151 ;; user, domain and path
|
|
|
152 ((string-match "/?[^/:@ \t\n\^M\"`']+@[^/:@ \t\n\^M\"`']+:[^]@ \t\n\^M\"`'\)\}]*"
|
|
|
153 path)
|
|
|
154 (substring path (match-beginning 0) (match-end 0)))
|
|
|
155 ;; @domain and path
|
|
|
156 ((string-match "@[^/:@ \t\n\^M\"`']+:[^]@ \t\n\^M\"`'\)\}]*"
|
|
|
157 path)
|
|
|
158 (concat "/" user
|
|
|
159 (substring path (match-beginning 0) (match-end 0))))
|
|
|
160 ;; domain and path
|
|
|
161 ((and (string-match
|
|
|
162 "/?\\(\\([^/:@ \t\n\^M\"`']+\\):[^]@:, \t\n\^M\"`'\)\}]*\\)"
|
|
|
163 path)
|
|
|
164 (setq result (substring path
|
|
|
165 (match-beginning 1) (match-end 1)))
|
|
|
166 (string-match "[^.]\\.[^.]"
|
|
|
167 (substring path (match-beginning 2)
|
|
|
168 (match-end 2))))
|
|
|
169 (concat "/" user "@" result))
|
|
|
170 ;; host and path
|
|
|
171 ((and (string-match
|
|
|
172 "/\\([^/:@ \t\n\^M\"`']+:[^]@:, \t\n\^M\"`'\)\}]*\\)"
|
|
|
173 path)
|
|
|
174 (setq result (substring
|
|
|
175 path
|
|
|
176 (match-beginning 1) (match-end 1))))
|
|
|
177 (concat "/" user "@" result))
|
|
|
178 ))
|
|
|
179 (hpath:delete-trailer result))))
|
|
|
180
|
|
|
181 (defun hpath:at-p (&optional type non-exist)
|
|
|
182 "Returns delimited path or non-delimited ange-ftp path at point, if any.
|
|
|
183 World wide web urls are treated as non-paths so they are handled elsewhere.
|
|
|
184 Delimiters may be: double quotes, open and close single quote, or
|
|
|
185 Texinfo file references.
|
|
|
186 If optional TYPE is the symbol 'file or 'directory, then only that path type is
|
|
|
187 accepted as a match. Only locally reachable paths are checked for existence.
|
|
|
188 With optional NON-EXIST, nonexistent local paths are allowed.
|
|
70
|
189 Absolute pathnames must begin with a '/' or '~'. Relative pathnames
|
|
|
190 must begin with a './' or '../' to be recognized."
|
|
0
|
191 (cond (;; Local file URLs
|
|
|
192 (hpath:is-p (hargs:delimited
|
|
|
193 "file://localhost" "[ \t\n\^M\"\'\}]" nil t)))
|
|
|
194 ((hpath:ange-ftp-at-p))
|
|
|
195 ((hpath:www-at-p) nil)
|
|
|
196 ((hpath:is-p (or (hargs:delimited "\"" "\"")
|
|
|
197 ;; Filenames in Info docs
|
|
|
198 (hargs:delimited "\`" "\'")
|
|
|
199 ;; Filenames in TexInfo docs
|
|
|
200 (hargs:delimited "@file{" "}"))
|
|
|
201 type non-exist))))
|
|
|
202
|
|
70
|
203 (defun hpath:find (filename &optional other-window-p)
|
|
|
204 "Edit file FILENAME using program from hpath:find-alist if available.
|
|
|
205 Otherwise, switch to a buffer visiting file FILENAME, creating one if none
|
|
|
206 already exists.
|
|
0
|
207
|
|
|
208 FILENAME may start with a special prefix character which is
|
|
|
209 handled as follows:
|
|
|
210 !filename - execute as a non-windowed program within a shell;
|
|
|
211 &filename - execute as a windowed program;
|
|
|
212 -filename - load as an Emacs Lisp program.
|
|
|
213
|
|
70
|
214 Return non-nil iff file is displayed within a buffer (not with an external
|
|
0
|
215 program)."
|
|
|
216 (interactive "FFind file: ")
|
|
|
217 (let (modifier)
|
|
|
218 (if (string-match hpath:prefix-regexp filename)
|
|
|
219 (setq modifier (aref filename 0)
|
|
|
220 filename (substring filename (match-end 0))))
|
|
|
221 (setq filename (hpath:substitute-value filename))
|
|
|
222 (cond (modifier (cond ((eq modifier ?!)
|
|
|
223 (hact 'exec-shell-cmd filename))
|
|
|
224 ((eq modifier ?&)
|
|
|
225 (hact 'exec-window-cmd filename))
|
|
|
226 ((eq modifier ?-)
|
|
|
227 (load filename)))
|
|
|
228 nil)
|
|
|
229 (t (let ((find-program (hpath:find-program filename)))
|
|
|
230 (cond ((stringp find-program)
|
|
|
231 (hact 'exec-window-cmd find-program)
|
|
|
232 nil)
|
|
|
233 ((hypb:functionp find-program)
|
|
|
234 (funcall find-program filename)
|
|
70
|
235 nil)
|
|
0
|
236 (t (setq filename (hpath:validate filename))
|
|
70
|
237 (funcall (if (and other-window-p
|
|
|
238 (not (br-in-browser)))
|
|
|
239 'switch-to-buffer-other-window
|
|
|
240 'switch-to-buffer)
|
|
|
241 (find-file-noselect filename))
|
|
0
|
242 t)))))))
|
|
|
243
|
|
70
|
244 (defun hpath:find-other-window (filename)
|
|
|
245 "Edit file FILENAME, in another window or using program from hpath:find-alist.
|
|
|
246 May create a new window, or reuse an existing one; see the function display-buffer.
|
|
24
|
247
|
|
70
|
248 Alternatively, FILENAME may start with a prefix character to indicate special
|
|
|
249 handling. See documentation of `hpath:find' for details.
|
|
24
|
250
|
|
70
|
251 Return non-nil iff file is displayed within a buffer."
|
|
0
|
252 (interactive "FFind file in other window: ")
|
|
70
|
253 (hpath:find filename t))
|
|
0
|
254
|
|
|
255 (defun hpath:is-p (path &optional type non-exist)
|
|
|
256 "Returns PATH if PATH is a Unix path, else nil.
|
|
|
257 If optional TYPE is the symbol 'file or 'directory, then only that path type
|
|
|
258 is accepted as a match. The existence of the path is checked only for
|
|
|
259 locally reachable paths (Info paths are not checked). Single spaces are
|
|
|
260 permitted in middle of existing pathnames, but not at the start or end. Tabs
|
|
|
261 and newlines are converted to space before the pathname is checked, this
|
|
|
262 normalized path form is what is returned for PATH. With optional NON-EXIST,
|
|
|
263 nonexistent local paths are allowed."
|
|
|
264 (let ((rtn-path path)
|
|
|
265 (suffix))
|
|
|
266 (and (stringp path)
|
|
|
267 ;; Path may be a link reference with other components other than a
|
|
|
268 ;; pathname. These components always follow a comma, so strip them,
|
|
|
269 ;; if any, before checking path.
|
|
|
270 (if (string-match "[ \t\n\^M]*," path)
|
|
|
271 (setq rtn-path (concat (substring path 0 (match-beginning 0))
|
|
|
272 "%s" (substring path (match-beginning 0)))
|
|
|
273 path (substring path 0 (match-beginning 0)))
|
|
|
274 (setq rtn-path (concat rtn-path "%s")))
|
|
|
275 (if (string-match hpath:prefix-regexp path)
|
|
|
276 (setq path (substring path (match-end 0)))
|
|
|
277 t)
|
|
70
|
278 (not (or (string= path "")
|
|
0
|
279 (string-match "\\`\\s \\|\\s \\'" path)))
|
|
|
280 ;; Convert tabs and newlines to space.
|
|
|
281 (setq path (hbut:key-to-label (hbut:label-to-key path)))
|
|
|
282 (or (not (string-match "[()]" path))
|
|
|
283 (string-match "\\`([^ \t\n\^M\)]+)[ *A-Za-z0-9]" path))
|
|
|
284 (if (string-match "\\${[^}]+}" path)
|
|
|
285 (setq path (hpath:substitute-value path))
|
|
|
286 t)
|
|
|
287 (not (string-match "[\t\n\^M\"`'{}|\\]" path))
|
|
|
288 (or (not (hpath:www-p path))
|
|
|
289 (string-match "^ftp:" path))
|
|
|
290 (let ((remote-path (string-match "@.+:\\|^/.+:\\|.+:/" path)))
|
|
|
291 (if (cond (remote-path
|
|
|
292 (cond ((eq type 'file)
|
|
|
293 (not (string-equal "/" (substring path -1))))
|
|
|
294 ((eq type 'directory)
|
|
|
295 (string-equal "/" (substring path -1)))
|
|
|
296 (t)))
|
|
|
297 ((or (and non-exist
|
|
|
298 (or
|
|
|
299 ;; Info or ange-ftp path, so don't check for.
|
|
|
300 (string-match "[()]" path)
|
|
|
301 (hpath:ange-ftp-p path)
|
|
|
302 (setq suffix (hpath:exists-p path t))
|
|
|
303 ;; Don't allow spaces in non-existent
|
|
|
304 ;; pathnames.
|
|
|
305 (not (string-match " " path))))
|
|
|
306 (setq suffix (hpath:exists-p path t)))
|
|
|
307 (cond ((eq type 'file)
|
|
|
308 (not (file-directory-p path)))
|
|
|
309 ((eq type 'directory)
|
|
|
310 (file-directory-p path))
|
|
|
311 (t)))
|
|
|
312 )
|
|
70
|
313 ;; Return path if non-nil return value
|
|
|
314 (if (stringp suffix) ;; suffix could = t, which we ignore
|
|
|
315 (if (string-match
|
|
|
316 (concat (regexp-quote suffix) "%s") rtn-path)
|
|
|
317 ;; remove suffix
|
|
|
318 (concat (substring rtn-path 0 (match-beginning 0))
|
|
|
319 (substring rtn-path (match-end 0)))
|
|
|
320 ;; add suffix
|
|
|
321 (format rtn-path suffix))
|
|
|
322 (format rtn-path "")))))))
|
|
0
|
323
|
|
|
324 (defun hpath:relative-to (path &optional default-dir)
|
|
70
|
325 "Returns PATH relative to optional DEFAULT-DIR or 'default-directory'.
|
|
0
|
326 Returns PATH unchanged when it is not a valid path."
|
|
|
327 (if (not (and (stringp path) (hpath:is-p path)))
|
|
|
328 path
|
|
|
329 (setq default-dir
|
|
|
330 (expand-file-name
|
|
|
331 (file-name-as-directory (or default-dir default-directory)))
|
|
|
332 path (expand-file-name path))
|
|
|
333 (and path default-dir
|
|
|
334 (if (string-equal "/" default-dir)
|
|
|
335 path
|
|
|
336 (let ((end-dir (min (length path) (length default-dir))))
|
|
|
337 (cond
|
|
|
338 ((string-equal (substring path 0 end-dir) default-dir)
|
|
|
339 (concat "./" (substring path end-dir)))
|
|
|
340 ((progn (setq default-dir (file-name-directory (directory-file-name default-dir))
|
|
|
341 end-dir (min (length path) (length default-dir)))
|
|
|
342 (string-equal (substring path 0 end-dir) default-dir))
|
|
|
343 (concat "../" (substring path end-dir)))
|
|
|
344 ((progn (setq default-dir (file-name-directory (directory-file-name default-dir))
|
|
|
345 end-dir (min (length path) (length default-dir)))
|
|
|
346 (string-equal (substring path 0 end-dir) default-dir))
|
|
|
347 (concat "../../" (substring path end-dir)))
|
|
|
348 (t path)))))))
|
|
|
349
|
|
|
350 (defun hpath:rfc (rfc-num)
|
|
|
351 "Return pathname to textual rfc document indexed by RFC-NUM.
|
|
70
|
352 See the documentation of the 'hpath:rfc' variable."
|
|
0
|
353 (format hpath:rfc rfc-num))
|
|
|
354
|
|
|
355 (defun hpath:substitute-value (path)
|
|
|
356 "Substitutes matching value for Emacs Lisp variables and environment variables in PATH.
|
|
|
357 Returns path with variable values substituted."
|
|
|
358 (substitute-in-file-name
|
|
|
359 (hypb:replace-match-string
|
|
|
360 "\\${[^}]+}"
|
|
|
361 path
|
|
|
362 (function
|
|
|
363 (lambda (str)
|
|
|
364 (let* ((var-group (substring path match start))
|
|
|
365 (var-name (substring path (+ match 2) (1- start)))
|
|
|
366 (rest-of-path (substring path start))
|
|
|
367 (sym (intern-soft var-name)))
|
|
|
368 (if (file-name-absolute-p rest-of-path)
|
|
|
369 (setq rest-of-path (substring rest-of-path 1)))
|
|
|
370 (if (and sym (boundp sym))
|
|
|
371 (directory-file-name
|
|
|
372 (hpath:substitute-dir var-name rest-of-path))
|
|
|
373 var-group))))
|
|
|
374 t)))
|
|
|
375
|
|
|
376 (defun hpath:substitute-var (path)
|
|
70
|
377 "Replaces up to one match in PATH with first matching variable from 'hpath:variables'."
|
|
0
|
378 (if (not (and (stringp path) (string-match "/" path) (hpath:is-p path)))
|
|
|
379 path
|
|
|
380 (setq path (hpath:symlink-referent path))
|
|
|
381 (let ((new-path)
|
|
|
382 (vars hpath:variables)
|
|
|
383 result var val)
|
|
|
384 (while (and vars (null new-path))
|
|
|
385 (setq var (car vars) vars (cdr vars))
|
|
|
386 (if (boundp var)
|
|
|
387 (progn (setq val (symbol-value var))
|
|
|
388 (cond ((stringp val)
|
|
|
389 (if (setq result
|
|
|
390 (hpath:substitute-var-name var val path))
|
|
|
391 (setq new-path result)))
|
|
|
392 ((null val))
|
|
|
393 ((listp val)
|
|
|
394 (while (and val (null new-path))
|
|
|
395 (if (setq result
|
|
|
396 (hpath:substitute-var-name var (car val) path))
|
|
|
397 (setq new-path result))
|
|
|
398 (setq val (cdr val))))
|
|
70
|
399 (t (error "(hpath:substitute-var): '%s' has invalid value for hpath:variables" var))))))
|
|
0
|
400 (or new-path path)
|
|
|
401 )))
|
|
|
402
|
|
|
403 ;;
|
|
|
404 ;; The following function recursively resolves all UNIX links to their
|
|
|
405 ;; final referents.
|
|
|
406 ;; Works with Apollo's variant and other strange links like:
|
|
|
407 ;; /usr/local -> $(SERVER_LOCAL)/usr/local, /usr/bin ->
|
|
|
408 ;; ../$(SYSTYPE)/usr/bin and /tmp -> `node_data/tmp. It also handles
|
|
|
409 ;; relative links properly as in /usr/local/emacs -> gnu/emacs which must
|
|
70
|
410 ;; be resolved relative to the '/usr/local' directory.
|
|
|
411 ;; It will fail on Apollos if the '../' notation is used to move just
|
|
|
412 ;; above the '/' directory level. This is fairly uncommon and so the
|
|
0
|
413 ;; problem has not been fixed.
|
|
|
414 ;;
|
|
|
415 (defun hpath:symlink-referent (linkname)
|
|
|
416 "Returns expanded file or directory referent of LINKNAME.
|
|
|
417 LINKNAME should not end with a directory delimiter.
|
|
|
418 Returns nil if LINKNAME is not a string.
|
|
|
419 Returns LINKNAME unchanged if it is not a symbolic link but is a pathname."
|
|
|
420 (if (stringp linkname)
|
|
|
421 (or (file-symlink-p linkname) linkname)))
|
|
|
422
|
|
|
423 (defun hpath:symlink-expand (referent dirname)
|
|
|
424 "Returns expanded file or directory REFERENT relative to DIRNAME."
|
|
|
425 (let ((var-link)
|
|
|
426 (dir dirname))
|
|
|
427 (while (string-match "\\$(\\([^\)]*\\))" referent)
|
|
|
428 (setq var-link (getenv (substring referent (match-beginning 1)
|
|
|
429 (match-end 1)))
|
|
|
430 referent (concat (substring referent 0 (match-beginning 0))
|
|
|
431 var-link
|
|
|
432 (substring referent (match-end 0)))))
|
|
|
433 ;; If referent is not an absolute path
|
|
|
434 (let ((nd-abbrev (string-match "`node_data" referent)))
|
|
|
435 (if (and nd-abbrev (= nd-abbrev 0))
|
|
|
436 (setq referent (concat
|
|
|
437 ;; Prepend node name given in dirname, if any
|
|
|
438 (and (string-match "^//[^/]+" dirname)
|
|
|
439 (substring dirname 0 (match-end 0)))
|
|
|
440 "/sys/" (substring referent 1)))))
|
|
|
441 (while (string-match "\\(^\\|/\\)\\.\\.\\(/\\|$\\)" referent)
|
|
|
442 ;; Match to "//.." or "/.." at the start of link referent
|
|
|
443 (while (string-match "^\\(//\\.\\.\\|/\\.\\.\\)\\(/\\|$\\)" referent)
|
|
|
444 (setq referent (substring referent (match-end 1))))
|
|
|
445 ;; Match to "../" or ".." at the start of link referent
|
|
|
446 (while (string-match "^\\.\\.\\(/\\|$\\)" referent)
|
|
|
447 (setq dir (file-name-directory (directory-file-name dir))
|
|
|
448 referent (concat dir (substring referent (match-end 0)))))
|
|
|
449 ;; Match to rest of "../" in link referent
|
|
|
450 (while (string-match "[^/]+/\\.\\./" referent)
|
|
|
451 (setq referent (concat (substring referent 0 (match-beginning 0))
|
|
|
452 (substring referent (match-end 0))))))
|
|
|
453 (and (/= (aref referent 0) ?~)
|
|
|
454 (/= (aref referent 0) ?/)
|
|
|
455 (setq referent (expand-file-name referent dirname))))
|
|
|
456 referent)
|
|
|
457
|
|
|
458 (defun hpath:validate (path)
|
|
|
459 "Returns PATH if PATH is a valid, readable path, else signals error.
|
|
|
460 Info and ange-ftp remote pathnames are considered readable without any
|
|
|
461 validation checks.
|
|
|
462 Default-directory should be equal to current Hyperbole button source
|
|
|
463 directory when called, so that PATH is expanded relative to it."
|
|
|
464 (cond ((not (stringp path))
|
|
|
465 (error "(hpath:validate): \"%s\" is not a pathname." path))
|
|
|
466 ((or (string-match "[()]" path) (hpath:ange-ftp-p path))
|
|
|
467 ;; info or ange-ftp path, so don't validate
|
|
|
468 path)
|
|
|
469 ((if (not (hpath:www-p path))
|
|
|
470 ;; Otherwise, must not be a WWW link ref and must be a readable
|
|
|
471 ;; path.
|
|
|
472 (let ((return-path (hpath:exists-p path)))
|
|
|
473 (and return-path (file-readable-p return-path)
|
|
|
474 return-path))))
|
|
|
475 (t (error "(hpath:validate): \"%s\" is not readable." path))))
|
|
|
476
|
|
|
477 (defun hpath:url-at-p ()
|
|
|
478 "Return world-wide-web universal resource locator (url) that point immediately precedes or nil.
|
|
|
479 Use buffer-substring with match-beginning and match-end on the following
|
|
|
480 groupings:
|
|
70
|
481 1 = access protocol
|
|
|
482 2 = optional username
|
|
|
483 3 = host and domain to connect to
|
|
|
484 4 = optional port number to use
|
|
|
485 5 = pathname to access."
|
|
|
486 ;; WWW URL format: <protocol>:/[<user>@]<domain>[:<port>]/<path>
|
|
|
487 ;; or <protocol>://[<user>@]<domain>[:<port>]<path>
|
|
0
|
488 ;; Avoid [a-z]:/path patterns since these may be disk paths on OS/2, DOS or
|
|
|
489 ;; Windows.
|
|
70
|
490 (if (looking-at "\\([a-zA-Z][a-zA-Z]+\\)://?\\([^@/: \t\n\^M]+@\\)?\\([^/:@ \t\n\^M\"`']+\\)\\(:[0-9]+\\)?\\([/~][^]@ \t\n\^M\"`'\)\}>]*\\)?")
|
|
0
|
491 (save-excursion
|
|
36
|
492 (goto-char (match-end 0))
|
|
70
|
493 (skip-chars-backward ".?#!*()")
|
|
|
494 (buffer-substring (match-beginning 0) (point)))))
|
|
0
|
495
|
|
|
496 (defun hpath:url-p (obj)
|
|
|
497 "Return t if OBJ is a world-wide-web universal resource locator (url) string, else nil.
|
|
|
498 Use string-match with match-beginning and match-end on the following groupings:
|
|
70
|
499 1 = access protocol
|
|
|
500 2 = optional username
|
|
|
501 3 = host and domain to connect to
|
|
|
502 4 = optional port number to use
|
|
|
503 5 = pathname to access."
|
|
|
504 ;; WWW URL format: <protocol>:/[<user>@]<domain>[:<port>]/<path>
|
|
|
505 ;; or <protocol>://[<user>@]<domain>[:<port>]<path>
|
|
0
|
506 ;; Avoid [a-z]:/path patterns since these may be disk paths on OS/2, DOS or
|
|
|
507 ;; Windows.
|
|
|
508 (and (stringp obj)
|
|
70
|
509 (string-match "\\`<?\\([a-zA-Z][a-zA-Z]+\\)://?\\([^@/: \t\n\^M]+@\\)?\\([^/:@ \t\n\^M\"`']+\\)\\(:[0-9]+\\)?\\([/~][^]@ \t\n\^M\"`'\)\}>]*\\)?>?\\'"
|
|
0
|
510 obj)
|
|
|
511 t))
|
|
|
512
|
|
|
513 (defun hpath:www-at-p (&optional include-start-and-end-p)
|
|
|
514 "Returns a world-wide-web link reference that point is within or nil.
|
|
|
515 With optional INCLUDE-START-AND-END-P non-nil, returns list of:
|
|
|
516 (link-string begin-position end-position)."
|
|
|
517 (save-excursion
|
|
|
518 (skip-chars-backward "^[ \t\n\"`'\(\{<")
|
|
|
519 (cond ((not include-start-and-end-p)
|
|
|
520 (hpath:url-at-p))
|
|
|
521 ((hpath:url-at-p)
|
|
70
|
522 (list (buffer-substring (match-beginning 0) (match-end 0))
|
|
|
523 (match-beginning 0)
|
|
36
|
524 (match-end 0))))))
|
|
0
|
525
|
|
|
526 (defun hpath:www-p (path)
|
|
|
527 "Returns non-nil iff PATH is a world-wide-web link reference."
|
|
|
528 (and (stringp path) (hpath:url-p path) path))
|
|
|
529
|
|
|
530 ;;; ************************************************************************
|
|
|
531 ;;; Private functions
|
|
|
532 ;;; ************************************************************************
|
|
|
533
|
|
|
534 (defun hpath:ange-ftp-available-p ()
|
|
|
535 "Return t if the ange-ftp or efs package is available, nil otherwise.
|
|
|
536 Either the package must have been loaded already or under versions of Emacs
|
|
70
|
537 19, it must be set for autoloading via 'file-name-handler-alist'."
|
|
0
|
538 (or (featurep 'ange-ftp) (featurep 'efs)
|
|
|
539 (and (boundp 'file-name-handler-alist) ; v19
|
|
|
540 (or (rassq 'ange-ftp-hook-function file-name-handler-alist)
|
|
|
541 (rassq 'efs-file-handler-function file-name-handler-alist))
|
|
|
542 t)))
|
|
|
543
|
|
|
544
|
|
|
545
|
|
|
546 (defun hpath:ange-ftp-default-user ()
|
|
|
547 "Return default user account for remote file access with ange-ftp or efs.
|
|
|
548 Returns \"anonymous\" if neither ange-ftp-default-user nor efs-default-user
|
|
|
549 is set."
|
|
|
550 (cond ((and (boundp 'ange-ftp-default-user)
|
|
|
551 (stringp ange-ftp-default-user))
|
|
|
552 ange-ftp-default-user)
|
|
|
553 ((and (boundp 'efs-default-user)
|
|
|
554 (stringp efs-default-user))
|
|
|
555 efs-default-user)
|
|
|
556 (t "anonymous")))
|
|
|
557
|
|
|
558 (defun hpath:delete-trailer (string)
|
|
|
559 "Return string minus any trailing .?#!*() characters."
|
|
|
560 (save-match-data
|
|
|
561 (if (and (stringp string) (> (length string) 0)
|
|
|
562 (string-match "[.?#!*()]+\\'" string))
|
|
|
563 (substring string 0 (match-beginning 0))
|
|
|
564 string)))
|
|
|
565
|
|
|
566 (defun hpath:exists-p (path &optional suffix-flag)
|
|
|
567 "Return PATH if it exists. (This does not mean you can read it.)
|
|
|
568 If PATH exists with or without a suffix from hpath:suffixes, then that
|
|
|
569 pathname is returned.
|
|
|
570
|
|
|
571 With optional SUFFIX-FLAG and PATH exists, return suffix added or removed
|
|
|
572 from path or t."
|
|
|
573 (let ((return-path)
|
|
|
574 (suffix) suffixes)
|
|
|
575 (if (file-exists-p path)
|
|
|
576 (setq return-path path)
|
|
|
577 (setq suffixes hpath:suffixes)
|
|
|
578 (while suffixes
|
|
|
579 (setq suffix (car suffixes))
|
|
|
580 (if (string-match (concat (regexp-quote suffix) "\\'") path)
|
|
|
581 ;; Remove suffix
|
|
|
582 (setq return-path (substring path 0 (match-beginning 0)))
|
|
|
583 ;; Add suffix
|
|
|
584 (setq return-path (concat path suffix)))
|
|
|
585 (if (file-exists-p return-path)
|
|
|
586 (setq suffixes nil);; found a match
|
|
|
587 (setq suffix nil
|
|
|
588 suffixes (cdr suffixes)
|
|
|
589 return-path nil))))
|
|
|
590 (if return-path
|
|
|
591 (if suffix-flag
|
|
|
592 (or suffix t)
|
|
|
593 return-path))))
|
|
|
594
|
|
|
595 (defun hpath:find-program (filename)
|
|
|
596 "Return shell or Lisp command to execute to display FILENAME or nil.
|
|
|
597 Return nil if FILENAME is a directory name.
|
|
70
|
598 See also documentation for 'hpath:find-alist' and 'hpath:display-alist'."
|
|
0
|
599 (let ((cmd))
|
|
|
600 (cond ((and (stringp filename) (file-directory-p filename))
|
|
|
601 nil)
|
|
|
602 ((stringp (setq cmd (hpath:match filename hpath:find-alist)))
|
|
|
603 (let ((orig-path filename))
|
|
|
604 ;; If filename is a remote path, we have to copy it to a
|
|
|
605 ;; temporary local file and then display that.
|
|
|
606 (if (hpath:ange-ftp-p filename)
|
|
|
607 (copy-file orig-path
|
|
|
608 (setq filename
|
|
|
609 (concat hpath:tmp-prefix
|
|
|
610 (file-name-nondirectory orig-path)))
|
|
|
611 t t))
|
|
|
612 ;;
|
|
|
613 ;; Permit %s substitution of filename within program.
|
|
|
614 (if (string-match "[^%]%s" cmd)
|
|
|
615 (format cmd filename)
|
|
|
616 (concat cmd " " filename))))
|
|
|
617 ((null cmd)
|
|
|
618 (hpath:match filename hpath:display-alist))
|
|
|
619 (t cmd))))
|
|
|
620
|
|
|
621 (defun hpath:match (filename regexp-alist)
|
|
|
622 "If FILENAME matches the car of any element in REGEXP-ALIST, return its cdr.
|
|
|
623 REGEXP-ALIST elements must be of the form (<filename-regexp>
|
|
|
624 . <command-to-display-file>). <command-to-display-file> may be a string
|
|
|
625 representing an external window-system command to run or it may be a Lisp
|
|
|
626 function to call with FILENAME as its single argument."
|
|
|
627 (let ((cmd)
|
|
|
628 elt)
|
|
|
629 (while (and (not cmd) regexp-alist)
|
|
|
630 (if (string-match (car (setq elt (car regexp-alist))) filename)
|
|
|
631 (setq cmd (cdr elt)))
|
|
|
632 (setq regexp-alist (cdr regexp-alist)))
|
|
|
633 cmd))
|
|
|
634
|
|
|
635 (defun hpath:substitute-dir (var-name rest-of-path)
|
|
|
636 "Returns a dir for VAR-NAME using REST-OF-PATH to find match or triggers an error when no match.
|
|
|
637 VAR-NAME's value may be a directory or a list of directories. If it is a
|
|
|
638 list, the first directory prepended to REST-OF-PATH which produces a valid
|
|
|
639 local pathname is returned."
|
|
|
640 (let (sym val)
|
|
|
641 (cond ((not (stringp var-name))
|
|
70
|
642 (error "(hpath:substitute-dir): VAR-NAME arg, '%s', must be a string" var-name))
|
|
0
|
643 ((not (and (setq sym (intern-soft var-name))
|
|
|
644 (boundp sym)))
|
|
|
645 (error "(hpath:substitute-dir): VAR-NAME arg, \"%s\", is not a bound variable"
|
|
|
646 var-name))
|
|
|
647 ((stringp (setq val (symbol-value sym)))
|
|
|
648 (if (hpath:validate (expand-file-name rest-of-path val))
|
|
|
649 val))
|
|
|
650 ((listp val)
|
|
|
651 (let ((dir))
|
|
|
652 (while (and val (not dir))
|
|
|
653 (setq dir (car val) val (cdr val))
|
|
|
654 (or (and (stringp dir)
|
|
|
655 (file-name-absolute-p dir)
|
|
|
656 (file-readable-p (expand-file-name rest-of-path dir)))
|
|
|
657 (setq dir nil)))
|
|
|
658 (if dir (hpath:validate (directory-file-name dir))
|
|
|
659 (error "(hpath:substitute-dir): Can't find match for \"%s\""
|
|
|
660 (concat "${" var-name "}/" rest-of-path))
|
|
|
661 )))
|
|
|
662 (t (error "(hpath:substitute-dir): Value of VAR-NAME, \"%s\", must be a string or list" var-name))
|
|
|
663 )))
|
|
|
664
|
|
|
665 (defun hpath:substitute-var-name (var-symbol var-dir-val path)
|
|
|
666 "Replaces with VAR-SYMBOL any occurrences of VAR-DIR-VAL in PATH.
|
|
|
667 Replacement is done iff VAR-DIR-VAL is an absolute path.
|
|
|
668 If PATH is modified, returns PATH, otherwise returns nil."
|
|
|
669 (if (and (stringp var-dir-val) (file-name-absolute-p var-dir-val))
|
|
|
670 (let ((new-path (hypb:replace-match-string
|
|
|
671 (regexp-quote (file-name-as-directory
|
|
|
672 (or var-dir-val default-directory)))
|
|
|
673 path (concat "${" (symbol-name var-symbol) "}/")
|
|
|
674 t)))
|
|
|
675 (if (equal new-path path) nil new-path))))
|
|
|
676
|
|
|
677
|
|
|
678 ;;; ************************************************************************
|
|
|
679 ;;; Private variables
|
|
|
680 ;;; ************************************************************************
|
|
|
681
|
|
|
682
|
|
|
683 (defvar hpath:prefix-regexp "\\`[-!&][ ]*"
|
|
|
684 "Regexp matching command characters which may precede a pathname.
|
|
|
685 These are used to indicate how to display or execute the pathname.
|
|
|
686 - means evaluate it as Emacs Lisp;
|
|
|
687 ! means execute it as a shell script
|
|
|
688 & means run it under the current window system.")
|
|
|
689
|
|
|
690 (provide 'hpath)
|
