home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / functions / shadow-load.el < prev    next >
Encoding:
Text File  |  1991-07-24  |  11.2 KB  |  289 lines
  1. ; Path: dg-rtp!rock!mcnc!stanford.edu!agate!usenet.ins.cwru.edu!magnus.acs.ohio-state.edu!cis.ohio-state.edu!ifi.uio.no!hallvard
  2. ; From: hallvard@ifi.uio.no (Hallvard B Furuseth)
  3. ; Newsgroups: gnu.emacs.sources
  4. ; Subject: shadow-load.el
  5. ; Date: 11 Jul 91 23:11:05 GMT
  6. ; 
  7. ; Here is a library I have forgotten to post for some time.
  8. ; 
  9. ; If your private ~/elisp/foo.el loads the standard library foo.el and then
  10. ; redefines some parts of it, you can now put
  11. ; 
  12. ;    (load "foo" nil 'shadow)
  13. ; 
  14. ; in ~/elisp/foo.el to load the standard library.  It does the same as
  15. ; normal load, but skips the first ~/elisp/foo.el in load-path.
  16. ; 
  17. ; This can be convenient if the "standard" load-path is undetermined when
  18. ; you write your mod to foo.el, or if "foo" loads other libraries which are
  19. ; also modified in ~/elisp.  Otherwise ~/elisp/foo.el could simply say
  20. ; 
  21. ;   (let ((load-path '("/usr/lib/gnu/emacs/lisp")))
  22. ;      (load "foo" nil t))
  23. ; 
  24. ; Problems: It will not always work in autoloads.  Read the top of the file
  25. ; to see.
  26. ; 
  27. ; 
  28. ; Hallvard Furuseth
  29. ; hallvard@ifi.uio.no
  30.  
  31. ;; shadow-load.el version 1.5 for GNU Emacs.
  32. ;; Created by Hallvard B Furuseth (hallvard@ifi.uio.no).
  33. ;; Last modified Tue 18/04-1991.
  34. ;; This code is in the public domain.
  35.  
  36. ;; LCD Archive Entry:
  37. ;; shadow-load|Hallvard B Furuseth|hallvard@ifi.uio.no
  38. ;; |Load "file" from first dir in load-path from which "file" is not loading
  39. ;; |91-04-18|1.5|~/functions/shadow-load.el.Z
  40.  
  41. ;; In file "foo.el", put
  42. ;;
  43. ;;   (load "foo" nil 'shadow)
  44. ;;
  45. ;; to load "foo" from the first dir in load-path from which "foo" not
  46. ;; currently loading.
  47. ;; It first searches load-path once for library "foo", the first occurrence
  48. ;; which is not already shadowed is assumed to be the current file.
  49. ;;
  50. ;; To let others (who do not have ~you/elisp in load-path) load your foo, the
  51. ;; form below is currently necessary. It will probably be abolished if
  52. ;; shadowing is implemeted in C:
  53. ;;
  54. ;;   (require 'shadow-load "~you/elisp/shadow-load")
  55. ;;   (load "foo" nil "~you/elisp/foo")
  56. ;;
  57. ;; This informs load that the your "foo" resides in ~you/elisp/.
  58. ;; But in many cases you could probably just as well say
  59. ;;    (load "/local/lib/gnu/emacs/lisp/foo").
  60. ;;
  61. ;; Extended require:
  62. ;;   Arg 3 is NOERROR as 2nd arg to load,
  63. ;;   Arg 4 is SHADOW ('shadow or filename of self, as with load).
  64. ;; So you may prefer to use require instead of load:
  65. ;;
  66. ;;   (require 'shadow-load "~you/elisp/shadow-load")
  67. ;;   (require 'foo nil nil "~you/elisp/foo")
  68. ;;
  69. ;; Modified eval-current-buffer and eval-region so shadowing can be
  70. ;; used inside them.
  71. ;;
  72. ;; Also includes an extension to my where-is-file (locate a file in a pathlist)
  73. ;; which obeys the variable load-ignore-directories.
  74.  
  75. ;; Bugs and caveats:
  76. ;;
  77. ;;   If you don't tell Load which file is currently loading, it can guess
  78. ;;   wrong.
  79. ;;
  80. ;;   When you give 3rd or 4th arg to Require, defuns in the loaded file are
  81. ;;   not undone if the feature was not provided.
  82. ;;
  83. ;;   File-id has several problems.  See comments in the code.
  84. ;;   It is used to (try to) detect directories with several names, but
  85. ;;   if you don't like it, replace it with (fset 'file-id 'identity).
  86. ;;
  87. ;;   These problems can be fixed by writing this in C.
  88. ;;   The code should be smaller in C, too.  Load, f.ex, would simply bind
  89. ;;   current-load-info to (cons full-filename load-ignore-directories) during
  90. ;;   readevalloop().  When shadowing, it would bind load-ignore-directories
  91. ;;   to (cons (file-id (car current-load-info)) (cdr current-load-info))
  92. ;;   during openp() and when computing the current-load-info above.
  93.  
  94. (provide 'shadow-load)
  95.  
  96.  
  97. (defvar current-load-info nil
  98.   "Info about the currently loading file.  Set by function load.
  99. Value: (full_filename . load-ignore-directories for (load ... 'shadow)).")
  100.  
  101. (defvar load-ignore-directories nil
  102.   "If (list (file-id DIR)) is in this list, where-is-file will not return
  103. files in DIR.  However, files in subdirs of DIR may still be returned.
  104. Used in (load ... 'shadow).
  105. Don't modify this variable unless you know exactly what you are doing.")
  106.  
  107.  
  108. (or (fboundp 'shadow-old-load)
  109.     (fset 'shadow-old-load (symbol-function 'load)))
  110.  
  111. (defun load (shadow-lib &optional shadow-noerr shadow-self shadow-nosuff)
  112.   "Execute a file of Lisp code named FILE.
  113. First tries FILE with .elc appended, then tries with .el,
  114.  then tries FILE unmodified.  Searches directories in  load-path.
  115. If optional second arg NOERROR is non-nil,
  116.  report no error if FILE doesn't exist.
  117. Print messages at start and end of loading unless
  118.  optional third arg NOMESSAGE is non-nil.
  119. If optional fourth arg NOSUFFIX is non-nil, don't try adding
  120.  suffixes .elc or .el to the specified name FILE.
  121. Return t if file exists.
  122.  
  123. Extension:
  124. If NOMESSAGE is 'shadow, load FILE from the first dir in load-path from which
  125.  FILE is not currently loading.  If FILE is an absolute pathname, just fail if
  126.  it's already loading.  The calling file must have the same basename as FILE.
  127. Until this is written in C, NOMESSAGE may also be the full pathname of the file
  128.  which calls load.  If not, load assumes this is the first (not shadowed) FILE
  129.  in load-path."
  130.   (if (not (or (eq shadow-self 'shadow) (stringp shadow-self)))
  131.       (let ((current-load-info (list shadow-lib)))
  132.     (shadow-old-load shadow-lib shadow-noerr shadow-self shadow-nosuff))
  133.     (or current-load-info load-in-progress
  134.     (error "Attempt to shadow-load while no load in progress"))
  135.     (let ((current-load-info
  136.        (let* ((load-ignore-directories load-ignore-directories)
  137.           (case-fold-search (eq system-type 'vax-vms))
  138.           self key tmp)
  139.          ;; Get or guess current library name and load-ignore-directories
  140.          (setq self (cond
  141.              ((not (stringp shadow-self)) shadow-lib)
  142.              ((not (file-name-absolute-p shadow-self))
  143.               (error "load: non-absolute shadow %s" shadow-self))
  144.              ((setq shadow-self (expand-file-name shadow-self))))
  145.            self (substring self 0 (string-match "\\.elc?\\'" self))
  146.            key (file-name-nondirectory self))
  147.          (and current-load-info
  148.           (string-match
  149.            (concat "\\`" (regexp-quote key) "\\(\\.elc?\\)?\\'")
  150.            (file-name-nondirectory (car current-load-info)))
  151.           (progn (setq load-ignore-directories (cdr current-load-info))
  152.              (or (stringp shadow-self)
  153.                  (setq shadow-self (car current-load-info)))))
  154.          ;; load-ignore-directories is set. Find currently loading file
  155.          (or (stringp shadow-self)
  156.          (setq shadow-self (if (file-name-absolute-p self) key self)))
  157.          (setq self
  158.            (cond ((file-name-absolute-p shadow-self)
  159.               (expand-file-name shadow-self))
  160.              ((where-is-file load-path shadow-self ".elc:.el:"))
  161.              ((error "load: unknown shadow file %s" shadow-self))))
  162.          ;; Find shadowed library
  163.          (setq load-ignore-directories
  164.            (cons (list (file-id (file-name-directory self)))
  165.              load-ignore-directories))
  166.          (or (setq shadow-lib
  167.                (where-is-file load-path (setq tmp shadow-lib)
  168.                       (if (not shadow-nosuff) ".elc:.el:")))
  169.          shadow-noerr
  170.          (error "Cannot open shadow-load file: %s" tmp))
  171.          (cons shadow-lib load-ignore-directories))))
  172.       (and shadow-lib
  173.        (shadow-old-load shadow-lib shadow-noerr t t)))))
  174.  
  175.  
  176.  
  177. (or (fboundp 'shadow-old-eval-current-buffer)
  178.     (fset 'shadow-old-eval-current-buffer (symbol-function 'eval-current-buffer)))
  179. (defun eval-current-buffer (&optional shadow-printflag)
  180.   (interactive)
  181.   (let ((current-load-info (if buffer-file-name
  182.                    (list buffer-file-name))))
  183.     (shadow-old-eval-current-buffer shadow-printflag)))
  184.  
  185. (or (fboundp 'shadow-old-eval-region)
  186.     (fset 'shadow-old-eval-region (symbol-function 'eval-region)))
  187. (defun eval-region (shadow-beginning shadow-end &optional shadow-printflag)
  188.   (interactive "r")
  189.   (let ((current-load-info (if buffer-file-name
  190.                    (list buffer-file-name))))
  191.     (shadow-old-eval-region shadow-beginning shadow-end shadow-printflag)))
  192.  
  193.  
  194.  
  195. (or (fboundp 'shadow-old-require)
  196.     (fset 'shadow-old-require (symbol-function 'require)))
  197.  
  198. (defun require (rq-feature &optional rq-file rq-noerror rq-shadow)
  199.   "If FEATURE is not present in Emacs (ie (featurep FEATURE) is false),
  200.  load FILENAME.  FILENAME is optional and defaults to FEATURE.
  201. Extension:
  202. If NOERROR is non-nil, report no error if no FILENAME is found.
  203. If SHADOW is 'shadow (or, for now, a string), it is used as 3rd arg to load."
  204.   (cond ((featurep rq-feature) rq-feature)
  205.     ((not (or rq-noerror rq-shadow))
  206.      (shadow-old-require rq-feature rq-file))
  207.     ((not (condition-case error
  208.           (load (or rq-file (symbol-name rq-feature))
  209.             rq-noerror (or rq-shadow t))
  210.         (error
  211.          (setq features (delq rq-feature features))
  212.          (signal (car error) (cdr error)))))
  213.      nil)
  214.     ((featurep rq-feature) rq-feature)
  215.     ((error "Required feature %s was not provided" rq-feature))))
  216.  
  217.  
  218. ;; This is a lisp version of openp() in src/lread.c,
  219. ;; ***extended to obey the load-ignore-directories variable***.
  220. ;;  Instead of using the exec_only argument of openp(), it returns the
  221. ;;  name of a *readable* file.  Should include an optional prefix arg
  222. ;;  ACCESS as well, but that can't be done correctly in Elisp.
  223. (defun where-is-file (path file &optional suffixes)
  224.   "Search through PATH (list) for a readable FILENAME, expanded by one of the
  225. optional SUFFIXES (string of suffixes separated by \":\"s).  Interactively,
  226. SUFFIXES (default \".elc:.el:\") is prompted when there is a prefix arg.
  227. Does not return files in load-ignore-directories, see doc for that variable."
  228.   (interactive
  229.    (list (let ((path (read-minibuffer "Search path: " "load-path")))
  230.        (if (and (consp path) (or (stringp (car path)) (null (car path))))
  231.            path
  232.          (eval path)))
  233.      (read-string "Locate file: ")
  234.      (if current-prefix-arg
  235.          (read-string "Suffixes: " ".elc:.el:")
  236.        ".elc:.el:")))
  237.   (if (not (equal file ""))
  238.       (let ((filelist nil) pos temp templist ignore)
  239.     ;; Make list of possible file names
  240.     (setq filelist
  241.           (if suffixes
  242.           (progn
  243.             (while (setq pos (string-match ":[^:]*\\'" suffixes))
  244.               (setq filelist (cons (concat file (substring suffixes
  245.                                    (1+ pos)))
  246.                        filelist))
  247.               (setq suffixes (substring suffixes 0 pos)))
  248.             (cons (concat file suffixes) filelist))
  249.         (list file)))
  250.     ;; Search PATH for a readable file in filelist
  251.     (catch 'bar
  252.       (if (file-name-absolute-p file) (setq path '(nil)))
  253.       (while path
  254.         (setq ignore (cons '(nil) load-ignore-directories))
  255.         (setq templist filelist)
  256.         (while
  257.         (progn
  258.           (setq temp (expand-file-name (car templist) (car path)))
  259.           (cond ((and ignore
  260.                   (prog1
  261.                   (assoc (file-id (file-name-directory temp))
  262.                      ignore)
  263.                 (setq ignore nil)))
  264.              nil)
  265.             ((file-readable-p temp)
  266.              (if (interactive-p)
  267.                  (message "%s" temp))
  268.              (throw 'bar temp))
  269.             ((setq templist (cdr templist))))))
  270.         (setq path (cdr path)))
  271.       (if (interactive-p)
  272.           (message "(File %s not found)" file))
  273.       nil))))
  274.  
  275.  
  276. (defun file-id (file)
  277.   "Attempt to return an i.d. for FILE which is unique (by EQUAL)."
  278.   ;; Problems:
  279.   ;;    Does not dereference if FILE is a symlink (because expand-file-name
  280.   ;;      handles "foo/.." incorrectly if foo is a symlink).
  281.   ;;    I have no idea of how this works on non-UNIX systems.
  282.   ;;    Can't get FILE's device, so two files with the same
  283.   ;;      inode and owner will be considered equal.
  284.   ;;  If you don't trust it, replace it with (fset 'file-id 'identity).
  285.   (if (setq file (file-attributes file))
  286.       ;; Should be (inode . device), but I suppose this is safe enough
  287.       ;; for the use of this package.
  288.       (cons (nth 10 file) (nth 2 file))))
  289.