Mercurial > hg > xemacs-beta

comparison lisp/package-admin.el @ 5118:e0db3c197671 ben-lisp-object

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
merge up to latest default branch, doesn't compile yet
author Ben Wing <ben@xemacs.org>
date Sat, 26 Dec 2009 21:18:49 -0600
parents 3c92890f3750
children 308d34e9f07d
comparison
equal deleted inserted replaced
5117:3742ea8250b5 5118:e0db3c197671
148 148
149 Argument TYPE is a symbol that determines the type of package we're 149 Argument TYPE is a symbol that determines the type of package we're
150 trying to find a directory for. 150 trying to find a directory for.
151 151
152 Optional Argument USER-DIR if non-nil use directories off 152 Optional Argument USER-DIR if non-nil use directories off
153 `user-init-directory'. This overrides everything except 153 `early-package-directories'.
154 \"EMACSPACKAGEPATH\".
155
156 This function honours the environment variable \"EMACSPACKAGEPATH\"
157 and returns directories found there as a priority. If that variable
158 doesn't exist and USER-DIR is nil, check in the normal places.
159 154
160 If we still can't find a suitable directory, return nil. 155 If we still can't find a suitable directory, return nil.
161 156
162 Possible values for TYPE are: 157 Possible values for TYPE are:
163 158
164 std == For \"standard\" packages that go in '/xemacs-packages/' 159 std == For \"standard\" packages that go in '/xemacs-packages/'
165 mule == For \"mule\" packages that go in '/mule-packages/' 160 mule == For \"mule\" packages that go in '/mule-packages/'
166 site == For \"unsupported\" packages that go in '/site-packages/' 161 site == For \"unsupported\" packages that go in '/site-packages/'
167 162 "
168 Note: Type \"site\" is not yet fully supported." 163 (let* ((hierarchies late-package-hierarchies)
169 (let* ((env-value (getenv "EMACSPACKAGEPATH")) 164
165 (hierarchy-suffix
166 (file-name-as-directory
167 (cond
168 ((eq type 'std) "xemacs-packages")
169 ((eq type 'mule) "mule-packages")
170 ((eq type 'site) "site-packages"))))
171 (suffix-length (length hierarchy-suffix))
170 top-dir) 172 top-dir)
171 ;; First, check the environment var. 173
172 (if env-value 174 (if user-dir
173 (let ((path-list (paths-decode-directory-path env-value 'drop-empties))) 175 (expand-file-name hierarchy-suffix
174 (cond ((eq type 'std) 176 (if configure-early-package-directories
175 (while path-list 177 (car configure-early-package-directories)
176 (if (equal (file-name-nondirectory 178 user-init-directory))
177 (directory-file-name (car path-list))) 179
178 "xemacs-packages") 180 (while hierarchies
179 (setq top-dir (car path-list))) 181 (if (string-equal (substring (car hierarchies) (- suffix-length))
180 (setq path-list (cdr path-list)))) 182 hierarchy-suffix)
181 ((eq type 'mule) 183 (setq top-dir (car hierarchies)))
182 (while path-list 184 (setq hierarchies (cdr hierarchies)))
183 (if (equal (file-name-nondirectory 185 top-dir)))
184 (directory-file-name (car path-list))) 186
185 "mule-packages")
186 (setq top-dir (car path-list)))
187 (setq path-list (cdr path-list)))))))
188 ;; Wasn't in the environment, try `user-init-directory' if
189 ;; USER-DIR is non-nil.
190 (if (and user-dir
191 (not top-dir))
192 (cond ((eq type 'std)
193 (setq top-dir (file-name-as-directory
194 (expand-file-name "xemacs-packages" user-init-directory))))
195 ((eq type 'mule)
196 (setq top-dir (file-name-as-directory
197 (expand-file-name "mule-packages" user-init-directory))))))
198 ;; Finally check the normal places
199 (if (not top-dir)
200 (let ((path-list (nth 1 (packages-find-all-package-hierarchies
201 emacs-data-roots))))
202 (cond ((eq type 'std)
203 (while path-list
204 (if (equal (substring (car path-list) -16)
205 (concat "xemacs-packages" (char-to-string directory-sep-char)))
206 (setq top-dir (car path-list)))
207 (setq path-list (cdr path-list))))
208 ((eq type 'mule)
209 (while path-list
210 (if (equal (substring (car path-list) -14)
211 (concat "mule-packages" (char-to-string directory-sep-char)))
212 (setq top-dir (car path-list)))
213 (setq path-list (cdr path-list)))))))
214 ;; Now return either the directory or nil.
215 top-dir))
216 187
217 (defun package-admin-get-install-dir (package &optional pkg-dir) 188 (defun package-admin-get-install-dir (package &optional pkg-dir)
218 "Find a suitable installation directory for a package. 189 "Find a suitable installation directory for a package.
219 190
220 Argument PACKAGE is the package to find a installation directory for. 191 Argument PACKAGE is the package to find a installation directory for.
306 "Check for a MANIFEST.<package> file in the package distribution. 277 "Check for a MANIFEST.<package> file in the package distribution.
307 If it doesn't exist, create and write one. 278 If it doesn't exist, create and write one.
308 PKG-OUTBUF is the buffer that holds the output from `tar', and PKG-TOPDIR 279 PKG-OUTBUF is the buffer that holds the output from `tar', and PKG-TOPDIR
309 is the top-level directory under which the package was installed." 280 is the top-level directory under which the package was installed."
310 (let ((manifest-buf " *pkg-manifest*") 281 (let ((manifest-buf " *pkg-manifest*")
311 (old-case-fold-search case-fold-search) 282 (case-fold-search (file-system-ignore-case-p pkg-topdir))
312 regexp package-name pathname regexps) 283 regexp package-name pathname regexps)
313 (unwind-protect 284 (save-excursion ;; Probably redundant.
314 (save-excursion ;; Probably redundant. 285 (set-buffer (get-buffer pkg-outbuf)) ;; Probably already the current buffer.
315 (set-buffer (get-buffer pkg-outbuf)) ;; Probably already the current buffer. 286 (goto-char (point-min))
316 (goto-char (point-min)) 287 (setq regexp (concat "\\bpkginfo"
317 288 (char-to-string directory-sep-char)
318 ;; Make filenames case-insensitive, if necessary 289 "MANIFEST\\...*"))
319 (if (eq system-type 'windows-nt) 290
320 (setq case-fold-search t)) 291 ;; Look for the manifest.
321 292 (if (not (re-search-forward regexp nil t))
322 (setq regexp (concat "\\bpkginfo" 293 (progn
323 (char-to-string directory-sep-char) 294 ;; We didn't find a manifest. Make one.
324 "MANIFEST\\...*")) 295
325 296 ;; Yuk. We weren't passed the package name, and so we have
326 ;; Look for the manifest. 297 ;; to dig for it. Look for it as the subdirectory name below
327 (if (not (re-search-forward regexp nil t)) 298 ;; "lisp", or "man".
328 (progn 299 ;; Here, we don't use a single regexp because we want to search
329 ;; We didn't find a manifest. Make one. 300 ;; the directories for a package name in a particular order.
330 301 (if (catch 'done
331 ;; Yuk. We weren't passed the package name, and so we have 302 (let ((dirs '("lisp" "man"))
332 ;; to dig for it. Look for it as the subdirectory name below 303 rexp)
333 ;; "lisp", or "man". 304 (while dirs
334 ;; Here, we don't use a single regexp because we want to search 305 (setq rexp (concat "\\b" (car dirs)
335 ;; the directories for a package name in a particular order. 306 "[\\/]\\([^\\/]+\\)[\//]"))
336 (if (catch 'done 307 (if (re-search-forward rexp nil t)
337 (let ((dirs '("lisp" "man")) 308 (throw 'done t))
338 rexp) 309 (setq dirs (cdr dirs)))))
339 (while dirs 310 (progn
340 (setq rexp (concat "\\b" (car dirs) 311 (setq package-name (buffer-substring (match-beginning 1)
341 "[\\/]\\([^\\/]+\\)[\//]")) 312 (match-end 1)))
342 (if (re-search-forward rexp nil t) 313
343 (throw 'done t)) 314 ;; Get and erase the manifest buffer
344 (setq dirs (cdr dirs))))) 315 (setq manifest-buf (get-buffer-create manifest-buf))
345 (progn 316 (buffer-disable-undo manifest-buf)
346 (setq package-name (buffer-substring (match-beginning 1) 317 (erase-buffer manifest-buf)
347 (match-end 1))) 318
348 319 ;; Now, scan through the output buffer, looking for
349 ;; Get and erase the manifest buffer 320 ;; file and directory names.
350 (setq manifest-buf (get-buffer-create manifest-buf)) 321 (goto-char (point-min))
351 (buffer-disable-undo manifest-buf) 322 ;; for each line ...
352 (erase-buffer manifest-buf) 323 (while (< (point) (point-max))
353 324 (beginning-of-line)
354 ;; Now, scan through the output buffer, looking for 325 (setq pathname nil)
355 ;; file and directory names. 326
356 (goto-char (point-min)) 327 ;; scan through the regexps, looking for a pathname
357 ;; for each line ... 328 (if (catch 'found-path
358 (while (< (point) (point-max)) 329 (setq regexps package-admin-tar-filename-regexps)
359 (beginning-of-line) 330 (while regexps
360 (setq pathname nil) 331 (if (looking-at (car regexps))
361 332 (progn
362 ;; scan through the regexps, looking for a pathname 333 (setq pathname
363 (if (catch 'found-path 334 (buffer-substring
364 (setq regexps package-admin-tar-filename-regexps) 335 (match-beginning 1)
365 (while regexps 336 (match-end 1)))
366 (if (looking-at (car regexps)) 337 (throw 'found-path t)))
367 (progn 338 (setq regexps (cdr regexps))))
368 (setq pathname 339 (progn
369 (buffer-substring 340 ;; found a pathname -- add it to the manifest
370 (match-beginning 1) 341 ;; buffer
371 (match-end 1))) 342 (save-excursion
372 (throw 'found-path t))) 343 (set-buffer manifest-buf)
373 (setq regexps (cdr regexps)))) 344 (goto-char (point-max))
374 (progn 345 (insert pathname "\n"))))
375 ;; found a pathname -- add it to the manifest 346 (forward-line 1))
376 ;; buffer 347
377 (save-excursion 348 ;; Processed all lines.
378 (set-buffer manifest-buf) 349 ;; Now, create the file, pkginfo/MANIFEST.<pkgname>
379 (goto-char (point-max)) 350
380 (insert pathname "\n")))) 351 ;; We use `expand-file-name' instead of `concat',
381 (forward-line 1)) 352 ;; for portability.
382 353 (setq pathname (expand-file-name "pkginfo"
383 ;; Processed all lines. 354 pkg-topdir))
384 ;; Now, create the file, pkginfo/MANIFEST.<pkgname> 355 ;; Create pkginfo, if necessary
385 356 (if (not (file-directory-p pathname))
386 ;; We use `expand-file-name' instead of `concat', 357 (make-directory pathname))
387 ;; for portability. 358 (setq pathname (expand-file-name
388 (setq pathname (expand-file-name "pkginfo" 359 (concat "MANIFEST." package-name)
389 pkg-topdir)) 360 pathname))
390 ;; Create pkginfo, if necessary 361 (save-excursion
391 (if (not (file-directory-p pathname)) 362 (set-buffer manifest-buf)
392 (make-directory pathname)) 363 ;; Put the files in sorted order
393 (setq pathname (expand-file-name 364 (if-fboundp 'sort-lines
394 (concat "MANIFEST." package-name) 365 (sort-lines nil (point-min) (point-max))
395 pathname)) 366 (warn "`xemacs-base' not installed, MANIFEST.%s not sorted"
396 (save-excursion 367 package-name))
397 (set-buffer manifest-buf) 368 ;; Write the file.
398 ;; Put the files in sorted order 369 ;; Note that using `write-region' *BYPASSES* any check
399 (if-fboundp 'sort-lines 370 ;; to see if XEmacs is currently editing/visiting the
400 (sort-lines nil (point-min) (point-max)) 371 ;; file.
401 (warn "`xemacs-base' not installed, MANIFEST.%s not sorted" 372 (write-region (point-min) (point-max) pathname))
402 package-name)) 373 (kill-buffer manifest-buf))))))))
403 ;; Write the file.
404 ;; Note that using `write-region' *BYPASSES* any check
405 ;; to see if XEmacs is currently editing/visiting the
406 ;; file.
407 (write-region (point-min) (point-max) pathname))
408 (kill-buffer manifest-buf))))))
409 ;; Restore old case-fold-search status
410 (setq case-fold-search old-case-fold-search))))
411 374
412 ;;;###autoload 375 ;;;###autoload
413 (defun package-admin-add-binary-package (file &optional pkg-dir) 376 (defun package-admin-add-binary-package (file &optional pkg-dir)
414 "Install a pre-bytecompiled XEmacs package into package hierarchy." 377 "Install a pre-bytecompiled XEmacs package into package hierarchy."
415 (interactive "fPackage tarball: ") 378 (interactive "fPackage tarball: ")