Mercurial > hg > xemacs-beta

comparison lisp/packages.el @ 276:6330739388db r21-0b36

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-0b36
author cvs
date Mon, 13 Aug 2007 10:30:37 +0200
parents ca9a9ec9c1c1
children 90d73dddcdc4
comparison
equal deleted inserted replaced
275:a68ae4439f57 276:6330739388db
55 ;;; Package versioning 55 ;;; Package versioning
56 56
57 (defvar packages-package-list nil 57 (defvar packages-package-list nil
58 "database of loaded packages and version numbers") 58 "database of loaded packages and version numbers")
59 59
60 (defvar packages-hierarchy-depth 1
61 "Depth of package hierarchies.")
62
63 (defvar packages-load-path-depth 1
64 "Depth of load-path search in package hierarchies.")
65
60 (defvar early-packages nil 66 (defvar early-packages nil
61 "Packages early in the load path.") 67 "Packages early in the load path.")
62 68
63 (defvar early-package-load-path nil 69 (defvar early-package-load-path nil
64 "Load path for packages early in the load path.") 70 "Load path for packages early in the load path.")
75 (defvar last-package-load-path nil 81 (defvar last-package-load-path nil
76 "Load path for packages last in the load path.") 82 "Load path for packages last in the load path.")
77 83
78 (defvar package-locations 84 (defvar package-locations
79 (list 85 (list
80 (list "~/.xemacs" 'early #'(lambda () t)) 86 (list (paths-construct-path '("~" ".xemacs"))
87 'early #'(lambda () t))
88 (list "site-packages" 'late #'(lambda () t))
81 (list "mule-packages" 'late #'(lambda () (featurep 'mule))) 89 (list "mule-packages" 'late #'(lambda () (featurep 'mule)))
82 (list "packages" 'late #'(lambda () t)) 90 (list "packages" 'late #'(lambda () t))
83 (list "infodock-packages" 'late #'(lambda () (featurep 'infodock)))) 91 (list "infodock-packages" 'late #'(lambda () (featurep 'infodock))))
84 "Locations of the various package directories. 92 "Locations of the various package directories.
85 This is a list each of whose elements describes one directory. 93 This is a list each of whose elements describes one directory.
214 This function is used during build to find where the global symbol files so 222 This function is used during build to find where the global symbol files so
215 they can be perused for their useful information." 223 they can be perused for their useful information."
216 ;; Source directory may not be initialized yet. 224 ;; Source directory may not be initialized yet.
217 ;; (print (prin1-to-string load-path)) 225 ;; (print (prin1-to-string load-path))
218 (if (null source-directory) 226 (if (null source-directory)
219 (setq source-directory (concat (car load-path) "./"))) 227 (setq source-directory (car load-path)))
220 (let ((files (directory-files (file-name-as-directory source-directory) 228 (let ((files (directory-files (file-name-as-directory source-directory)
221 t ".*")) 229 t ".*"))
222 file autolist) 230 file autolist)
223 ;; (print (prin1-to-string source-directory)) 231 ;; (print (prin1-to-string source-directory))
224 ;; (print (prin1-to-string files)) 232 ;; (print (prin1-to-string files))
225 (while (setq file (car-safe files)) 233 (while (setq file (car-safe files))
226 (if (and (file-directory-p file) 234 (if (and (file-directory-p file)
227 (file-exists-p (concat file "/" autoload-file-name))) 235 (file-exists-p (concat (file-name-as-directory file)
228 (setq autolist (cons (concat file "/" autoload-file-name) 236 autoload-file-name)))
237 (setq autolist (cons (concat (file-name-as-directory file)
238 autoload-file-name)
229 autolist))) 239 autolist)))
230 (setq files (cdr files))) 240 (setq files (cdr files)))
231 autolist)) 241 autolist))
232 242
233 ;; The following function cannot be called from a bare temacs 243 ;; The following function cannot be called from a bare temacs
276 (condition-case nil 286 (condition-case nil
277 (load autoload-file) 287 (load autoload-file)
278 (t nil))) 288 (t nil)))
279 (setq autoload-list (cdr autoload-list))))) 289 (setq autoload-list (cdr autoload-list)))))
280 290
281 ;; The following function cannot be called from a bare temacs
282 (defun packages-reload-dumped-lisp ()
283 "Reload new or updated dumped lisp files (with exceptions).
284 This is an extremely dangerous function to call at any time."
285 ;; Nothing for the moment
286 nil)
287
288 ;; Data-directory is really a list now. Provide something to search it for 291 ;; Data-directory is really a list now. Provide something to search it for
289 ;; directories. 292 ;; directories.
290 293
291 (defun locate-data-directory (name &optional dir-list) 294 (defun locate-data-directory (name &optional dir-list)
292 "Locate a directory in a search path DIR-LIST (a list of directories). 295 "Locate a directory in a search path DIR-LIST (a list of directories).
293 If no DIR-LIST is supplied, it defaults to `data-directory-list'." 296 If no DIR-LIST is supplied, it defaults to `data-directory-list'."
294 (unless dir-list 297 (unless dir-list
295 (setq dir-list data-directory-list)) 298 (setq dir-list data-directory-list))
296 (let (found found-dir) 299 (let (found found-dir)
297 (while (and (null found-dir) dir-list) 300 (while (and (null found-dir) dir-list)
298 (setq found (concat (car dir-list) name "/") 301 (setq found (file-name-as-directory (concat (car dir-list) name))
299 found-dir (file-directory-p found)) 302 found-dir (file-directory-p found))
300 (or found-dir 303 (or found-dir
301 (setq found nil)) 304 (setq found nil))
302 (setq dir-list (cdr dir-list))) 305 (setq dir-list (cdr dir-list)))
303 found)) 306 found))
327 "Special subdirectories of packages.") 330 "Special subdirectories of packages.")
328 331
329 (defun packages-find-packages-in-directories (directories) 332 (defun packages-find-packages-in-directories (directories)
330 "Find all packages underneath directories in DIRECTORIES." 333 "Find all packages underneath directories in DIRECTORIES."
331 (paths-find-recursive-path directories 334 (paths-find-recursive-path directories
335 packages-hierarchy-depth
332 (append paths-version-control-bases 336 (append paths-version-control-bases
333 packages-special-bases))) 337 packages-special-bases)))
334 338
335 (defun packages-split-path (path) 339 (defun packages-split-path (path)
336 "Split PATH at \"/\", return pair with two components. 340 "Split PATH at \"\", return pair with two components.
337 The second component is shared with PATH." 341 The second component is shared with PATH."
338 (let ((reverse-tail '()) 342 (let ((reverse-tail '())
339 (rest path)) 343 (rest path))
340 (while (and rest (null (string-equal "/" (car rest)))) 344 (while (and rest (null (string-equal "" (car rest))))
341 (setq reverse-tail (cons (car rest) reverse-tail)) 345 (setq reverse-tail (cons (car rest) reverse-tail))
342 (setq rest (cdr rest))) 346 (setq rest (cdr rest)))
343 (if (null rest) 347 (if (null rest)
344 (cons path nil) 348 (cons path nil)
345 (cons (nreverse reverse-tail) (cdr rest))))) 349 (cons (nreverse reverse-tail) (cdr rest)))))
346 350
347 (defun packages-split-package-path (package-path) 351 (defun packages-split-package-path (package-path)
348 "Split up PACKAGE-PATH into early, late and last components. 352 "Split up PACKAGE-PATH into early, late and last components.
349 The separation is by \"/\" components. 353 The separation is by \"\" components.
350 This returns (LIST EARLY-PACKAGES LATE-PACKAGES LAST-PACKAGES)." 354 This returns (LIST EARLY-PACKAGES LATE-PACKAGES LAST-PACKAGES)."
351 ;; When in doubt, it's late 355 ;; When in doubt, it's late
352 (let* ((stuff (packages-split-path package-path)) 356 (let* ((stuff (packages-split-path package-path))
353 (early (and (cdr stuff) (car stuff))) 357 (early (and (cdr stuff) (car stuff)))
354 (late+last (or (cdr stuff) (car stuff))) 358 (late+last (or (cdr stuff) (car stuff)))
375 (roots package-locations time &optional default) 379 (roots package-locations time &optional default)
376 "Find packages at given time. 380 "Find packages at given time.
377 For the format of PACKAGE-LOCATIONS, see the global variable of the same name. 381 For the format of PACKAGE-LOCATIONS, see the global variable of the same name.
378 TIME is either 'EARLY, 'LATE, or 'LAST. 382 TIME is either 'EARLY, 'LATE, or 'LAST.
379 DEFAULT is a default list of packages." 383 DEFAULT is a default list of packages."
380 (let ((packages '())) 384 (or default
381 (while package-locations 385 (let ((packages '()))
382 (packages-deconstruct 386 (while package-locations
383 (car package-locations) 387 (packages-deconstruct
384 #'(lambda (name a-time thunk) 388 (car package-locations)
385 (if (and (eq time a-time) 389 #'(lambda (name a-time thunk)
386 (funcall thunk)) 390 (if (and (eq time a-time)
387 (setq packages 391 (funcall thunk))
388 (nconc packages 392 (setq packages
389 (packages-find-packages-by-name roots name)))))) 393 (nconc packages
390 (setq package-locations (cdr package-locations))) 394 (packages-find-packages-by-name roots name))))))
391 (paths-uniq-append packages 395 (setq package-locations (cdr package-locations)))
392 default))) 396 packages)))
393 397
394 (defun packages-find-packages (roots &optional inhibit) 398 (defun packages-find-packages (roots)
395 "Find the packages." 399 "Find the packages."
396 (if inhibit 400 (let ((envvar-value (getenv "EMACSPACKAGEPATH")))
397 (list '() '() '()) 401 (if envvar-value
398 (let ((envvar-value (getenv "EMACSPACKAGEPATH"))) 402 (packages-split-package-path (paths-decode-directory-path envvar-value))
399 (if envvar-value 403 (packages-deconstruct
400 (packages-split-package-path envvar-value) 404 (packages-split-package-path configure-package-path)
401 (packages-deconstruct 405 #'(lambda (configure-early-packages
402 (packages-split-package-path configure-package-path) 406 configure-late-packages
403 #'(lambda (configure-early-packages 407 configure-last-packages)
404 configure-late-packages 408 (list (packages-find-packages-at-time roots package-locations 'early
405 configure-last-packages) 409 configure-early-packages)
406 (list (packages-find-packages-at-time roots package-locations 'early 410 (packages-find-packages-at-time roots package-locations 'late
407 configure-early-packages) 411 configure-late-packages)
408 (packages-find-packages-at-time roots package-locations 'late 412 (packages-find-packages-at-time roots package-locations 'last
409 configure-late-packages) 413 configure-last-packages)))))))
410 (packages-find-packages-at-time roots package-locations 'last
411 configure-last-packages))))))))
412 414
413 (defun packages-find-package-library-path (packages suffixes) 415 (defun packages-find-package-library-path (packages suffixes)
414 "Construct a path into a component of the packages hierarchy. 416 "Construct a path into a component of the packages hierarchy.
415 PACKAGES is a list of package directories. 417 PACKAGES is a list of package directories.
416 SUFFIXES is a list of names of package subdirectories to look for." 418 SUFFIXES is a list of names of package subdirectories to look for."
417 (let ((directories 419 (let ((directories
418 (apply 420 (apply
419 #'append 421 #'append
420 (mapcar #'(lambda (package) 422 (mapcar #'(lambda (package)
421 (mapcar #'(lambda (suffix) 423 (mapcar #'(lambda (suffix)
422 (concat package suffix)) 424 (file-name-as-directory (concat package suffix)))
423 suffixes)) 425 suffixes))
424 packages)))) 426 packages))))
425 (paths-directories-which-exist directories))) 427 (paths-directories-which-exist directories)))
426 428
427 (defun packages-find-package-load-path (packages) 429 (defun packages-find-package-load-path (packages)
428 "Construct the load-path component for packages. 430 "Construct the load-path component for packages.
429 PACKAGES is a list of package directories." 431 PACKAGES is a list of package directories."
430 (paths-find-recursive-load-path 432 (paths-find-recursive-load-path
431 (packages-find-package-library-path packages '("lisp/")))) 433 (packages-find-package-library-path packages
434 '("lisp"))
435 packages-load-path-depth))
432 436
433 (defun packages-find-package-exec-path (packages) 437 (defun packages-find-package-exec-path (packages)
434 (packages-find-package-library-path packages 438 (packages-find-package-library-path packages
435 (list (concat "bin/" system-configuration "/") 439 (list (paths-construct-path
436 "lib-src/"))) 440 (list "bin" system-configuration))
441 "lib-src")))
437 442
438 (defun packages-find-package-info-path (packages) 443 (defun packages-find-package-info-path (packages)
439 (packages-find-package-library-path packages '("info/"))) 444 (packages-find-package-library-path packages '("info")))
440 445
441 (defun packages-find-package-data-path (packages) 446 (defun packages-find-package-data-path (packages)
442 (packages-find-package-library-path packages '("etc/"))) 447 (packages-find-package-library-path packages '("etc")))
443 448
444 ;; Loading package initialization files 449 ;; Loading package initialization files
445 450
446 (defun packages-load-package-lisps (package-load-path base) 451 (defun packages-load-package-lisps (package-load-path base)
447 "Load all Lisp files of a certain name along a load path. 452 "Load all Lisp files of a certain name along a load path.
448 BASE is the base name of the files." 453 BASE is the base name of the files."
449 (mapc #'(lambda (dir) 454 (mapc #'(lambda (dir)
450 (let ((file-name (expand-file-name base dir))) 455 (let ((file-name (expand-file-name base dir)))
451 (if (file-exists-p file-name) 456 (condition-case error
452 (condition-case error 457 (load file-name t t)
453 (load file-name) 458 (error
454 (error 459 (warn (format "Autoload error in: %s:\n\t%s"
455 (warn (format "Autoload error in: %s:\n\t%s" 460 file-name
456 file-name 461 (with-output-to-string
457 (with-output-to-string 462 (display-error error nil))))))))
458 (display-error error nil)))))))))
459 package-load-path)) 463 package-load-path))
460 464
461 (defun packages-load-package-auto-autoloads (package-load-path) 465 (defun packages-load-package-auto-autoloads (package-load-path)
462 "Load auto-autoload files along a load path." 466 "Load auto-autoload files along a load path."
463 (packages-load-package-lisps package-load-path 467 (packages-load-package-lisps package-load-path
476 ;; dumped-lisp.el could have set this ... 480 ;; dumped-lisp.el could have set this ...
477 (if package-lisp 481 (if package-lisp
478 (mapc #'(lambda (base) 482 (mapc #'(lambda (base)
479 (funcall handle base)) 483 (funcall handle base))
480 package-lisp)))))) 484 package-lisp))))))
481 package-load-path)) 485 package-load-path))
482 486
483 (defun packages-load-package-dumped-lisps (package-load-path) 487 (defun packages-load-package-dumped-lisps (package-load-path)
484 "Load dumped-lisp.el files along a load path. 488 "Load dumped-lisp.el files along a load path.
485 Also load files off PACKAGE-LISP definitions there" 489 Also load files off PACKAGE-LISP definitions there"
486 (packages-handle-package-dumped-lisps #'load package-load-path)) 490 (packages-handle-package-dumped-lisps #'load package-load-path))