Mercurial > hg > xemacs-beta

comparison lisp/loadhist.el @ 380:8626e4521993 r21-2-5

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-5
author cvs
date Mon, 13 Aug 2007 11:07:10 +0200
parents 57709be46d1b
children 501cfd01ee6d
comparison
equal deleted inserted replaced
379:76b7d63099ad 380:8626e4521993
32 ;; These functions exploit the load-history system variable. 32 ;; These functions exploit the load-history system variable.
33 ;; Entry points include `unload-feature', `symbol-file', and `feature-file'. 33 ;; Entry points include `unload-feature', `symbol-file', and `feature-file'.
34 34
35 ;;; Code: 35 ;;; Code:
36 36
37 ;; load-history is a list of entries that look like this:
38 ;; ("outline" outline-regexp ... (require . wid-edit) ... (provide . outline) ...)
39
37 (defun symbol-file (sym) 40 (defun symbol-file (sym)
38 "Return the input source from which SYM was loaded. 41 "Return the input source from which SYM was loaded.
39 This is a file name, or nil if the source was a buffer with no associated file." 42 This is a file name, or nil if the source was a buffer with no associated file."
40 (interactive "SFind source file for symbol: ") ; XEmacs 43 (interactive "SFind source file for symbol: ") ; XEmacs
41 (catch 'foundit 44 (dolist (entry load-history)
42 (mapcar 45 (when (memq sym (cdr entry))
43 (function (lambda (x) (if (memq sym (cdr x)) (throw 'foundit (car x))))) 46 (return (car entry)))))
44 load-history)
45 nil))
46 47
47 (defun feature-symbols (feature) 48 (defun feature-symbols (feature)
48 "Return the file and list of symbols associated with a given FEATURE." 49 "Return the file and list of symbols associated with a given FEATURE."
49 (catch 'foundit 50 (let ((pair `(provide . ,feature)))
50 (mapcar 51 (dolist (entry load-history)
51 (function (lambda (x) 52 (when (member pair (cdr entry))
52 (if (member (cons 'provide feature) (cdr x)) 53 (return entry)))))
53 (throw 'foundit x))))
54 load-history)
55 nil))
56 54
57 (defun feature-file (feature) 55 (defun feature-file (feature)
58 "Return the file name from which a given FEATURE was loaded. 56 "Return the file name from which a given FEATURE was loaded.
59 Actually, return the load argument, if any; this is sometimes the name of a 57 Actually, return the load argument, if any; this is sometimes the name of a
60 Lisp file without an extension. If the feature came from an eval-buffer on 58 Lisp file without an extension. If the feature came from an eval-buffer on
61 a buffer with no associated file, or an eval-region, return nil." 59 a buffer with no associated file, or an eval-region, return nil."
62 (if (not (featurep feature)) 60 (unless (featurep feature)
63 (error "%s is not a currently loaded feature" (symbol-name feature)) 61 (error "%s is not a currently loaded feature" (symbol-name feature)))
64 (car (feature-symbols feature)))) 62 (car (feature-symbols feature)))
63
64 (defun file-symbols (file)
65 "Return the file and list of symbols associated with FILE.
66 The file name in the returned list is the string used to load the file,
67 and may not be the same string as FILE, but it will be equivalent."
68 (or (assoc file load-history)
69 (assoc (file-name-sans-extension file) load-history)
70 (assoc (concat file ".el") load-history)
71 (assoc (concat file ".elc") load-history)))
65 72
66 (defun file-provides (file) 73 (defun file-provides (file)
67 "Return the list of features provided by FILE." 74 "Return the list of features provided by FILE."
68 (let ((symbols (or (cdr (assoc file load-history)) 75 (let ((provides nil))
69 (cdr (assoc (file-name-sans-extension file) load-history)) 76 (dolist (x (cdr (file-symbols file)))
70 (cdr (assoc (concat file ".el") load-history)) 77 (when (eq (car-safe x) 'provide)
71 (cdr (assoc (concat file ".elc") load-history)))) 78 (push (cdr x) provides)))
72 (provides nil)) 79 provides))
73 (mapcar
74 (function (lambda (x)
75 (if (and (consp x) (eq (car x) 'provide))
76 (setq provides (cons (cdr x) provides)))))
77 symbols)
78 provides
79 ))
80 80
81 (defun file-requires (file) 81 (defun file-requires (file)
82 "Return the list of features required by FILE." 82 "Return the list of features required by FILE."
83 (let ((symbols (cdr (assoc file load-history))) (requires nil)) 83 (let ((requires nil))
84 (mapcar 84 (dolist (x (cdr (file-symbols file)))
85 (function (lambda (x) 85 (when (eq (car-safe x) 'require)
86 (if (and (consp x) (eq (car x) 'require)) 86 (push (cdr x) requires)))
87 (setq requires (cons (cdr x) requires))))) 87 requires))
88 symbols)
89 requires
90 ))
91
92 (defun file-set-intersect (p q)
93 ;; Return the set intersection of two lists
94 (let ((ret nil))
95 (mapcar
96 (function (lambda (x) (if (memq x q) (setq ret (cons x ret)))))
97 p)
98 ret
99 ))
100 88
101 (defun file-dependents (file) 89 (defun file-dependents (file)
102 "Return the list of loaded libraries that depend on FILE. 90 "Return the list of loaded libraries that depend on FILE.
103 This can include FILE itself." 91 This can include FILE itself."
104 (let ((provides (file-provides file)) (dependents nil)) 92 (let ((provides (file-provides file))
105 (mapcar 93 (dependents nil))
106 (function (lambda (x) 94 (dolist (entry load-history)
107 (if (file-set-intersect provides (file-requires (car x))) 95 (dolist (x (cdr entry))
108 (setq dependents (cons (car x) dependents))))) 96 (when (and (eq (car-safe x) 'require)
109 load-history) 97 (memq (cdr-safe x) provides))
110 dependents 98 (push (car entry) dependents))))
111 )) 99 dependents))
112 100
113 ;; FSFmacs 101 ;; FSFmacs
114 ;(defun read-feature (prompt) 102 ;(defun read-feature (prompt)
115 ; "Read a feature name \(string\) from the minibuffer, 103 ; "Read a feature name \(string\) from the minibuffer,
116 ;prompting with PROMPT and completing from `features', and 104 ;prompting with PROMPT and completing from `features', and
117 ;return the feature \(symbol\)." 105 ;return the feature \(symbol\)."
118 ; (intern (completing-read prompt 106 ; (intern (completing-read prompt
119 ; (mapcar (function (lambda (feature) 107 ; (mapcar #'(lambda (feature)
120 ; (list (symbol-name feature)))) 108 ; (list (symbol-name feature)))
121 ; features) 109 ; features)
122 ; nil t))) 110 ; nil t)))
123 111
124 ;; ;;;###autoload 112 ;; ;;;###autoload
125 (defun unload-feature (feature &optional force) 113 (defun unload-feature (feature &optional force)
126 "Unload the library that provided FEATURE, restoring all its autoloads. 114 "Unload the library that provided FEATURE, restoring all its autoloads.
127 If the feature is required by any other loaded code, and optional FORCE 115 If the feature is required by any other loaded code, and optional FORCE
128 is nil, raise an error." 116 is nil, raise an error."
129 (interactive "SFeature: ") 117 (interactive "SFeature: ")
130 (if (not (featurep feature)) 118 (unless (featurep feature)
131 (error "%s is not a currently loaded feature" (symbol-name feature))) 119 (error "%s is not a currently loaded feature" (symbol-name feature)))
132 (if (not force) 120 (when (not force)
133 (let* ((file (feature-file feature)) 121 (let* ((file (feature-file feature))
134 (dependents (delete file (copy-sequence (file-dependents file))))) 122 (dependents (delete file (copy-sequence (file-dependents file)))))
135 (if dependents 123 (when dependents
136 (error "Loaded libraries %s depend on %s" 124 (error "Loaded libraries %s depend on %s"
137 (prin1-to-string dependents) file) 125 (prin1-to-string dependents) file))))
138 )))
139 (let* ((flist (feature-symbols feature)) (file (car flist))) 126 (let* ((flist (feature-symbols feature)) (file (car flist)))
140 (mapcar 127 (mapcar
141 (function (lambda (x) 128 #'(lambda (x)
142 (cond ((stringp x) nil) 129 (cond ((stringp x) nil)
143 ((consp x) 130 ((consp x)
144 ;; Remove any feature names that this file provided. 131 ;; Remove any feature names that this file provided.
145 (if (eq (car x) 'provide) 132 (if (eq (car x) 'provide)
146 (setq features (delq (cdr x) features)))) 133 (setq features (delq (cdr x) features))))
147 ((boundp x) (makunbound x)) 134 ((boundp x) (makunbound x))
148 ((fboundp x) 135 ((fboundp x)
149 (fmakunbound x) 136 (fmakunbound x)
150 (let ((aload (get x 'autoload))) 137 (let ((aload (get x 'autoload)))
151 (if aload (fset x (cons 'autoload aload)))))))) 138 (if aload (fset x (cons 'autoload aload)))))))
152 (cdr flist)) 139 (cdr flist))
153 ;; Delete the load-history element for this file. 140 ;; Delete the load-history element for this file.
154 (let ((elt (assoc file load-history))) 141 (let ((elt (assoc file load-history)))
155 (setq load-history (delq elt load-history))))) 142 (setq load-history (delq elt load-history)))))
156 143