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