Mercurial > hg > xemacs-beta
diff lisp/hyperbole/hpath.el @ 70:131b0175ea99 r20-0b30
Import from CVS: tag r20-0b30
author | cvs |
---|---|
date | Mon, 13 Aug 2007 09:02:59 +0200 |
parents | 1a767b41a199 |
children | 4be1180a9e89 |
line wrap: on
line diff
--- a/lisp/hyperbole/hpath.el Mon Aug 13 09:00:04 2007 +0200 +++ b/lisp/hyperbole/hpath.el Mon Aug 13 09:02:59 2007 +0200 @@ -6,10 +6,19 @@ ;; KEYWORDS: comm, hypermedia, unix ;; ;; AUTHOR: Bob Weiner -;; ORG: InfoDock Associates +;; ORG: Brown U. ;; ;; ORIG-DATE: 1-Nov-91 at 00:44:23 -;; LAST-MOD: 20-Mar-97 at 11:52:51 by Bob Weiner +;; LAST-MOD: 10-Oct-95 at 23:31:56 by Bob Weiner +;; +;; This file is part of Hyperbole. +;; Available for use and distribution under the same terms as GNU Emacs. +;; +;; Copyright (C) 1991-1995, Free Software Foundation, Inc. +;; Developed with support from Motorola Inc. +;; +;; DESCRIPTION: +;; DESCRIP-END. ;;; ************************************************************************ ;;; Public variables @@ -17,7 +26,7 @@ (defvar hpath:rfc "/anonymous@ds.internic.net:rfc/rfc%s.txt" "*String to be used in the call: (hpath:rfc rfc-num) -to create an path to the RFC document for `rfc-num'.") +to create an path to the RFC document for 'rfc-num'.") (defvar hpath:suffixes '(".gz" ".Z") "*List of filename suffixes to add or remove within (hpath:exists-p) calls.") @@ -30,7 +39,7 @@ ;;; ************************************************************************ (defun hpath:absolute-to (path &optional default-dirs) - "Returns PATH as an absolute path relative to one directory from optional DEFAULT-DIRS or `default-directory'. + "Returns PATH as an absolute path relative to one directory from optional DEFAULT-DIRS or 'default-directory'. Returns PATH unchanged when it is not a valid path or when DEFAULT-DIRS is invalid. DEFAULT-DIRS when non-nil may be a single directory or a list of directories. The first one in which PATH is found is used." @@ -54,7 +63,7 @@ (defun hpath:ange-ftp-at-p () "Returns an ange-ftp pathname that point is within or nil. -See the `ange-ftp' or `efs' Elisp packages for pathname format details. +See the 'ange-ftp' or 'efs' Elisp packages for pathname format details. Always returns nil if (hpath:ange-ftp-available-p) returns nil." (if (hpath:ange-ftp-available-p) (let ((user (hpath:ange-ftp-default-user)) @@ -65,23 +74,23 @@ (cond ((hpath:url-at-p) (if (string-equal - (buffer-substring (match-beginning 2) (match-end 2)) + (buffer-substring (match-beginning 1) (match-end 1)) "ftp") (concat "/" ;; user - (if (match-beginning 3) + (if (match-beginning 2) (buffer-substring - (match-beginning 3) (match-end 3)) + (match-beginning 2) (match-end 2)) (concat user "@")) ;; domain (hpath:delete-trailer - (buffer-substring (match-beginning 4) (match-end 4))) + (buffer-substring (match-beginning 3) (match-end 3))) ":" ;; path - (if (match-beginning 6) - (buffer-substring (match-beginning 6) - (match-end 6)))) + (if (match-beginning 5) + (buffer-substring (match-beginning 5) + (match-end 5)))) ;; else ignore this other type of WWW path )) ;; user, domain and path @@ -111,7 +120,7 @@ (defun hpath:ange-ftp-p (path) "Returns non-nil iff PATH is an ange-ftp pathname. -See the `ange-ftp' or `efs' Elisp package for pathname format details. +See the 'ange-ftp' or 'efs' Elisp package for pathname format details. Always returns nil if (hpath:ange-ftp-available-p) returns nil." (and (stringp path) (or (featurep 'ange-ftp) (featurep 'efs)) @@ -121,22 +130,22 @@ (cond ((hpath:url-p path) (if (string-equal - (substring path (match-beginning 2) (match-end 2)) + (substring path (match-beginning 1) (match-end 1)) "ftp") (concat "/" ;; user - (if (match-beginning 3) - (substring path (match-beginning 3) (match-end 3)) + (if (match-beginning 2) + (substring path (match-beginning 2) (match-end 2)) (concat user "@")) ;; domain (hpath:delete-trailer - (substring path (match-beginning 4) (match-end 4))) + (substring path (match-beginning 3) (match-end 3))) ":" ;; path - (if (match-beginning 6) - (substring path (match-beginning 6) - (match-end 6)))) + (if (match-beginning 5) + (substring path (match-beginning 5) + (match-end 5)))) ;; else ignore this other type of WWW path )) ;; user, domain and path @@ -177,8 +186,8 @@ If optional TYPE is the symbol 'file or 'directory, then only that path type is accepted as a match. Only locally reachable paths are checked for existence. With optional NON-EXIST, nonexistent local paths are allowed. -Absolute pathnames must begin with a `/' or `~'. Relative pathnames -must begin with a `./' or `../' to be recognized." +Absolute pathnames must begin with a '/' or '~'. Relative pathnames +must begin with a './' or '../' to be recognized." (cond (;; Local file URLs (hpath:is-p (hargs:delimited "file://localhost" "[ \t\n\^M\"\'\}]" nil t))) @@ -191,40 +200,10 @@ (hargs:delimited "@file{" "}")) type non-exist)))) -(defun hpath:display-buffer (buffer &optional display-where) - "Displays BUFFER at optional DISPLAY-WHERE location or at hpath:display-where. -BUFFER may be a buffer or a buffer name. - -See documentation of `hpath:display-buffer-alist' for valid values of DISPLAY-WHERE. -Returns non-nil iff buffer is actually displayed." - (interactive "bDisplay buffer: ") - (if (stringp buffer) (setq buffer (get-buffer buffer))) - (if (null buffer) - nil - (if (null display-where) - (setq display-where hpath:display-where)) - (funcall (car (cdr (or (assq display-where - hpath:display-buffer-alist) - (assq 'other-window - hpath:display-buffer-alist)))) - buffer) - t)) - -(defun hpath:display-buffer-other-frame (buffer) - "Displays BUFFER, in another frame. -May create a new frame, or reuse an existing one. -See documentation of `hpath:display-buffer' for details. -Returns the dispalyed buffer." - (interactive "bDisplay buffer in other frame: ") - (if (= (length (frame-list)) 1) - (select-frame (make-frame)) - (other-frame 1)) - (if (br-in-browser) - (br-to-view-window)) - (switch-to-buffer buffer)) - -(defun hpath:find (filename &optional display-where) - "Edits file FILENAME using user customizable settings of display program and location. +(defun hpath:find (filename &optional other-window-p) + "Edit file FILENAME using program from hpath:find-alist if available. +Otherwise, switch to a buffer visiting file FILENAME, creating one if none +already exists. FILENAME may start with a special prefix character which is handled as follows: @@ -232,14 +211,7 @@ &filename - execute as a windowed program; -filename - load as an Emacs Lisp program. -Otherwise, if FILENAME matches a regular expression in the variable -`hpath:find-alist,' the associated external display program is invoked. -If not, `hpath:display-alist' is consulted for a specialized internal -display function to use. If no matches are found there, -`hpath:display-where-alist' is consulted using the optional argument, -DISPLAY-WHERE (a symbol) or if that is nil, the value of -`hpath:display-where', and the matching display function is used. -Returns non-nil iff file is displayed within a buffer (not with an external +Return non-nil iff file is displayed within a buffer (not with an external program)." (interactive "FFind file: ") (let (modifier) @@ -260,62 +232,25 @@ nil) ((hypb:functionp find-program) (funcall find-program filename) - t) + nil) (t (setq filename (hpath:validate filename)) - (if (null display-where) - (setq display-where hpath:display-where)) - (funcall (car (cdr (or (assq display-where - hpath:display-where-alist) - (assq 'other-window - hpath:display-where-alist)))) - filename) + (funcall (if (and other-window-p + (not (br-in-browser))) + 'switch-to-buffer-other-window + 'switch-to-buffer) + (find-file-noselect filename)) t))))))) -(defun hpath:find-line (filename line-num &optional display-where) - "Edits file FILENAME with point placed at LINE-NUM. +(defun hpath:find-other-window (filename) + "Edit file FILENAME, in another window or using program from hpath:find-alist. +May create a new window, or reuse an existing one; see the function display-buffer. -`hpath:display-where-alist' is consulted using the optional argument, -DISPLAY-WHERE (a symbol) or if that is nil, the value of -`hpath:display-where', and the matching display function is used to determine -where to display the file, e.g. in another frame. -Always returns t." - (interactive "FFind file: ") - ;; Just delete any special characters preceding the filename, ignoring them. - (if (string-match hpath:prefix-regexp filename) - (setq filename (substring filename (match-end 0)))) - (setq filename (hpath:substitute-value filename) - filename (hpath:validate filename)) - (if (null display-where) - (setq display-where hpath:display-where)) - (funcall (car (cdr (or (assq display-where - hpath:display-where-alist) - (assq 'other-window - hpath:display-where-alist)))) - filename) - (if (integerp line-num) - (progn (widen) (goto-line line-num))) - t) +Alternatively, FILENAME may start with a prefix character to indicate special +handling. See documentation of `hpath:find' for details. -(defun hpath:find-other-frame (filename) - "Edits file FILENAME, in another frame. -May create a new frame, or reuse an existing one. -See documentation of `hpath:find' for details. -Returns the buffer of displayed file." - (interactive "FFind file in other frame: ") - (if (= (length (frame-list)) 1) - (select-frame (make-frame)) - (other-frame 1)) - (if (br-in-browser) - (br-to-view-window)) - (find-file filename)) - -(defun hpath:find-other-window (filename) - "Edits file FILENAME, in another window or using an external program. -May create a new window, or reuse an existing one; see the function display-buffer. -See documentation of `hpath:find' for details. -Returns non-nil iff file is displayed within a buffer." +Return non-nil iff file is displayed within a buffer." (interactive "FFind file in other window: ") - (hpath:find filename 'other-window)) + (hpath:find filename t)) (defun hpath:is-p (path &optional type non-exist) "Returns PATH if PATH is a Unix path, else nil. @@ -340,7 +275,7 @@ (if (string-match hpath:prefix-regexp path) (setq path (substring path (match-end 0))) t) - (not (or (string-equal path "") + (not (or (string= path "") (string-match "\\`\\s \\|\\s \\'" path))) ;; Convert tabs and newlines to space. (setq path (hbut:key-to-label (hbut:label-to-key path))) @@ -375,23 +310,19 @@ (file-directory-p path)) (t))) ) - (progn - ;; Quote any but last %s within rtn-path. - (setq rtn-path (hypb:replace-match-string "%s" rtn-path "%%s") - rtn-path (hypb:replace-match-string "%%s\\'" rtn-path "%s")) - ;; Return path if non-nil return value. - (if (stringp suffix);; suffix could = t, which we ignore - (if (string-match - (concat (regexp-quote suffix) "%s") rtn-path) - ;; remove suffix - (concat (substring rtn-path 0 (match-beginning 0)) - (substring rtn-path (match-end 0))) - ;; add suffix - (format rtn-path suffix)) - (format rtn-path "")))))))) + ;; Return path if non-nil return value + (if (stringp suffix) ;; suffix could = t, which we ignore + (if (string-match + (concat (regexp-quote suffix) "%s") rtn-path) + ;; remove suffix + (concat (substring rtn-path 0 (match-beginning 0)) + (substring rtn-path (match-end 0))) + ;; add suffix + (format rtn-path suffix)) + (format rtn-path ""))))))) (defun hpath:relative-to (path &optional default-dir) - "Returns PATH relative to optional DEFAULT-DIR or `default-directory'. + "Returns PATH relative to optional DEFAULT-DIR or 'default-directory'. Returns PATH unchanged when it is not a valid path." (if (not (and (stringp path) (hpath:is-p path))) path @@ -418,7 +349,7 @@ (defun hpath:rfc (rfc-num) "Return pathname to textual rfc document indexed by RFC-NUM. -See the documentation of the `hpath:rfc' variable." +See the documentation of the 'hpath:rfc' variable." (format hpath:rfc rfc-num)) (defun hpath:substitute-value (path) @@ -443,7 +374,7 @@ t))) (defun hpath:substitute-var (path) - "Replaces up to one match in PATH with first matching variable from `hpath:variables'." + "Replaces up to one match in PATH with first matching variable from 'hpath:variables'." (if (not (and (stringp path) (string-match "/" path) (hpath:is-p path))) path (setq path (hpath:symlink-referent path)) @@ -465,7 +396,7 @@ (hpath:substitute-var-name var (car val) path)) (setq new-path result)) (setq val (cdr val)))) - (t (error "(hpath:substitute-var): `%s' has invalid value for hpath:variables" var)))))) + (t (error "(hpath:substitute-var): '%s' has invalid value for hpath:variables" var)))))) (or new-path path) ))) @@ -476,9 +407,9 @@ ;; /usr/local -> $(SERVER_LOCAL)/usr/local, /usr/bin -> ;; ../$(SYSTYPE)/usr/bin and /tmp -> `node_data/tmp. It also handles ;; relative links properly as in /usr/local/emacs -> gnu/emacs which must -;; be resolved relative to the `/usr/local' directory. -;; It will fail on Apollos if the `../' notation is used to move just -;; above the `/' directory level. This is fairly uncommon and so the +;; be resolved relative to the '/usr/local' directory. +;; It will fail on Apollos if the '../' notation is used to move just +;; above the '/' directory level. This is fairly uncommon and so the ;; problem has not been fixed. ;; (defun hpath:symlink-referent (linkname) @@ -547,37 +478,35 @@ "Return world-wide-web universal resource locator (url) that point immediately precedes or nil. Use buffer-substring with match-beginning and match-end on the following groupings: - 1 = optional `URL:' literal - 2 = access protocol - 4 = optional username - 4 = host and domain to connect to - 5 = optional port number to use - 6 = optional pathname to access." - ;; WWW URL format: [URL:]<protocol>:/[<user>@]<domain>[:<port>][/<path>] - ;; or [URL:]<protocol>://[<user>@]<domain>[:<port>][<path>] + 1 = access protocol + 2 = optional username + 3 = host and domain to connect to + 4 = optional port number to use + 5 = pathname to access." + ;; WWW URL format: <protocol>:/[<user>@]<domain>[:<port>]/<path> + ;; or <protocol>://[<user>@]<domain>[:<port>]<path> ;; Avoid [a-z]:/path patterns since these may be disk paths on OS/2, DOS or ;; Windows. - (if (looking-at "\\(URL:\\)?\\([a-zA-Z][a-zA-Z]+\\)://?\\([^@/: \t\n\^M]+@\\)?\\([^/:@ \t\n\^M\"`']+\\)\\(:[0-9]+\\)?\\([/~][^]@ \t\n\^M\"`'\)\}>]*\\)?") + (if (looking-at "\\([a-zA-Z][a-zA-Z]+\\)://?\\([^@/: \t\n\^M]+@\\)?\\([^/:@ \t\n\^M\"`']+\\)\\(:[0-9]+\\)?\\([/~][^]@ \t\n\^M\"`'\)\}>]*\\)?") (save-excursion (goto-char (match-end 0)) - (skip-chars-backward ".,?#!*()") - (buffer-substring (match-beginning 2) (point))))) + (skip-chars-backward ".?#!*()") + (buffer-substring (match-beginning 0) (point))))) (defun hpath:url-p (obj) "Return t if OBJ is a world-wide-web universal resource locator (url) string, else nil. Use string-match with match-beginning and match-end on the following groupings: - 1 = optional `URL:' literal - 2 = access protocol - 3 = optional username - 4 = host and domain to connect to - 5 = optional port number to use - 6 = optional pathname to access." - ;; WWW URL format: [URL:]<protocol>:/[<user>@]<domain>[:<port>][/<path>] - ;; or [URL:]<protocol>://[<user>@]<domain>[:<port>][<path>] + 1 = access protocol + 2 = optional username + 3 = host and domain to connect to + 4 = optional port number to use + 5 = pathname to access." + ;; WWW URL format: <protocol>:/[<user>@]<domain>[:<port>]/<path> + ;; or <protocol>://[<user>@]<domain>[:<port>]<path> ;; Avoid [a-z]:/path patterns since these may be disk paths on OS/2, DOS or ;; Windows. (and (stringp obj) - (string-match "\\`<?\\(URL:\\)?\\([a-zA-Z][a-zA-Z]+\\)://?\\([^@/: \t\n\^M]+@\\)?\\([^/:@ \t\n\^M\"`']+\\)\\(:[0-9]+\\)?\\([/~][^]@ \t\n\^M\"`'\)\}>]*\\)?>?\\'" + (string-match "\\`<?\\([a-zA-Z][a-zA-Z]+\\)://?\\([^@/: \t\n\^M]+@\\)?\\([^/:@ \t\n\^M\"`']+\\)\\(:[0-9]+\\)?\\([/~][^]@ \t\n\^M\"`'\)\}>]*\\)?>?\\'" obj) t)) @@ -590,8 +519,8 @@ (cond ((not include-start-and-end-p) (hpath:url-at-p)) ((hpath:url-at-p) - (list (buffer-substring (match-beginning 2) (match-end 0)) - (match-beginning 2) + (list (buffer-substring (match-beginning 0) (match-end 0)) + (match-beginning 0) (match-end 0)))))) (defun hpath:www-p (path) @@ -605,7 +534,7 @@ (defun hpath:ange-ftp-available-p () "Return t if the ange-ftp or efs package is available, nil otherwise. Either the package must have been loaded already or under versions of Emacs -19, it must be set for autoloading via `file-name-handler-alist'." +19, it must be set for autoloading via 'file-name-handler-alist'." (or (featurep 'ange-ftp) (featurep 'efs) (and (boundp 'file-name-handler-alist) ; v19 (or (rassq 'ange-ftp-hook-function file-name-handler-alist) @@ -666,7 +595,7 @@ (defun hpath:find-program (filename) "Return shell or Lisp command to execute to display FILENAME or nil. Return nil if FILENAME is a directory name. -See also documentation for `hpath:find-alist' and `hpath:display-alist'." +See also documentation for 'hpath:find-alist' and 'hpath:display-alist'." (let ((cmd)) (cond ((and (stringp filename) (file-directory-p filename)) nil) @@ -710,7 +639,7 @@ local pathname is returned." (let (sym val) (cond ((not (stringp var-name)) - (error "(hpath:substitute-dir): VAR-NAME arg, `%s', must be a string" var-name)) + (error "(hpath:substitute-dir): VAR-NAME arg, '%s', must be a string" var-name)) ((not (and (setq sym (intern-soft var-name)) (boundp sym))) (error "(hpath:substitute-dir): VAR-NAME arg, \"%s\", is not a bound variable"