Mercurial > hg > xemacs-beta

comparison lisp/hyperbole/hpath.el @ 70:131b0175ea99 r20-0b30

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