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