home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / packages / symlink-fix.el < prev    next >
Encoding:
Text File  |  1993-03-03  |  18.3 KB  |  452 lines
  1. ;; symlink-fix: Remove symbolic links from file pathnames.
  2. ;; Copyright (C) 1989, 1990, 1991, 1993 Free Software Foundation, Inc.
  3.  
  4. ;; This file is not officially part of GNU Emacs.
  5.  
  6. ;; This file is distributed in the hope that it will be useful, but
  7. ;; WITHOUT ANY WARRANTY.  No author or distributor accepts responsibility
  8. ;; to anyone for the consequences of using it or for whether it serves any
  9. ;; particular purpose or works at all, unless he says so in writing.
  10. ;; Refer to the GNU Emacs General Public License for full details.
  11.  
  12. ;; Everyone is granted permission to copy, modify and redistribute this
  13. ;; file, but only under the conditions described in the GNU Emacs General
  14. ;; Public License.  A copy of this license is supposed to have been given
  15. ;; to you along with GNU Emacs so you can know your rights and
  16. ;; responsibilities.  It should be in a file named COPYING.  Among other
  17. ;; things, the copyright notice and this notice must be preserved on all
  18. ;; copies.
  19.  
  20. ;; Created by: Joe Wells, joew@uswest.com
  21. ;; Created on: summer 1988
  22. ;; Last modified by: Joe Wells, jbw@csd
  23. ;; Last modified on: Tue Feb 23 23:05:51 1993
  24. ;; Filename: symlink-fix.el
  25. ;; Purpose: remove symbolic links from pathnames
  26. ;; Change log: 
  27. ;; 
  28. ;; Tue Feb 23 21:31:57 1993  Joe Wells  (jbw at csd)
  29. ;; 
  30. ;;     * Made overloading more sophisticated.  Avoid possible recursion
  31. ;;     resulting from Emacs Lisp primitives being redefined to call
  32. ;;     expand-file-name.  (Ange-FTP changes file-symlink-p to call
  33. ;;     expand-file-name.)  Allow changing the order of overloading to put
  34. ;;     this package's function on top of the overloading stack.  Allow
  35. ;;     prevention of symlink-expansion (even calling file-symlink-p) on
  36. ;;     certain pathnames.  (It can be very slow to call file-symlink-p on
  37. ;;     a remote file accessed through Ange-FTP.)  Allow dynamically
  38. ;;     toggling symlink resolution by expand-file-name.  Save and restore
  39. ;;      match data.
  40. ;; 
  41. ;; Fri Aug 23 12:54:22 1991  Joe Wells  (jbw at teton)
  42. ;; 
  43. ;;     * Fixed some bugs with the symlink-mapping-alist.
  44. ;; 
  45. ;; Thu Aug 22 14:58:33 1991  Joe Wells  (jbw at teton)
  46. ;; 
  47. ;;     * Added documentation.
  48. ;; 
  49.  
  50. ;; LCD Archive Entry:
  51. ;; symlink-fix|Joe Wells|jbw@cs.bu.edu|
  52. ;; Remove symbolic links from file pathnames|
  53. ;; 1993-02-23||~/packages/symlink-fix.el.Z|
  54.  
  55.  
  56. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  57. ;;;
  58. ;;; Documentation (what little there is).
  59. ;;;
  60.  
  61. ;; Features:
  62.  
  63. ;; 1. Makes Emacs use the real path, which prevents accidentally visiting
  64. ;; the same file twice by different paths.  This problem could happen when
  65. ;; Emacs used the output of a program that had called getwd, and also in
  66. ;; other similar circumstances.
  67.  
  68. ;; Known problems:
  69.  
  70. ;; 1. expand-file-name (if overloaded and symlink resolution is turned on)
  71. ;; saves and restores the match data.  In old versions of Emacs, the
  72. ;; routines for saving and restoring the match data were buggy.  The
  73. ;; solution is to upgrade to a modern version of Emacs.
  74.  
  75. ;; 2. symlink-expand-file-name does too much string creation.  This should
  76. ;; be fixed by having it use a scratch buffer instead.
  77.  
  78. ;; 3. expand-file-name (if overloaded and symlink resolution is turned on)
  79. ;; doesn't work really well with the automounter.  In essence, you have to
  80. ;; selectively disable part of its functionality to prevent the
  81. ;; automounter from unmounting file systems from under you.  What would be
  82. ;; really great is if some enterprising individual would write a routine
  83. ;; that restores automounter symbolic links back into pathnames.
  84.  
  85. ;; 4. expand-file-name (if overloaded and symlink resolution is turned on)
  86. ;; doesn't resolve symlinks if the overloading occurred before ange-ftp
  87. ;; was loaded unless you modify ange-ftp-expand-file-name to not be clever
  88. ;; and always call ange-ftp-real-expand-file-name.  Overloading after
  89. ;; ange-ftp is loaded works correctly.  You can either load this file
  90. ;; after Ange-FTP or set ange-ftp-load-hook (Nonexistent yet!  Arggh!) to
  91. ;; call the function symlink-overload-expand-file-name.
  92.  
  93. ;; 5. You may not like having symlinks removed from remote file names
  94. ;; because it can be slow, so in that case you should set the variable
  95. ;; symlink-dont-resolve-symlinks-regexp to match Ange-FTP remote filenames
  96. ;; like this:
  97. ;;
  98. ;;   (setq symlink-no-resolve-symlinks-regexp (car ange-ftp-path-format))
  99. ;;
  100.  
  101. ;; Sample configuration:
  102.  
  103. ;; This sample configuration uses all of the configuration variables.  You
  104. ;; probably don't want all of these configurations, and some of it would
  105. ;; have to be adjusted for your site anyway.
  106.  
  107. ;; (setq symlink-overload-expand-file-name-p t)
  108. ;; (require 'symlink-fix)
  109. ;; (setq expand-file-name-resolve-symlinks-p t)
  110. ;; (setq symlink-mapping-alist '(("\\`/nfs/" . nil)))
  111. ;; *** This won't work yet because there is no ange-ftp-load-hook!  Arrgh! ***
  112. ;; (defun symlink-ange-ftp-hook-function ()
  113. ;;   (symlink-overload-expand-file-name)
  114. ;;   (setq symlink-no-resolve-symlinks-regexp
  115. ;;     (car ange-ftp-path-format)))
  116. ;; (if (featurep 'ange-ftp)
  117. ;;     (symlink-ange-ftp-hook-function)
  118. ;;   (setq ange-ftp-load-hook
  119. ;;     (cons symlink-ange-ftp-hook-function ange-ftp-load-hook)))
  120.  
  121.  
  122. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  123. ;;;
  124. ;;; Configuration variables.
  125. ;;;
  126.  
  127. (defvar symlink-overload-expand-file-name-p nil
  128.  
  129.   "*Whether expand-file-name is overloaded at load time of symlink-fix.el.
  130.  
  131. This determines whether the function symlink-overload-expand-file-name is
  132. called at load time.  (This is actually a simplification, as the actual
  133. behavior is more sophisticated.)  This does not necessarily change the
  134. behavior of expand-file-name, since symlinks will not be resolved by the
  135. overloading function unless the variable
  136. expand-file-name-resolve-symlinks-p is non-nil.
  137.  
  138. The function symlink-expand-file-name always calls the function value that
  139. expand-file-name had at the last time the function
  140. symlink-overload-expand-file-name was called.  (This is another
  141. simplification, as the actual overloading behavior is more sophisticated.)
  142. This should work with other packages that overload expand-file-name,
  143. unless they do not always call the function they overload, in which case
  144. you can overload expand-file-name after the other packages do by calling
  145. symlink-overload-expand-file-name again.
  146.  
  147. Setting this variable after symlink-fix.el is loaded has no effect.")
  148.  
  149. (defvar expand-file-name-resolve-symlinks-p t
  150.   "*Whether expand-file-name will resolve symbolic links after it has been
  151. overloaded by symlink-overload-expand-file-name.  Set to nil to get the
  152. default behavior of expand-file-name.")
  153.  
  154. (defvar symlink-mapping-alist nil
  155.   "*Used to hide certain directories during symlink elimination.
  156.  
  157. Should be an alist where each element is of the form \(REGEXP .
  158. REPLACEMENT\).  When an absolute symbolic link points to a path matched by
  159. REGEXP, the portion of the path that matches either the entire REGEXP is
  160. replaced by REPLACEMENT \(as described for replace-match\).  If REPLACEMENT
  161. is nil, then the original symbolic link is used rather than the path it
  162. points to.  This is only applied when the symbolic link points to an
  163. absolute path.
  164.  
  165. As an example, if /tmp_mnt is an automounter directory, you might want to
  166. make symlink-mapping-alist have this value:
  167.  
  168.   ((\"\\\\`/tmp_mnt/\" . nil))
  169.  
  170. Another example is if /u is a directory containing symbolic links to each
  171. person's real home directory, which are located in /home/machine/username,
  172. and it is desired that this be hidden.  Then symlink-mapping-alist can be
  173. given this value:
  174.  
  175.   ((\"\\\\`/home/[-a-z0-9]+/[a-z]+\\\\'\" . nil))
  176.  
  177. Note that doing this defeats one of the main points of using
  178. symlink-expand-file-name, which is to have Emacs use the same pathname
  179. that is reported by getwd \(which is used by many other programs whose
  180. output Emacs uses to find files\).
  181.  
  182. Also note that any transformation specified should yield the same file
  183. pointed to by the original symbolic link or an equivalent one.  Otherwise
  184. all bets are off.")
  185.  
  186. (defvar symlink-no-resolve-symlinks-regexp nil
  187.   "*A regular expression for symbolic links that will not be resolved.
  188.  
  189. If the absolute pathname of a symbolic link \(possibly including some .
  190. and .. elements if it is pointed to by another symbolic link\) matches
  191. this regular expression, then the symbolic link's value will not be
  192. substituted into the pathname by the function symlink-expand-file-name
  193. \(and expand-file-name if overloaded and symlink resolution is turned
  194. on\).")
  195.  
  196.  
  197. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  198. ;;;
  199. ;;; The symbolic link resolution routines.
  200. ;;;
  201.  
  202. (defun symlink-expand-file-name (file-name &optional directory)
  203.   "Convert FILENAME to absolute, and canonicalize it.
  204. Second arg DIRECTORY is directory to start with if FILENAME is relative
  205. \(does not start with slash); if DIRECTORY is nil or missing,
  206. the current buffer's value of default-directory is used.
  207. Filenames containing . or .. as components are simplified;
  208. initial ~ is expanded.  See also the function  substitute-in-file-name.
  209.  
  210. All symbolic links are resolved from FILENAME, with exceptions specified
  211. by symlink-mapping-alist and symlink-no-resolve-symlinks-regexp."
  212.  
  213.   (let ((match-data (match-data))
  214.     left right split link new)
  215.     
  216.     ;; Call the original expand-file-name.  This is an essential part of
  217.     ;; any overloading protocol, that you avoid short-circuiting things in
  218.     ;; case some other package is overloading the same function.
  219.     (setq right (symlink-original-expand-file-name file-name directory))
  220.     (setq left "")
  221.     
  222.     ;; Resolve symbolic links to return a canonical path.
  223.     (while (not (equal right ""))
  224.       (setq split (symlink-split-file-name right))
  225.       (setq left (symlink-join-file-name left (car split)))
  226.       (setq right (cdr split))
  227.       
  228.       ;; Allow users to specify that they don't want to resolve symbolic
  229.       ;; links in filenames matching a particular pattern.  The usual
  230.       ;; reason for this will be that the operation is too expensive, for
  231.       ;; example with remote FTP filenames.
  232.       ;; Otherwise find a symbolic link if any.
  233.       (setq link
  234.         (if (and symlink-no-resolve-symlinks-regexp
  235.              (string-match symlink-no-resolve-symlinks-regexp left))
  236.         nil
  237.           (file-symlink-p left)))
  238.  
  239.       (if (null link)
  240.       nil
  241.  
  242.     ;; We found a symbolic link, handle it.
  243.     (if (eq 0 (length link)) (setq link "."))
  244.     (if (not (eq (aref link 0) ?/))
  245.  
  246.         ;; Handle a relative symbolic link.
  247.         (setq split (symlink-split-file-name link)
  248.           left (symlink-join-file-name (file-name-directory left)
  249.                            (car split))
  250.           right (symlink-join-file-name (cdr split) right))
  251.       
  252.       ;; Handle an absolute symbolic link.
  253.       ;; Check for symlink hiding.
  254.       (setq new (symlink-assoc-string-match link symlink-mapping-alist))
  255.       (if new
  256.  
  257.           ;; The symbolic link is hidden from resolution or has an
  258.           ;; alternate resolution specified.
  259.           (if (cdr new)
  260.  
  261.           ;; An alternate resolution for the symbolic link is
  262.           ;; specified.
  263.           ;; *** TODO: Check that this alternate resolution still
  264.           ;; *** points to the same file!
  265.           (setq left (symlink-replace-regexp-string
  266.                   link (car new) (cdr new))))
  267.         
  268.         ;; The symbolic link is not hidden from resolution.
  269.         ;; We have an absolute path now so we're starting over.
  270.         (setq right (symlink-join-file-name link right))
  271.         (setq left "")))))
  272.  
  273.     ;; *** I'm not quite sure why I'm doing this.  I think this is to
  274.     ;; *** handle relative symbolic links with ".." or "." in them.
  275.     (setq left (symlink-original-expand-file-name left))
  276.     
  277.     ;; Restore the prior regexp match data since we trashed it.
  278.     ;; expand-file-name doesn't trash the match data, so we can't either.
  279.     (store-match-data match-data)
  280.     
  281.     ;; Return something that is EQ to the input argument if the result is
  282.     ;; the same as the input.  expand-file-name behaves this way, so we
  283.     ;; have to do this too.
  284.     (if (string-equal left file-name)
  285.     file-name
  286.       left)))
  287.  
  288. (defun symlink-join-file-name (left right)
  289.   "Concatenates LEFT and RIGHT, preserving at most one slash between them.
  290. This horrible hack is necessary to work around the fact that
  291. expand-file-name treats // specially."
  292.   (let* ((llen (length left))
  293.      (rlen (length right))
  294.      (lend llen)
  295.      (rstart 0)
  296.      slash-found)
  297.     (while (and (> lend 0)
  298.         (eq ?/ (aref left (1- lend))))
  299.       (setq slash-found t
  300.         lend (1- lend)))
  301.     (while (and (< rstart rlen)
  302.         (eq ?/ (aref right rstart)))
  303.       (setq slash-found t
  304.         rstart (1+ rstart)))
  305.     (concat (if (eq lend llen) left (substring left 0 lend))
  306.         (if slash-found "/" "")
  307.         (if (eq rstart 0) right (substring right rstart rlen)))))
  308.  
  309. (defun symlink-split-file-name (file-name)
  310.   "Splits FILENAME into two strings, and returns a list of the two
  311. strings.  The first string will be the first filename component in
  312. FILENAME, plus any leading slashes, and the second string will be the
  313. rest of FILENAME, possibly a string of length 0."
  314.   (if (string-match "\\`\\(/*[^/]+\\)\\(/.*\\)\\'" file-name)
  315.       (cons (substring file-name (match-beginning 1) (match-end 1))
  316.         (substring file-name (match-beginning 2) (match-end 2)))
  317.     (cons file-name "")))
  318.  
  319. (defun symlink-assoc-string-match (string alist)
  320.   "Like CL (assoc STRING ALIST :test #'(lambda (x y) (string-match y x))).
  321. If a match is made, then the match data is from the successful match,
  322. otherwise it is clobbered."
  323.   ;; TODO: use a real save-match-data
  324.   (let (item)
  325.     (catch 'found
  326.       (while (consp alist)
  327.     (setq item (car alist))
  328.     (and (consp item)
  329.          (string-match (car item) string)
  330.          (throw 'found item))
  331.     (setq alist (cdr alist))))))
  332.  
  333. ;; A function which is not in standard GNU Emacs Lisp but should be.
  334. ;; TODO: give it arguments like replace-regexp, not replace-match
  335. (defun symlink-replace-regexp-string (string regexp to-string
  336.                          &optional fixedcase literal)
  337.   "Replace matches in STRING for REGEXP by TO-STRING.
  338. If fourth arg FIXEDCASE is non-nil, do not alter case of replacement text.
  339. Otherwise convert to all caps or cap initials, like replaced text.
  340. If fifth arg LITERAL is non-nil, use TO-STRING literally.
  341. Otherwise treat \ as special:
  342.   \& in TO-STRING means substitute original matched text,
  343.   \N means substitute match for \(...\) number N,
  344.   \\ means insert one \."
  345.   (save-excursion
  346.     (set-buffer (get-buffer-create " *replace-regexp-string*"))
  347.     (erase-buffer)
  348.     (buffer-flush-undo (current-buffer))
  349.     (insert string)
  350.     (goto-char (point-min))
  351.     (while (re-search-forward regexp nil t)
  352.       (replace-match to-string fixedcase literal))
  353.     (buffer-string)))
  354.  
  355.  
  356. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  357. ;;;
  358. ;;; Overloading routines and bookkeeping variables.
  359. ;;;
  360.  
  361. ;;
  362. ;; Arrange for overloading of expand-file-name if necessary.  Arrange for
  363. ;; things to work if expand-file-name is not overloaded.
  364. ;; 
  365.  
  366. (defvar symlink-intermediary-overloading-symbol nil
  367.   "Don't touch this!  The value of this variable is an uninterned symbol
  368. whose purpose for existence is to allow the overloading of
  369. expand-file-name by this package to be safely removed from the overloading
  370. stack even though other packages might have overloaded expand-file-name
  371. after this.  The function value of the uninterned symbol is the
  372. overloading function of this package.")
  373.  
  374. (defvar symlink-intermediary-overloading-symbol-counter 0
  375.   "Don't touch this!  This variable is used to form unique names for the
  376. uninterned symbols that are the values of the variable
  377. symlink-intermediary-overloading-symbol.  Since all uninterned symbols are
  378. different even if they are given the same name, the only reason this
  379. variable exists is to make debugging easier.")
  380.  
  381. (defvar symlink-expand-file-name-overloaded-yet-p nil
  382.   "Whether expand-file-name has been overloaded at least once by the
  383. symlink-fix package.")
  384.  
  385. (defun symlink-overload-expand-file-name ()
  386.   "Overload expand-file-name with the function symlink-new-expand-file-name.
  387. If this overloading has been done before, it is removed and redone.  This
  388. allows changing the order of overloading if more than one package is
  389. overloading expand-file-name."
  390.  
  391.   (if symlink-expand-file-name-overloaded-yet-p
  392.       ;; If we've already overloaded it, then if someone else has overloaded
  393.       ;; it after us, remove ourself from the overloading chain before
  394.       ;; overloading it again, otherwise pop ourself from the top of the
  395.       ;; overloading chain.
  396.       (if (eq (symbol-function 'expand-file-name)
  397.           symlink-intermediary-overloading-symbol)
  398.       (fset 'expand-file-name 
  399.         (symbol-function 'symlink-original-expand-file-name))
  400.     (fset symlink-intermediary-overloading-symbol
  401.           (symbol-function 'symlink-original-expand-file-name))))
  402.   
  403.   (setq symlink-intermediary-overloading-symbol
  404.     (make-symbol
  405.      (format "symlink-intermediary-overloading-symbol-uninterned-%d"
  406.          (setq symlink-intermediary-overloading-symbol-counter
  407.                (1+ symlink-intermediary-overloading-symbol-counter)))))
  408.   (fset 'symlink-original-expand-file-name
  409.     (symbol-function 'expand-file-name))
  410.   (fset 'expand-file-name symlink-intermediary-overloading-symbol)
  411.   (fset symlink-intermediary-overloading-symbol
  412.     'symlink-new-expand-file-name)
  413.   (setq symlink-expand-file-name-overloaded-yet-p t))
  414.  
  415. (defun symlink-new-expand-file-name (filename &optional directory)
  416.   "Convert FILENAME to absolute, and canonicalize it.
  417. Second arg DIRECTORY is directory to start with if FILENAME is relative
  418. \(does not start with slash); if DIRECTORY is nil or missing,
  419. the current buffer's value of default-directory is used.
  420. Filenames containing . or .. as components are simplified;
  421. initial ~ is expanded.  See also the function  substitute-in-file-name.
  422.  
  423. All symbolic links are resolved from FILENAME, with exceptions specified
  424. by symlink-mapping-alist and symlink-no-resolve-symlinks-regexp.
  425.  
  426. NOTE:  This is not the standard expand-file-name that comes with Emacs!
  427. This is the symlink-new-expand-file-name function that is overloading
  428. expand-file-name."
  429.  
  430.   (if expand-file-name-resolve-symlinks-p
  431.       (let ((expand-file-name-resolve-symlinks-p nil))
  432.     (symlink-expand-file-name filename directory))
  433.     (symlink-original-expand-file-name filename directory)))
  434.  
  435. ;;
  436. ;; Give a default initial behavior that will make symlink-expand-file-name
  437. ;; work even if expand-file-name is not overloaded.
  438. ;;
  439.  
  440. (or (fboundp 'symlink-original-expand-file-name)
  441.     (fset 'symlink-original-expand-file-name 'expand-file-name))
  442.  
  443. ;;
  444. ;; Perform the overloading at load time if requested.
  445. ;;
  446.  
  447. (if (and symlink-overload-expand-file-name-p
  448.      (not symlink-expand-file-name-overloaded-yet-p))
  449.     (symlink-overload-expand-file-name))
  450.  
  451. (provide 'symlink-fix)
  452.