home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / lisp / ilisp / symlink.el < prev    next >
Encoding:
Text File  |  1992-06-29  |  5.5 KB  |  140 lines
  1. ;; symlink: Fix to remove symbolic links from file pathnames.
  2. ;; Copyright (C) 1989 Free Software Foundation, Inc.
  3.  
  4. ;; This file is not officially part of GNU Emacs, but is being donated
  5. ;; to the Free Software Foundation.
  6.  
  7. ;; GNU Emacs is distributed in the hope that it will be useful,
  8. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  9. ;; accepts responsibility to anyone for the consequences of using it
  10. ;; or for whether it serves any particular purpose or works at all,
  11. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  12. ;; License for full details.
  13.  
  14. ;; Everyone is granted permission to copy, modify and redistribute
  15. ;; GNU Emacs, but only under the conditions described in the
  16. ;; GNU Emacs General Public License.   A copy of this license is
  17. ;; supposed to have been given to you along with GNU Emacs so you
  18. ;; can know your rights and responsibilities.  It should be in a
  19. ;; file named COPYING.  Among other things, the copyright notice
  20. ;; and this notice must be preserved on all copies.
  21.  
  22. ;; Created by: Joe Wells, joew@uswest.com
  23. ;; Created on: summer 1988
  24. ;; Last modified by: Joe Wells, jbw@bucsf
  25. ;; Last modified on: Fri May 11 12:56:08 1990
  26. ;; Filename: symlink.el
  27.  
  28. ;; Modified by Chris McConnell and Todd Kaufmann for ilisp and CMU.
  29. (or (fboundp 'original-expand-file-name)
  30.     (fset 'original-expand-file-name
  31.       (symbol-function 'expand-file-name)))
  32.  
  33. ;;;
  34. (defvar expand-symlinks nil "*Set this to T to expand symbolic links.")
  35.  
  36. ;;;; Added by Todd.Kaufmann@cs.cmu.edu, 20-Jul-90:  for CMU RFS.
  37. ;;;
  38. ;;; Because of weird cmu rfs filesystem, the /../machine must be preserved in
  39. ;;; links, but toss it when a link goes to another machine or afs.
  40. (defvar expand-symlinks-rfs-exists nil
  41.   "T at cmu, nil otherwise.  This is to preserve machine name context like
  42. /../foo in the file names during expansion of symlinks.")
  43.  
  44. (defun expand-symlinks-rfs-machine-context (old-dir new-dir)
  45.   "If new-dir is afs or rfs to another machine, forget old-dir.
  46. Otherwise leave /../machine in the old-dir and return it, else the empty
  47. string."
  48.   (if (string-match "\\(/\\.\\.\\|/afs\\)" new-dir)    ; new: afs or rfs?
  49.       ""
  50.       (if (not (string-match "^/\\.\\./[^/]+/" (setq *ld old-dir))) ; old: rfs?
  51.       ""
  52.       (substring old-dir 0 (1- (match-end 0))))
  53.       ))
  54.   
  55. ;;; Concatenates LEFT and RIGHT, preserving at most one slash between them.
  56. ;;; This horrible hack is necessary to work around the fact that
  57. ;;; expand-file-name treats // specially.
  58. (defun join-file-name (left right)
  59.   (let* ((llen (length left))
  60.      (rlen (length right))
  61.      (lend llen)
  62.      (rstart 0)
  63.      slash-found)
  64.     (while (and (> lend 0)
  65.         (eq ?/ (aref left (1- lend))))
  66.       (setq slash-found t
  67.         lend (1- lend)))
  68.     (while (and (< rstart rlen)
  69.         (eq ?/ (aref right rstart)))
  70.       (setq slash-found t
  71.         rstart (1+ rstart)))
  72.     (concat (if (eq lend llen) left (substring left 0 lend))
  73.         (if slash-found "/" "")
  74.         (if (eq rstart 0) right (substring right rstart rlen)))))
  75.  
  76. ;;; Splits FILENAME into two strings, and returns a list of the two
  77. ;;; strings.  The first string will be the first filename component in
  78. ;;; FILENAME, plus any leading slashes, and the second string will be the
  79. ;;; rest of FILENAME, possibly a string of length 0.
  80. (defun split-file-name (file-name)
  81.   (if (string-match "\\`\\(/*[^/]+\\)\\(/.*\\)\\'" file-name)
  82.       (cons (substring file-name (match-beginning 1) (match-end 1))
  83.         (substring file-name (match-beginning 2) (match-end 2)))
  84.     (cons file-name "")))
  85.  
  86. ;;; Takes FILENAME and LINK and returns a string which substitutes LINK for
  87. ;;; the last component of FILENAME.
  88. (defun hack-local-link (file-name link)
  89.   (or (string-match "\\`\\(.*/\\)[^/]+\\'" file-name)
  90.       (error "hack-local-link bad argument: %s" file-name))
  91.   (concat (substring file-name (match-beginning 1) (match-end 1)) link))
  92.  
  93. ;;;
  94. (defun expand-file-name (file-name &optional directory)
  95.   "Convert FILENAME to absolute, and canonicalize it.
  96. Second arg DEFAULT is directory to start with if FILENAME is relative
  97. \(does not start with slash)        ; if DEFAULT is nil or missing,
  98. the current buffer's value of default-directory is used.
  99. Filenames containing . or .. as components are simplified ;
  100. initial ~ is expanded.  See also the function  substitute-in-file-name.
  101. This has been modified to resolve all symbolic links from FILENAME.
  102. The original function definition is stored on original-expand-file-name."
  103.   (let (left-slash left right split link)
  104.     (setq right (original-expand-file-name file-name directory))
  105.     (if expand-symlinks
  106.     (progn
  107.       (setq left-slash (string-match "//" right)
  108.         left-slash (and left-slash (zerop left-slash)))
  109.       (setq left "")
  110.       (while (not (equal right ""))
  111.         (setq split (split-file-name right))
  112.         (setq left (join-file-name left (car split)))
  113.         (if left-slash
  114.         (setq left (concat "/" left)
  115.               *l2 left
  116.               left-slash nil))
  117.         (setq right (cdr split))
  118.         (setq link (file-symlink-p left))
  119.         (if (null link)
  120.         nil
  121.         (if (eq 0 (length link)) (setq link "."))
  122.         (cond ((not (eq (aref link 0) ?/))
  123.                (setq split (split-file-name link))
  124.                (setq left (join-file-name (file-name-directory left)
  125.                           (car split)))
  126.                (setq right (join-file-name (cdr split) right)))
  127.               (t
  128.                (setq right (join-file-name link right))
  129.                ;; mod by tk, 20-Jul-90 for cmu csd w/rfs.
  130.                ;; maybe keep rfs part of file name?
  131.                (if expand-symlinks-rfs-exists
  132.                (setq left (expand-symlinks-rfs-machine-context
  133.                        left right))
  134.                (setq left "")
  135.                )))))
  136.       left)
  137.         right)))
  138.  
  139. (provide 'symlink)
  140.