diff lisp/startup.el @ 267:966663fcf606 r20-5b32

Import from CVS: tag r20-5b32
author cvs
date Mon, 13 Aug 2007 10:26:29 +0200
parents 727739f917cb
children b2472a1930f2
line wrap: on
line diff
--- a/lisp/startup.el	Mon Aug 13 10:25:39 2007 +0200
+++ b/lisp/startup.el	Mon Aug 13 10:26:29 2007 +0200
@@ -369,6 +369,21 @@
 	    (setq default-directory (file-name-as-directory value)))))
     (setq default-directory (abbreviate-file-name default-directory))
     (initialize-xemacs-paths)
+
+    (startup-set-invocation-environment)
+
+    (let ((roots (paths-find-emacs-roots invocation-directory
+					 invocation-name)))
+      (startup-setup-paths roots
+			   inhibit-package-init
+			   inhibit-site-lisp)
+      (startup-setup-paths-warning))
+
+    (if (not inhibit-package-init)
+	(progn
+	  (packages-load-package-auto-autoloads early-package-load-path)
+	  (packages-load-package-auto-autoloads late-package-load-path)))
+
     (unwind-protect
 	(command-line)
       ;; Do this again, in case .emacs defined more abbreviations.
@@ -504,7 +519,6 @@
 
     (let ((debugger 'early-error-handler)
 	  (debug-on-error t))
-      (set-default-load-path)
 
       ;; Process magic command-line switches like -q and -u.  Do this
       ;; before creating the first frame because some of these switches
@@ -984,404 +998,71 @@
 ;;    (funcall present-file "sample.Xdefaults")
 ;;    (insert (format "\nin the directory %s." data-directory)))
 
-
-;;;; Computing the default load-path, etc.
-;;;
-;;; This stuff is a complete mess and isn't nearly as general as it 
-;;; thinks it is.  It should be rethunk.  In particular, too much logic
-;;; is duplicated between the code that looks around for the various
-;;; directories, and the code which suggests where to create the various
-;;; directories once it decides they are missing.
-
-;;; The source directory has this layout:
-;;;
-;;;    BUILD_ROOT/src/xemacs*			  argv[0]
-;;;    BUILD_ROOT/xemacs*			  argv[0], possibly
-;;;    BUILD_ROOT/lisp/
-;;;    BUILD_ROOT/etc/				  data-directory
-;;;    BUILD_ROOT/info/
-;;;    BUILD_ROOT/lib-src/			  exec-directory, doc-directory
-;;;    BUILD_ROOT/lock/
-;;;
-;;; The default tree created by "make install" has this layout:
-;;;
-;;;    PREFIX/bin/xemacs*	  		argv[0]
-;;;    PREFIX/lib/xemacs-VERSION/lisp/
-;;;    PREFIX/lib/xemacs-VERSION/etc/		  data-directory
-;;;    PREFIX/lib/xemacs-VERSION/info/
-;;;    PREFIX/lib/xemacs-VERSION/CONFIGURATION/	  exec-directory, doc-directory
-;;;    PREFIX/lib/xemacs/lock/
-;;;    PREFIX/lib/xemacs/site-lisp/
-;;;
-;;; The binary packages we ship have that layout, except that argv[0] has
-;;; been moved one level deeper under the bin directory:
-;;;
-;;;    PREFIX/bin/CONFIGURATION/xemacs*
-;;;
-;;; The following code has to deal with at least the above three situations,
-;;; and it should be possible for it to deal with more.  Though perhaps that
-;;; does cover it all?  The trick is, when something is missing, realizing
-;;; which of those three layouts is mostly in place, so that we can suggest
-;;; the right directories in the error message.
-
-
-;; extremely low-tech debugging, since this happens so early in startup.
-;;(or (fboundp 'orig-file-directory-p)
-;;    (fset 'orig-file-directory-p (symbol-function 'file-directory-p)))
-;;(defun file-directory-p (path)
-;;  (send-string-to-terminal (format "PROBING %S" path))
-;;  (let ((v (orig-file-directory-p path)))
-;;    (send-string-to-terminal (format " -> %S\n" v))
-;;    v))
-
-(defun startup-make-version-dir ()
-  (let ((version (and (string-match "\\`[^0-9]*\\([0-9]+\\.[0-9]+\\)"
-				    emacs-version)
-		      (substring emacs-version
-				 (match-beginning 1) (match-end 1)))))
-    (if (string-match "(beta *\\([0-9]+\\))" emacs-version)
-	(setq version (concat version "-b"
-			      (substring emacs-version (match-beginning 1)
-					 (match-end 1)))))
-    (if (string-match "(alpha *\\([0-9]+\\))" emacs-version)
-	(setq version (concat version "-a"
-			      (substring emacs-version (match-beginning 1)
-					 (match-end 1)))))
-    (concat "lib/xemacs-" version)))
-
-(defun find-emacs-root-internal-1 (path lisp-p)
-  ;; (prin1 (format "f-e-r-i-1:  %s\n" path))
-  (let ((dir (file-name-directory path)))
-    (or
-     ;;
-     ;; If this directory is a plausible root of the XEmacs tree, return it.
-     ;;
-     (and (or (not lisp-p)
-	      (file-directory-p (expand-file-name "lisp" dir)))
-	  (or (file-directory-p (expand-file-name "lib-src" dir))
-	      (file-directory-p (expand-file-name system-configuration dir)))
-	  dir)
-     ;;
-     ;; If the parent of this directory is a plausible root, use it.
-     ;; (But don't do so recursively!)
-     ;;
-     (and (or (not lisp-p)
-	      (file-directory-p (expand-file-name "../lisp" dir)))
-	  (or (file-directory-p (expand-file-name
-				 (format "../%s" system-configuration)
-				 dir))
-	      (file-directory-p (expand-file-name "../lib-src" dir)))
-	  (expand-file-name "../" dir))
-
-     ;; 
-     ;; (--run-in-place) Same thing, but from one directory level deeper.
-     ;;
-     (and (or (not lisp-p)
-	      (file-directory-p (expand-file-name "../../lisp" dir)))
-	  (or (file-directory-p (expand-file-name
-				 (format "../%s" system-configuration)
-				 dir))
-	      (file-directory-p 
-	       (expand-file-name 
-		(format "../../lib-src/%s" system-configuration) dir)))
-	  (expand-file-name "../.." dir))
-
-     ;; If ../lib/xemacs-<version> exists check it.
-     ;; This is of the form "xemacs-19.10/" or "xemacs-19.10-b7/".
-     ;;
-     (let ((ver-dir (concat "../" (startup-make-version-dir))))
-       (and (or (not lisp-p)
-		(file-directory-p (expand-file-name
-				   (format "%s/lisp" ver-dir)
-				   dir)))
-	    (or (file-directory-p (expand-file-name
-				   (format "%s/%s" ver-dir
-					   system-configuration)
-				   dir))
-		(file-directory-p (expand-file-name
-				   (format "%s/lib-src" ver-dir)
-				   dir)))
-	    (expand-file-name (file-name-as-directory ver-dir) dir)))
-     ;;
-     ;; Same thing, but one higher: ../../lib/xemacs-<version>.
-     ;;
-     (let ((ver-dir (concat "../../" (startup-make-version-dir))))
-       (and (or (not lisp-p)
-		(file-directory-p (expand-file-name
-				   (format "%s/lisp" ver-dir)
-				   dir)))
-	    (or (file-directory-p (expand-file-name
-				   (format "%s/%s" ver-dir
-					   system-configuration)
-				   dir))
-		(file-directory-p (expand-file-name
-				   (format "%s/lib-src" ver-dir)
-				   dir)))
-	    (expand-file-name (file-name-as-directory ver-dir) dir)))
-     ;;
-     ;; If that doesn't work, and the XEmacs executable is a symlink, then
-     ;; chase the link and try again there.
-     ;;
-     (and (setq path (file-symlink-p path))
-	  (find-emacs-root-internal-1 (expand-file-name path dir) lisp-p))
-     ;;
-     ;; Otherwise, this directory just doesn't cut it.
-     ;; Some bozos think they can use the 18.59 lisp directory with 19.*.
-     ;; This is because they're not using their brains.  But it might be
-     ;; nice to notice that that is happening and point them in the
-     ;; general direction of a clue.
-     ;;
-     nil)))
-
-(defun find-emacs-root-internal (path)
-  ;;  (send-string-to-terminal (format "FINDING ROOT FOR %S\n" path))
-  ;; first look for lisp and lib-src; then just look for lib-src.
-  ;; XEmacs can run (kind of) if the lisp directory is omitted, which
-  ;; some people might want to do for space reasons.
-  (or (find-emacs-root-internal-1 path t)
-      ;; (find-emacs-root-internal-1 path nil)
-      ;; If we don't succeed we are going to crash and burn for sure.
-      ;; Try some paths relative to prefix-directory if it isn't nil.
-      ;; This is definitely necessary in cases such as when we're used
-      ;; as a login shell since we can't determine the invocation
-      ;; directory in that case.
-
-      (find-emacs-root-internal-1
-       (format "%s/bin/%s" prefix-directory invocation-name) t)
-      (find-emacs-root-internal-1
-       (format "%s/bin/%s" prefix-directory invocation-name) nil)
-      (find-emacs-root-internal-1
-       (format "%s/lib/%s" prefix-directory invocation-name) t)
-      (find-emacs-root-internal-1
-       (format "%s/lib/%s" prefix-directory invocation-name) nil)
-
-      ;; We're desperate -- try the prefix-directory correctly.
-      (find-emacs-root-internal-1
-       (format "%s/%s/foo" prefix-directory (startup-make-version-dir)) t)
-      (find-emacs-root-internal-1
-       (format "%s/%s/foo" prefix-directory (startup-make-version-dir)) nil)
-      ))
-
-(defun set-default-load-path ()
+(defun startup-set-invocation-environment ()
   ;; XEmacs -- Steven Baur says invocation directory is nil if you
   ;; try to use XEmacs as a login shell.
   (or invocation-directory (setq invocation-directory default-directory))
   (setq invocation-directory
 	;; don't let /tmp_mnt/... get into the load-path or exec-path.
-	(abbreviate-file-name invocation-directory))
+	(abbreviate-file-name invocation-directory)))
+
+(defun startup-setup-paths (roots &optional inhibit-packages inhibit-site-lisp)
+  "Setup all the various paths.
+ROOTS is a list of plausible roots of the XEmacs directory hierarchy.
+If INHIBIT-PACKAGES is non-NIL, don't do packages.
+If INHIBIT-SITE-LISP is non-NIL, don't do site-lisp.
+It's idempotent, so call this as often as you like!"
+
+  (setq package-path (packages-find-package-path roots))
 
-  ;; #### FSFmacs recognizes environment vars EMACSLOCKDIR, etc.
-  (let* ((root (find-emacs-root-internal (concat invocation-directory
-						 invocation-name)))
-	 (lisp (and root
-		    (let ((f (expand-file-name "lisp" root)))
-		      (and (file-directory-p f) f))))
-	 (site-lisp
-	  (and root
-	       (or
-		(let ((f (expand-file-name "xemacs/site-lisp" root)))
-		  (and (file-directory-p f) f))
-		(let ((f (expand-file-name "../xemacs/site-lisp" root)))
-		  (and (file-directory-p f) f))
-		;; the next two are for --run-in-place
-		(let ((f (expand-file-name "site-lisp" root)))
-		  (and (file-directory-p f) f))
-		(let ((f (expand-file-name "lisp/site-lisp" root)))
-		  (and (file-directory-p f) f))
-		)))
-	 (lib-src
-	  (and root
-	       (or
-		(let ((f (expand-file-name
-			  (concat "lib-src/" system-configuration)
-			  root)))
-		  (and (file-directory-p f) f))
-		(let ((f (expand-file-name "lib-src" root)))
-		  (and (file-directory-p f) f))
-		(let ((f (expand-file-name system-configuration root)))
-		  (and (file-directory-p f) f)))))
-	 (etc
-	  (and root
-	       (let ((f (expand-file-name "etc" root)))
-		 (and (file-directory-p f) f))))
-	 (info
-	  (and root
-	       (let ((f (expand-file-name "info" root)))
-		 (and (file-directory-p f) (file-name-as-directory f)))))
-	 (packages
-	  (and root
-	       (let ((f (expand-file-name "packages" root)))
-		 (and (file-directory-p f) (file-name-as-directory f)))))
-	 (lock
-	  (and root
-	       (boundp 'lock-directory)
-	       (if (and lock-directory (file-directory-p lock-directory))
-		   (file-name-as-directory lock-directory)
-		 (or
-		  (let ((f (expand-file-name "xemacs/lock" root)))
-		    (and (file-directory-p f)
-			 (file-name-as-directory f)))
-		  (let ((f (expand-file-name "../xemacs/lock" root)))
-		    (and (file-directory-p f)
-			 (file-name-as-directory f)))
-		  (let ((f (expand-file-name "lock" root)))
-		    (and (file-directory-p f)
-			 (file-name-as-directory f)))
-		  ;; if none of them exist, make the "guess" be
-		  ;; the one that set-default-load-path-warning
-		  ;; will suggest.
-		  (file-name-as-directory
-		   (expand-file-name "../xemacs/lock" root))
-		  )))))
-    
-    ;; 1996/12/6 by MORIOKA Tomohiko <morioka@jaist.ac.jp>
-    ;;	define `default-load-path' for file-detect.el
-    (setq default-load-path load-path)
+  (let ((stuff (packages-find-packages package-path inhibit-packages)))
+    (setq early-packages (car stuff))
+    (setq late-packages (cdr stuff)))
+
+  (setq early-package-load-path (packages-find-package-load-path early-packages))
+  (setq late-package-load-path (packages-find-package-load-path late-packages))
 
-    ;; add site-lisp dir to load-path
-    (when site-lisp
-      ;; If the site-lisp dir isn't on the load-path, add it to the end.
-      (or (member site-lisp load-path)
-	  (setq load-path (append load-path
-				  (list (file-name-as-directory site-lisp)))))
-      ;; Also add any direct subdirectories of the site-lisp directory
-      ;; to the load-path.  But don't add dirs whose names begin
-      ;; with dot or hyphen.
-      (let ((files (directory-files site-lisp nil "^[^-.]" nil 'dirs-only))
-	    file)
-	(while files
-	  (setq file (car files))
-	  (if (and (not (member file '("RCS" "CVS" "SCCS")))
-		   (setq file (expand-file-name file site-lisp))
-		   (not (member file load-path)))
-	      (setq load-path
-		    (nconc load-path
-			   (list (file-name-as-directory file)))))
-	  (setq files (cdr files)))))
+  (setq load-path (paths-construct-load-path roots
+					     early-package-load-path
+					     late-package-load-path
+					     inhibit-site-lisp))
+
+  (setq info-path (paths-construct-info-path roots early-packages late-packages))
 
-    ;; add lisp dir to load-path
-    (when lisp
-      ;; If the lisp dir isn't on the load-path, add it to the end.
-      (or (member lisp load-path)
-	  (setq load-path (append load-path
-				  (list (file-name-as-directory lisp)))))
-      ;; Also add any direct subdirectories of the lisp directory
-      ;; to the load-path.  But don't add dirs whose names begin
-      ;; with dot or hyphen.
-      (let ((files (directory-files lisp nil "^[^-.]" nil 'dirs-only))
-	    file)
-	(while files
-	  (setq file (car files))
-	  (when (and (not (member file '("RCS" "CVS" "SCCS")))
-		     (setq file (expand-file-name file lisp))
-		     (not (member file load-path)))
-	    (setq load-path
-		  (nconc load-path
-			 (list (file-name-as-directory file)))))
-	  (setq files (cdr files)))))
+  (if (boundp 'lock-directory)
+      (progn
+	(setq lock-directory (paths-find-lock-directory roots))
+	(setq superlock-file (paths-find-superlock-file lock-directory))))
 
-    ;; 1996/12/6 by MORIOKA Tomohiko <morioka@jaist.ac.jp>
-    ;;	define `default-load-path' for file-detect.el
-    (setq default-load-path
-	  (append default-load-path
-		  (if site-lisp
-		      (list site-lisp))
-		  (if lisp
-		      (list lisp)
-		    )
-		  ))
+  (setq exec-directory (paths-find-exec-directory roots))
 
-    ;; 1997/03/06 by Jeff Miller <jmiller@bayserve.net>
-    ;; initialize 'site-directory'.  This is the site-lisp dir used by 
-    ;; XEmacs
-    (if site-lisp
-	(setq site-directory (file-name-as-directory site-lisp))
-      )
-    ;; If running from the build directory, always prefer the exec-directory
-    ;; that is here over to the one that came from paths.h.
-    (when (or (and (null exec-directory) lib-src)
-	      (and (string= lib-src (expand-file-name "lib-src" root))
-		   (not (string= exec-directory lib-src))))
-      (setq exec-directory (file-name-as-directory lib-src)))
-    (when (or (and (null doc-directory) lib-src)
-	      (and (string= lib-src (expand-file-name "lib-src" root))
-		   (not (string= doc-directory lib-src))))
-      (setq doc-directory (file-name-as-directory lib-src)))
+  (setq exec-path (paths-construct-exec-path roots exec-directory
+					     early-packages late-packages))
 
-    (when exec-directory
-      (or (member exec-directory exec-path)
-	  (setq exec-path (append exec-path (list exec-directory)))))
-    (when (or (and (null data-directory) etc)
-	      (and (string= etc (expand-file-name "etc" root))
-		   (not (string= data-directory etc))))
-      (setq data-directory (file-name-as-directory etc)))
+  (setq doc-directory (paths-find-doc-directory roots))
 
-    ;; If `configure' specified an info dir, use it.
-    ;; #### The above comment is suspect.
-    (or (boundp 'Info-default-directory-list)
-	(setq Info-default-directory-list nil))
-
-    ;; Add additional system directories.
-    (setq Info-default-directory-list
-	  (append Info-default-directory-list
-		  (split-string infopath-internal ":")))
+  (setq data-directory (paths-find-data-directory roots))
 
-    (let ((infopath (getenv "INFOPATH")))
-      (when infopath
-	(setq Info-default-directory-list
-	      (append Info-default-directory-list
-		      (split-string infopath ":")))))
-
-    (cond (configure-info-directory
-	   (setq configure-info-directory (file-name-as-directory
-					   configure-info-directory))
-	   (or (member configure-info-directory Info-default-directory-list)
-	       (setq Info-default-directory-list
-		     (append (list configure-info-directory)
-			     Info-default-directory-list)))))
-    ;; If we've guessed the info dir, use that (too).
-    (when (and info (not (member info Info-default-directory-list)))
-      (setq Info-default-directory-list
-	    (append (list info) Info-default-directory-list)))
+  (setq data-directory-list (paths-construct-data-directory-list data-directory
+								 early-packages
+								 late-packages)))
 
-    ;; Default the lock dir to being a sibling of the data-directory.
-    ;; If superlock isn't set, or is set to a file in a nonexistent
-    ;; directory, derive it from the lock dir.
-    (when (boundp 'lock-directory)
-      (setq lock-directory lock)
-      (cond ((null lock-directory)
-	     (setq superlock-file nil))
-	    ((or (null superlock-file)
-		 (not (file-directory-p
-		       (file-name-directory superlock-file))))
-	     (setq superlock-file
-		   (expand-file-name "!!!SuperLock!!!"
-				     lock-directory)))))
-
-    (set-default-load-path-warning)
-    (when (and (null (running-temacs-p))
-	       data-directory
-	       Info-default-directory-list)
-      (setq data-directory-list (list data-directory))
-      (packages-find-packages package-path nil))))
-
-
-(defun set-default-load-path-warning ()
+(defun startup-setup-paths-warning ()
   (let ((lock (if (boundp 'lock-directory) lock-directory 't))
-	warnings message guess)
-    (when (and (stringp lock) (not (file-directory-p lock)))
-      (setq lock nil))
+	warnings message)
+    (if (and (stringp lock) (null (file-directory-p lock)))
+	(setq lock nil))
     (cond
-     ((not (and exec-directory data-directory doc-directory load-path lock))
+     ((null (and exec-directory data-directory doc-directory load-path lock))
       (save-excursion
 	(set-buffer (get-buffer-create " *warning-tmp*"))
 	(erase-buffer)
 	(buffer-disable-undo (current-buffer))
-	(when (null lock)           (push "lock-directory" warnings))
-	(when (null exec-directory) (push "exec-directory" warnings))
-	(when (null data-directory) (push "data-directory" warnings))
-	(when (null doc-directory)  (push "doc-directory"  warnings))
-	(when (null load-path)      (push "load-path"      warnings))
+	(if (null lock)           (push "lock-directory" warnings))
+	(if (null exec-directory) (push "exec-directory" warnings))
+	(if (null data-directory) (push "data-directory" warnings))
+	(if (null doc-directory)  (push "doc-directory"  warnings))
+	(if (null load-path)      (push "load-path"      warnings))
 	(cond ((cdr (cdr warnings))
 	       (setq message (apply 'format "%s, %s, and %s" warnings)))
 	      ((cdr warnings)
@@ -1393,83 +1074,11 @@
 		"or the XEmacs executable, " (concat invocation-directory
 						     invocation-name)
 		" is in a strange place?")
-	(setq guess (or exec-directory
-			data-directory
-			doc-directory
-			(car load-path)
-			(and (string-match "/[^/]+\\'" invocation-directory)
-			     (substring invocation-directory 0
-					(match-beginning 0)))))
-	(when (and guess
-		   (or
-		    ;; parent of a terminal bin/<configuration> pair (hack hack).
-		    (string-match (concat "/bin/"
-					  (regexp-quote system-configuration)
-					  "/?\\'")
-				  guess)
-		    ;; parent of terminal src, lib-src, etc, or lisp dir.
-		    (string-match
-		     "/\\(bin\\|src\\|lib-src\\|etc\\|lisp\\)[^/]*/?\\'"
-		     guess)))
-	  (setq guess (substring guess 0 (match-beginning 0))))
 
-	;; If neither the exec nor lisp dirs are around, then "guess" that
-	;; the new configure-style lib dir should be used.  Otherwise, if
-	;; only one of them appears to be missing, or it's just lock,
-	;; then guess it to be a sibling of whatever already exists.
-	(when (and (null exec-directory) (null load-path))
-	  (setq guess (expand-file-name (startup-make-version-dir) guess)))
-
-	(when (or (null exec-directory) (null load-path))
-	  (insert
-	   "\n\nWithout both exec-directory and load-path, XEmacs will "
-	   "be very broken.  "))
-	(when (and (null exec-directory) guess)
-	  (insert
-	   "Consider making a symbolic link from "
-	   (expand-file-name system-configuration guess)
-	   " to wherever the appropriate XEmacs exec-directory "
-	   "directory is"))
-	(when (and (null data-directory) guess)
-	  (insert
-	   (if exec-directory
-	       "\n\nConsider making a symbolic link " ", and ")
-	   "from "
-	   (expand-file-name "etc" (if load-path
-				       (file-name-directory
-					(directory-file-name
-					 (car load-path)))
-				     guess))
-	   " to wherever the appropriate XEmacs data-directory is"))
-	(when (and (null load-path) guess)
-	  (insert
-	   (if (and exec-directory data-directory)
-	       "Consider making a symbolic link "
-	     ", and ")
-	   "from "
-	   (expand-file-name "lisp" guess)
-	   " to wherever the appropriate XEmacs lisp library is"))
-	(insert ".")
-
-	(when (null lock)
-	  (insert
-	   "\n\nWithout lock-directory set, file locking won't work.  ")
-	  (when guess
-	    (insert
-	     "Consider creating "
-	     (expand-file-name "../xemacs/lock"
-			       (or (find-emacs-root-internal
-				    (concat invocation-directory
-					    invocation-name))
-				   guess))
-	     " as a directory or symbolic link for use as the lock "
-	     "directory.  (This directory must be globally writable.)"
-	     )))
-
-	(when (fboundp 'fill-region)
-	  ;; Might not be bound in the cold load environment...
-	  (let ((fill-column 76))
-	    (fill-region (point-min) (point-max))))
+	(if (fboundp 'fill-region)
+	    ;; Might not be bound in the cold load environment...
+	    (let ((fill-column 76))
+	      (fill-region (point-min) (point-max))))
 	(goto-char (point-min))
 	(princ "\nWARNING:\n" 'external-debugging-output)
 	(princ (buffer-string) 'external-debugging-output)