Mercurial > hg > xemacs-beta

comparison lisp/hyperbole/hpath.el @ 100:4be1180a9e89 r20-1b2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b2
author cvs
date Mon, 13 Aug 2007 09:15:11 +0200
parents 131b0175ea99
children 8619ce7e4c50
comparison
equal deleted inserted replaced
99:2d83cbd90d8d 100:4be1180a9e89
4 ;; SUMMARY: Hyperbole support routines for handling UNIX paths. 4 ;; SUMMARY: Hyperbole support routines for handling UNIX paths.
5 ;; USAGE: GNU Emacs Lisp Library 5 ;; USAGE: GNU Emacs Lisp Library
6 ;; KEYWORDS: comm, hypermedia, unix 6 ;; KEYWORDS: comm, hypermedia, unix
7 ;; 7 ;;
8 ;; AUTHOR: Bob Weiner 8 ;; AUTHOR: Bob Weiner
9 ;; ORG: Brown U. 9 ;; ORG: InfoDock Associates
10 ;; 10 ;;
11 ;; ORIG-DATE: 1-Nov-91 at 00:44:23 11 ;; ORIG-DATE: 1-Nov-91 at 00:44:23
12 ;; LAST-MOD: 10-Oct-95 at 23:31:56 by Bob Weiner 12 ;; LAST-MOD: 16-Feb-97 at 02:34:35 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.
22 13
23 ;;; ************************************************************************ 14 ;;; ************************************************************************
24 ;;; Public variables 15 ;;; Public variables
25 ;;; ************************************************************************ 16 ;;; ************************************************************************
26 17
27 (defvar hpath:rfc "/anonymous@ds.internic.net:rfc/rfc%s.txt" 18 (defvar hpath:rfc "/anonymous@ds.internic.net:rfc/rfc%s.txt"
28 "*String to be used in the call: (hpath:rfc rfc-num) 19 "*String to be used in the call: (hpath:rfc rfc-num)
29 to create an path to the RFC document for 'rfc-num'.") 20 to create an path to the RFC document for `rfc-num'.")
30 21
31 (defvar hpath:suffixes '(".gz" ".Z") 22 (defvar hpath:suffixes '(".gz" ".Z")
32 "*List of filename suffixes to add or remove within (hpath:exists-p) calls.") 23 "*List of filename suffixes to add or remove within (hpath:exists-p) calls.")
33 24
34 (defvar hpath:tmp-prefix "/tmp/remote-" 25 (defvar hpath:tmp-prefix "/tmp/remote-"
37 ;;; ************************************************************************ 28 ;;; ************************************************************************
38 ;;; Public functions 29 ;;; Public functions
39 ;;; ************************************************************************ 30 ;;; ************************************************************************
40 31
41 (defun hpath:absolute-to (path &optional default-dirs) 32 (defun hpath:absolute-to (path &optional default-dirs)
42 "Returns PATH as an absolute path relative to one directory from optional DEFAULT-DIRS or 'default-directory'. 33 "Returns PATH as an absolute path relative to one directory from optional DEFAULT-DIRS or `default-directory'.
43 Returns PATH unchanged when it is not a valid path or when DEFAULT-DIRS 34 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 35 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." 36 directories. The first one in which PATH is found is used."
46 (if (not (and (stringp path) (hpath:is-p path nil t))) 37 (if (not (and (stringp path) (hpath:is-p path nil t)))
47 path 38 path
61 (or (file-exists-p rtn) (setq rtn nil))) 52 (or (file-exists-p rtn) (setq rtn nil)))
62 (or rtn path))))) 53 (or rtn path)))))
63 54
64 (defun hpath:ange-ftp-at-p () 55 (defun hpath:ange-ftp-at-p ()
65 "Returns an ange-ftp pathname that point is within or nil. 56 "Returns an ange-ftp pathname that point is within or nil.
66 See the 'ange-ftp' or 'efs' Elisp packages for pathname format details. 57 See the `ange-ftp' or `efs' Elisp packages for pathname format details.
67 Always returns nil if (hpath:ange-ftp-available-p) returns nil." 58 Always returns nil if (hpath:ange-ftp-available-p) returns nil."
68 (if (hpath:ange-ftp-available-p) 59 (if (hpath:ange-ftp-available-p)
69 (let ((user (hpath:ange-ftp-default-user)) 60 (let ((user (hpath:ange-ftp-default-user))
70 path) 61 path)
71 (setq path 62 (setq path
72 (save-excursion 63 (save-excursion
73 (skip-chars-backward "^[ \t\n\"`'\(\{<") 64 (skip-chars-backward "^[ \t\n\"`'\(\{<")
74 (cond 65 (cond
75 ((hpath:url-at-p) 66 ((hpath:url-at-p)
76 (if (string-equal 67 (if (string-equal
77 (buffer-substring (match-beginning 1) (match-end 1)) 68 (buffer-substring (match-beginning 2) (match-end 2))
78 "ftp") 69 "ftp")
79 (concat 70 (concat
80 "/" 71 "/"
81 ;; user 72 ;; user
82 (if (match-beginning 2) 73 (if (match-beginning 3)
83 (buffer-substring 74 (buffer-substring
84 (match-beginning 2) (match-end 2)) 75 (match-beginning 3) (match-end 3))
85 (concat user "@")) 76 (concat user "@"))
86 ;; domain 77 ;; domain
87 (hpath:delete-trailer 78 (hpath:delete-trailer
88 (buffer-substring (match-beginning 3) (match-end 3))) 79 (buffer-substring (match-beginning 4) (match-end 4)))
89 ":" 80 ":"
90 ;; path 81 ;; path
91 (if (match-beginning 5) 82 (if (match-beginning 6)
92 (buffer-substring (match-beginning 5) 83 (buffer-substring (match-beginning 6)
93 (match-end 5)))) 84 (match-end 6))))
94 ;; else ignore this other type of WWW path 85 ;; else ignore this other type of WWW path
95 )) 86 ))
96 ;; user, domain and path 87 ;; user, domain and path
97 ((looking-at "/?[^/:@ \t\n\^M\"`']+@[^/:@ \t\n\^M\"`']+:[^]@ \t\n\^M\"`'\)\}]*") 88 ((looking-at "/?[^/:@ \t\n\^M\"`']+@[^/:@ \t\n\^M\"`']+:[^]@ \t\n\^M\"`'\)\}]*")
98 (buffer-substring (match-beginning 0) (match-end 0))) 89 (buffer-substring (match-beginning 0) (match-end 0)))
118 ))) 109 )))
119 (hpath:delete-trailer path)))) 110 (hpath:delete-trailer path))))
120 111
121 (defun hpath:ange-ftp-p (path) 112 (defun hpath:ange-ftp-p (path)
122 "Returns non-nil iff PATH is an ange-ftp pathname. 113 "Returns non-nil iff PATH is an ange-ftp pathname.
123 See the 'ange-ftp' or 'efs' Elisp package for pathname format details. 114 See the `ange-ftp' or `efs' Elisp package for pathname format details.
124 Always returns nil if (hpath:ange-ftp-available-p) returns nil." 115 Always returns nil if (hpath:ange-ftp-available-p) returns nil."
125 (and (stringp path) 116 (and (stringp path)
126 (or (featurep 'ange-ftp) (featurep 'efs)) 117 (or (featurep 'ange-ftp) (featurep 'efs))
127 (let ((user (hpath:ange-ftp-default-user)) 118 (let ((user (hpath:ange-ftp-default-user))
128 result) 119 result)
129 (setq result 120 (setq result
130 (cond 121 (cond
131 ((hpath:url-p path) 122 ((hpath:url-p path)
132 (if (string-equal 123 (if (string-equal
133 (substring path (match-beginning 1) (match-end 1)) 124 (substring path (match-beginning 2) (match-end 2))
134 "ftp") 125 "ftp")
135 (concat 126 (concat
136 "/" 127 "/"
137 ;; user 128 ;; user
138 (if (match-beginning 2) 129 (if (match-beginning 3)
139 (substring path (match-beginning 2) (match-end 2)) 130 (substring path (match-beginning 3) (match-end 3))
140 (concat user "@")) 131 (concat user "@"))
141 ;; domain 132 ;; domain
142 (hpath:delete-trailer 133 (hpath:delete-trailer
143 (substring path (match-beginning 3) (match-end 3))) 134 (substring path (match-beginning 4) (match-end 4)))
144 ":" 135 ":"
145 ;; path 136 ;; path
146 (if (match-beginning 5) 137 (if (match-beginning 6)
147 (substring path (match-beginning 5) 138 (substring path (match-beginning 6)
148 (match-end 5)))) 139 (match-end 6))))
149 ;; else ignore this other type of WWW path 140 ;; else ignore this other type of WWW path
150 )) 141 ))
151 ;; user, domain and path 142 ;; user, domain and path
152 ((string-match "/?[^/:@ \t\n\^M\"`']+@[^/:@ \t\n\^M\"`']+:[^]@ \t\n\^M\"`'\)\}]*" 143 ((string-match "/?[^/:@ \t\n\^M\"`']+@[^/:@ \t\n\^M\"`']+:[^]@ \t\n\^M\"`'\)\}]*"
153 path) 144 path)
184 Delimiters may be: double quotes, open and close single quote, or 175 Delimiters may be: double quotes, open and close single quote, or
185 Texinfo file references. 176 Texinfo file references.
186 If optional TYPE is the symbol 'file or 'directory, then only that path type is 177 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. 178 accepted as a match. Only locally reachable paths are checked for existence.
188 With optional NON-EXIST, nonexistent local paths are allowed. 179 With optional NON-EXIST, nonexistent local paths are allowed.
189 Absolute pathnames must begin with a '/' or '~'. Relative pathnames 180 Absolute pathnames must begin with a `/' or `~'. Relative pathnames
190 must begin with a './' or '../' to be recognized." 181 must begin with a `./' or `../' to be recognized."
191 (cond (;; Local file URLs 182 (cond (;; Local file URLs
192 (hpath:is-p (hargs:delimited 183 (hpath:is-p (hargs:delimited
193 "file://localhost" "[ \t\n\^M\"\'\}]" nil t))) 184 "file://localhost" "[ \t\n\^M\"\'\}]" nil t)))
194 ((hpath:ange-ftp-at-p)) 185 ((hpath:ange-ftp-at-p))
195 ((hpath:www-at-p) nil) 186 ((hpath:www-at-p) nil)
198 (hargs:delimited "\`" "\'") 189 (hargs:delimited "\`" "\'")
199 ;; Filenames in TexInfo docs 190 ;; Filenames in TexInfo docs
200 (hargs:delimited "@file{" "}")) 191 (hargs:delimited "@file{" "}"))
201 type non-exist)))) 192 type non-exist))))
202 193
203 (defun hpath:find (filename &optional other-window-p) 194 (defun hpath:display-buffer (buffer &optional display-where)
204 "Edit file FILENAME using program from hpath:find-alist if available. 195 "Displays BUFFER at optional DISPLAY-WHERE location or at hpath:display-where.
205 Otherwise, switch to a buffer visiting file FILENAME, creating one if none 196 BUFFER may be a buffer or a buffer name.
206 already exists. 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.
207 228
208 FILENAME may start with a special prefix character which is 229 FILENAME may start with a special prefix character which is
209 handled as follows: 230 handled as follows:
210 !filename - execute as a non-windowed program within a shell; 231 !filename - execute as a non-windowed program within a shell;
211 &filename - execute as a windowed program; 232 &filename - execute as a windowed program;
212 -filename - load as an Emacs Lisp program. 233 -filename - load as an Emacs Lisp program.
213 234
214 Return non-nil iff file is displayed within a buffer (not with an external 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
215 program)." 243 program)."
216 (interactive "FFind file: ") 244 (interactive "FFind file: ")
217 (let (modifier) 245 (let (modifier)
218 (if (string-match hpath:prefix-regexp filename) 246 (if (string-match hpath:prefix-regexp filename)
219 (setq modifier (aref filename 0) 247 (setq modifier (aref filename 0)
230 (cond ((stringp find-program) 258 (cond ((stringp find-program)
231 (hact 'exec-window-cmd find-program) 259 (hact 'exec-window-cmd find-program)
232 nil) 260 nil)
233 ((hypb:functionp find-program) 261 ((hypb:functionp find-program)
234 (funcall find-program filename) 262 (funcall find-program filename)
235 nil) 263 t)
236 (t (setq filename (hpath:validate filename)) 264 (t (setq filename (hpath:validate filename))
237 (funcall (if (and other-window-p 265 (if (null display-where)
238 (not (br-in-browser))) 266 (setq display-where hpath:display-where))
239 'switch-to-buffer-other-window 267 (funcall (car (cdr (or (assq display-where
240 'switch-to-buffer) 268 hpath:display-where-alist)
241 (find-file-noselect filename)) 269 (assq 'other-window
270 hpath:display-where-alist))))
271 filename)
242 t))))))) 272 t)))))))
243 273
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
244 (defun hpath:find-other-window (filename) 312 (defun hpath:find-other-window (filename)
245 "Edit file FILENAME, in another window or using program from hpath:find-alist. 313 "Edits file FILENAME, in another window or using an external program.
246 May create a new window, or reuse an existing one; see the function display-buffer. 314 May create a new window, or reuse an existing one; see the function display-buffer.
247 315 See documentation of `hpath:find' for details.
248 Alternatively, FILENAME may start with a prefix character to indicate special 316 Returns non-nil iff file is displayed within a buffer."
249 handling. See documentation of `hpath:find' for details.
250
251 Return non-nil iff file is displayed within a buffer."
252 (interactive "FFind file in other window: ") 317 (interactive "FFind file in other window: ")
253 (hpath:find filename t)) 318 (hpath:find filename 'other-window))
254 319
255 (defun hpath:is-p (path &optional type non-exist) 320 (defun hpath:is-p (path &optional type non-exist)
256 "Returns PATH if PATH is a Unix path, else nil. 321 "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 322 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 323 is accepted as a match. The existence of the path is checked only for
273 path (substring path 0 (match-beginning 0))) 338 path (substring path 0 (match-beginning 0)))
274 (setq rtn-path (concat rtn-path "%s"))) 339 (setq rtn-path (concat rtn-path "%s")))
275 (if (string-match hpath:prefix-regexp path) 340 (if (string-match hpath:prefix-regexp path)
276 (setq path (substring path (match-end 0))) 341 (setq path (substring path (match-end 0)))
277 t) 342 t)
278 (not (or (string= path "") 343 (not (or (string-equal path "")
279 (string-match "\\`\\s \\|\\s \\'" path))) 344 (string-match "\\`\\s \\|\\s \\'" path)))
280 ;; Convert tabs and newlines to space. 345 ;; Convert tabs and newlines to space.
281 (setq path (hbut:key-to-label (hbut:label-to-key path))) 346 (setq path (hbut:key-to-label (hbut:label-to-key path)))
282 (or (not (string-match "[()]" path)) 347 (or (not (string-match "[()]" path))
283 (string-match "\\`([^ \t\n\^M\)]+)[ *A-Za-z0-9]" path)) 348 (string-match "\\`([^ \t\n\^M\)]+)[ *A-Za-z0-9]" path))
308 (not (file-directory-p path))) 373 (not (file-directory-p path)))
309 ((eq type 'directory) 374 ((eq type 'directory)
310 (file-directory-p path)) 375 (file-directory-p path))
311 (t))) 376 (t)))
312 ) 377 )
313 ;; Return path if non-nil return value 378 (progn
314 (if (stringp suffix) ;; suffix could = t, which we ignore 379 ;; Quote any but last %s within rtn-path.
315 (if (string-match 380 (setq rtn-path (hypb:replace-match-string "%s" rtn-path "%%s")
316 (concat (regexp-quote suffix) "%s") rtn-path) 381 rtn-path (hypb:replace-match-string "%%s\\'" rtn-path "%s"))
317 ;; remove suffix 382 ;; Return path if non-nil return value.
318 (concat (substring rtn-path 0 (match-beginning 0)) 383 (if (stringp suffix);; suffix could = t, which we ignore
319 (substring rtn-path (match-end 0))) 384 (if (string-match
320 ;; add suffix 385 (concat (regexp-quote suffix) "%s") rtn-path)
321 (format rtn-path suffix)) 386 ;; remove suffix
322 (format rtn-path ""))))))) 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 ""))))))))
323 392
324 (defun hpath:relative-to (path &optional default-dir) 393 (defun hpath:relative-to (path &optional default-dir)
325 "Returns PATH relative to optional DEFAULT-DIR or 'default-directory'. 394 "Returns PATH relative to optional DEFAULT-DIR or `default-directory'.
326 Returns PATH unchanged when it is not a valid path." 395 Returns PATH unchanged when it is not a valid path."
327 (if (not (and (stringp path) (hpath:is-p path))) 396 (if (not (and (stringp path) (hpath:is-p path)))
328 path 397 path
329 (setq default-dir 398 (setq default-dir
330 (expand-file-name 399 (expand-file-name
347 (concat "../../" (substring path end-dir))) 416 (concat "../../" (substring path end-dir)))
348 (t path))))))) 417 (t path)))))))
349 418
350 (defun hpath:rfc (rfc-num) 419 (defun hpath:rfc (rfc-num)
351 "Return pathname to textual rfc document indexed by RFC-NUM. 420 "Return pathname to textual rfc document indexed by RFC-NUM.
352 See the documentation of the 'hpath:rfc' variable." 421 See the documentation of the `hpath:rfc' variable."
353 (format hpath:rfc rfc-num)) 422 (format hpath:rfc rfc-num))
354 423
355 (defun hpath:substitute-value (path) 424 (defun hpath:substitute-value (path)
356 "Substitutes matching value for Emacs Lisp variables and environment variables in PATH. 425 "Substitutes matching value for Emacs Lisp variables and environment variables in PATH.
357 Returns path with variable values substituted." 426 Returns path with variable values substituted."
372 (hpath:substitute-dir var-name rest-of-path)) 441 (hpath:substitute-dir var-name rest-of-path))
373 var-group)))) 442 var-group))))
374 t))) 443 t)))
375 444
376 (defun hpath:substitute-var (path) 445 (defun hpath:substitute-var (path)
377 "Replaces up to one match in PATH with first matching variable from 'hpath:variables'." 446 "Replaces up to one match in PATH with first matching variable from `hpath:variables'."
378 (if (not (and (stringp path) (string-match "/" path) (hpath:is-p path))) 447 (if (not (and (stringp path) (string-match "/" path) (hpath:is-p path)))
379 path 448 path
380 (setq path (hpath:symlink-referent path)) 449 (setq path (hpath:symlink-referent path))
381 (let ((new-path) 450 (let ((new-path)
382 (vars hpath:variables) 451 (vars hpath:variables)
394 (while (and val (null new-path)) 463 (while (and val (null new-path))
395 (if (setq result 464 (if (setq result
396 (hpath:substitute-var-name var (car val) path)) 465 (hpath:substitute-var-name var (car val) path))
397 (setq new-path result)) 466 (setq new-path result))
398 (setq val (cdr val)))) 467 (setq val (cdr val))))
399 (t (error "(hpath:substitute-var): '%s' has invalid value for hpath:variables" var)))))) 468 (t (error "(hpath:substitute-var): `%s' has invalid value for hpath:variables" var))))))
400 (or new-path path) 469 (or new-path path)
401 ))) 470 )))
402 471
403 ;; 472 ;;
404 ;; The following function recursively resolves all UNIX links to their 473 ;; The following function recursively resolves all UNIX links to their
405 ;; final referents. 474 ;; final referents.
406 ;; Works with Apollo's variant and other strange links like: 475 ;; Works with Apollo's variant and other strange links like:
407 ;; /usr/local -> $(SERVER_LOCAL)/usr/local, /usr/bin -> 476 ;; /usr/local -> $(SERVER_LOCAL)/usr/local, /usr/bin ->
408 ;; ../$(SYSTYPE)/usr/bin and /tmp -> `node_data/tmp. It also handles 477 ;; ../$(SYSTYPE)/usr/bin and /tmp -> `node_data/tmp. It also handles
409 ;; relative links properly as in /usr/local/emacs -> gnu/emacs which must 478 ;; relative links properly as in /usr/local/emacs -> gnu/emacs which must
410 ;; be resolved relative to the '/usr/local' directory. 479 ;; be resolved relative to the `/usr/local' directory.
411 ;; It will fail on Apollos if the '../' notation is used to move just 480 ;; 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 481 ;; above the `/' directory level. This is fairly uncommon and so the
413 ;; problem has not been fixed. 482 ;; problem has not been fixed.
414 ;; 483 ;;
415 (defun hpath:symlink-referent (linkname) 484 (defun hpath:symlink-referent (linkname)
416 "Returns expanded file or directory referent of LINKNAME. 485 "Returns expanded file or directory referent of LINKNAME.
417 LINKNAME should not end with a directory delimiter. 486 LINKNAME should not end with a directory delimiter.
476 545
477 (defun hpath:url-at-p () 546 (defun hpath:url-at-p ()
478 "Return world-wide-web universal resource locator (url) that point immediately precedes or nil. 547 "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 548 Use buffer-substring with match-beginning and match-end on the following
480 groupings: 549 groupings:
481 1 = access protocol 550 1 = optional `URL:' literal
482 2 = optional username 551 2 = access protocol
483 3 = host and domain to connect to 552 4 = optional username
484 4 = optional port number to use 553 4 = host and domain to connect to
485 5 = pathname to access." 554 5 = optional port number to use
486 ;; WWW URL format: <protocol>:/[<user>@]<domain>[:<port>]/<path> 555 6 = pathname to access."
487 ;; or <protocol>://[<user>@]<domain>[:<port>]<path> 556 ;; WWW URL format: [URL:]<protocol>:/[<user>@]<domain>[:<port>]/<path>
557 ;; or [URL:]<protocol>://[<user>@]<domain>[:<port>]<path>
488 ;; Avoid [a-z]:/path patterns since these may be disk paths on OS/2, DOS or 558 ;; Avoid [a-z]:/path patterns since these may be disk paths on OS/2, DOS or
489 ;; Windows. 559 ;; Windows.
490 (if (looking-at "\\([a-zA-Z][a-zA-Z]+\\)://?\\([^@/: \t\n\^M]+@\\)?\\([^/:@ \t\n\^M\"`']+\\)\\(:[0-9]+\\)?\\([/~][^]@ \t\n\^M\"`'\)\}>]*\\)?") 560 (if (looking-at "\\(URL:\\)?\\([a-zA-Z][a-zA-Z]+\\)://?\\([^@/: \t\n\^M]+@\\)?\\([^/:@ \t\n\^M\"`']+\\)\\(:[0-9]+\\)?\\([/~][^]@ \t\n\^M\"`'\)\}>]*\\)?")
491 (save-excursion 561 (save-excursion
492 (goto-char (match-end 0)) 562 (goto-char (match-end 6))
493 (skip-chars-backward ".?#!*()") 563 (skip-chars-backward ".?#!*()")
494 (buffer-substring (match-beginning 0) (point))))) 564 (buffer-substring (match-beginning 2) (point)))))
495 565
496 (defun hpath:url-p (obj) 566 (defun hpath:url-p (obj)
497 "Return t if OBJ is a world-wide-web universal resource locator (url) string, else nil. 567 "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: 568 Use string-match with match-beginning and match-end on the following groupings:
499 1 = access protocol 569 1 = optional `URL:' literal
500 2 = optional username 570 2 = access protocol
501 3 = host and domain to connect to 571 3 = optional username
502 4 = optional port number to use 572 4 = host and domain to connect to
503 5 = pathname to access." 573 5 = optional port number to use
504 ;; WWW URL format: <protocol>:/[<user>@]<domain>[:<port>]/<path> 574 6 = pathname to access."
505 ;; or <protocol>://[<user>@]<domain>[:<port>]<path> 575 ;; WWW URL format: [URL:]<protocol>:/[<user>@]<domain>[:<port>]/<path>
576 ;; or [URL:]<protocol>://[<user>@]<domain>[:<port>]<path>
506 ;; Avoid [a-z]:/path patterns since these may be disk paths on OS/2, DOS or 577 ;; Avoid [a-z]:/path patterns since these may be disk paths on OS/2, DOS or
507 ;; Windows. 578 ;; Windows.
508 (and (stringp obj) 579 (and (stringp obj)
509 (string-match "\\`<?\\([a-zA-Z][a-zA-Z]+\\)://?\\([^@/: \t\n\^M]+@\\)?\\([^/:@ \t\n\^M\"`']+\\)\\(:[0-9]+\\)?\\([/~][^]@ \t\n\^M\"`'\)\}>]*\\)?>?\\'" 580 (string-match "\\`<?\\(URL:\\)?\\([a-zA-Z][a-zA-Z]+\\)://?\\([^@/: \t\n\^M]+@\\)?\\([^/:@ \t\n\^M\"`']+\\)\\(:[0-9]+\\)?\\([/~][^]@ \t\n\^M\"`'\)\}>]*\\)?>?\\'"
510 obj) 581 obj)
511 t)) 582 t))
512 583
513 (defun hpath:www-at-p (&optional include-start-and-end-p) 584 (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. 585 "Returns a world-wide-web link reference that point is within or nil.
517 (save-excursion 588 (save-excursion
518 (skip-chars-backward "^[ \t\n\"`'\(\{<") 589 (skip-chars-backward "^[ \t\n\"`'\(\{<")
519 (cond ((not include-start-and-end-p) 590 (cond ((not include-start-and-end-p)
520 (hpath:url-at-p)) 591 (hpath:url-at-p))
521 ((hpath:url-at-p) 592 ((hpath:url-at-p)
522 (list (buffer-substring (match-beginning 0) (match-end 0)) 593 (list (buffer-substring (match-beginning 2) (match-end 6))
523 (match-beginning 0) 594 (match-beginning 2)
524 (match-end 0)))))) 595 (match-end 6))))))
525 596
526 (defun hpath:www-p (path) 597 (defun hpath:www-p (path)
527 "Returns non-nil iff PATH is a world-wide-web link reference." 598 "Returns non-nil iff PATH is a world-wide-web link reference."
528 (and (stringp path) (hpath:url-p path) path)) 599 (and (stringp path) (hpath:url-p path) path))
529 600
532 ;;; ************************************************************************ 603 ;;; ************************************************************************
533 604
534 (defun hpath:ange-ftp-available-p () 605 (defun hpath:ange-ftp-available-p ()
535 "Return t if the ange-ftp or efs package is available, nil otherwise. 606 "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 607 Either the package must have been loaded already or under versions of Emacs
537 19, it must be set for autoloading via 'file-name-handler-alist'." 608 19, it must be set for autoloading via `file-name-handler-alist'."
538 (or (featurep 'ange-ftp) (featurep 'efs) 609 (or (featurep 'ange-ftp) (featurep 'efs)
539 (and (boundp 'file-name-handler-alist) ; v19 610 (and (boundp 'file-name-handler-alist) ; v19
540 (or (rassq 'ange-ftp-hook-function file-name-handler-alist) 611 (or (rassq 'ange-ftp-hook-function file-name-handler-alist)
541 (rassq 'efs-file-handler-function file-name-handler-alist)) 612 (rassq 'efs-file-handler-function file-name-handler-alist))
542 t))) 613 t)))
593 return-path)))) 664 return-path))))
594 665
595 (defun hpath:find-program (filename) 666 (defun hpath:find-program (filename)
596 "Return shell or Lisp command to execute to display FILENAME or nil. 667 "Return shell or Lisp command to execute to display FILENAME or nil.
597 Return nil if FILENAME is a directory name. 668 Return nil if FILENAME is a directory name.
598 See also documentation for 'hpath:find-alist' and 'hpath:display-alist'." 669 See also documentation for `hpath:find-alist' and `hpath:display-alist'."
599 (let ((cmd)) 670 (let ((cmd))
600 (cond ((and (stringp filename) (file-directory-p filename)) 671 (cond ((and (stringp filename) (file-directory-p filename))
601 nil) 672 nil)
602 ((stringp (setq cmd (hpath:match filename hpath:find-alist))) 673 ((stringp (setq cmd (hpath:match filename hpath:find-alist)))
603 (let ((orig-path filename)) 674 (let ((orig-path filename))
637 VAR-NAME's value may be a directory or a list of directories. If it is a 708 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 709 list, the first directory prepended to REST-OF-PATH which produces a valid
639 local pathname is returned." 710 local pathname is returned."
640 (let (sym val) 711 (let (sym val)
641 (cond ((not (stringp var-name)) 712 (cond ((not (stringp var-name))
642 (error "(hpath:substitute-dir): VAR-NAME arg, '%s', must be a string" var-name)) 713 (error "(hpath:substitute-dir): VAR-NAME arg, `%s', must be a string" var-name))
643 ((not (and (setq sym (intern-soft var-name)) 714 ((not (and (setq sym (intern-soft var-name))
644 (boundp sym))) 715 (boundp sym)))
645 (error "(hpath:substitute-dir): VAR-NAME arg, \"%s\", is not a bound variable" 716 (error "(hpath:substitute-dir): VAR-NAME arg, \"%s\", is not a bound variable"
646 var-name)) 717 var-name))
647 ((stringp (setq val (symbol-value sym))) 718 ((stringp (setq val (symbol-value sym)))