xemacs-beta: lisp/startup.el comparison

comparison lisp/startup.el @ 398:74fd4e045ea6 r21-2-29

Import from CVS: tag r21-2-29

author	cvs
date	Mon, 13 Aug 2007 11:13:30 +0200
parents	6719134a07c2
children	2f8bb876ab1d

comparison

equal deleted inserted replaced

-:f4aeb21a5bad
+:74fd4e045ea6
 ;;; Commentary:
 ;; This file is dumped with XEmacs.
 ;; -batch, -t, and -nw are processed by main() in emacs.c and are
 ;; never seen by lisp code.
 ;; -version and -help are special-cased as well: they imply -batch,
 ;; but are left on the list for lisp code to process.
 "Major mode command symbol to use for the initial *scratch* buffer.")
 (defvar emacs-roots nil
 "List of plausible roots of the XEmacs hierarchy.")
-(defvar init-file-user nil
+(defvar user-init-directory-base ".xemacs"
-"Identity of user whose `.emacs' file is or was read.
+"Base of directory where user-installed init files may go.")
-The value is nil if no init file is being used; otherwise, it may be either
-the null string, meaning that the init file was taken from the user that
+(defvar user-init-file-base-list (append
-originally logged in, or it may be a string containing a user's name.
+				  '(".emacs.elc" ".emacs.el" ".emacs")
+				  (and (eq system-type 'windows-nt)
-In either of the latter cases, `(concat \"~\" init-file-user \"/\")'
+				       '("_emacs.elc" "_emacs.el" "_emacs")))
-evaluates to the name of the directory in which the `.emacs' file was
+"List of allowed init files.  The first one found takes precedence.")
-searched for.
+(defvar user-init-directory
-Setting `init-file-user' does not prevent Emacs from loading
+(file-name-as-directory
-`site-start.el'.  The only way to do that is to use `--no-site-file'.")
+(paths-construct-path (list "~" user-init-directory-base)))
+"Directory where user-installed init files may go.")
+(defvar load-user-init-file-p t
+"Non-nil if XEmacs should load the user's init file.")
 ;; #### called `site-run-file' in FSFmacs
 (defvar site-start-file (purecopy "site-start")
 "File containing site-wide run-time initializations.
 "Print the XEmacs usage message and exit."
 (let ((standard-output 'external-debugging-output))
 (princ (concat "\n" (emacs-version) "\n\n"))
 (princ
 (if (featurep 'x)
-	 (concat (emacs-name)
+	 (concat "When creating a window on an X display, "
-		 " accepts all standard X Toolkit command line options.\n"
+		 (emacs-name)
-		 "In addition, the")
+		 " accepts all standard X Toolkit
+command line options plus the following:
+-iconname <title>     Use title as the icon name.
+-mc <color>           Use color as the mouse color.
+-cr <color>           Use color as the text-cursor foregound color.
+-private              Install a private colormap.
+In addition, the")
 "The"))
 (princ " following options are accepted:
 -t <device>           Use TTY <device> instead of the terminal for input
 and output.  This implies the -nw option.
 -nw                   Inhibit the use of any window-system-specific
 display code: use the current tty.
 -batch                Execute noninteractively (messages go to stderr).
 -no-early-packages	Do not process early packages.
 -no-autoloads		Do not load global symbol files (auto-autoloads) at
 			startup.  Also implies `-vanilla'.
 -vanilla		Equivalent to -q -no-site-file -no-early-packages.
 -q                    Same as -no-init-file.
+-user-init-file <file> Use <file> as init file.
+-user-init-directory <directory> use <directory> as init directory.
 -user <user>          Load user's init file instead of your own.
+Equivalent to -user-init-file ~<user>/.emacs
+-user-init-directory ~<user>/.xemacs/
 -u <user>             Same as -user.\n")
 (let ((l command-switch-alist)
 	  (insert (lambda (&rest x)
 		    (princ "  ")
 		    (let ((len 2))
 			   (and (getenv "EMACSDEBUGPATHS")
 				t))))
 (setq emacs-roots (paths-find-emacs-roots invocation-directory
 						invocation-name))
 (if debug-paths
 	  (princ (format "emacs-roots:\n%S\n" emacs-roots)
 		 'external-debugging-output))
 (if (null emacs-roots)
 	  (startup-find-roots-warning)
 	(startup-setup-paths emacs-roots
+			     user-init-directory
 			     inhibit-early-packages
 			     inhibit-site-lisp
 			     debug-paths))
 (startup-setup-paths-warning))
 (if (and (not inhibit-autoloads)
 	     lisp-directory)
 	(load (expand-file-name (file-name-sans-extension autoload-file-name)
 				lisp-directory) nil t))
 (if (not inhibit-autoloads)
 	(progn
 	  (if (not inhibit-early-packages)
 	      (packages-load-package-auto-autoloads early-package-load-path))
 	  (packages-load-package-auto-autoloads late-package-load-path)
 ;;		   (and (not (equal string "")) string))
 ;;		 (let ((string (getenv "LANG")))
 ;;		   (and (not (equal string "")) string)))))
 ;;	(and ctype
 ;;	     (string-match iso-8859-1-locale-regexp ctype)))
 ;;      (progn
 ;;	(standard-display-european t)
 ;;	(require 'iso-syntax)))
-;; Figure out which user's init file to load,
+(setq load-user-init-file-p (not (noninteractive)))
-;; either from the environment or from the options.
-(setq init-file-user (if (noninteractive) nil (user-login-name)))
-;; If user has not done su, use current $HOME to find .emacs.
-(and init-file-user (string= init-file-user (user-real-login-name))
-(setq init-file-user ""))
 ;; Allow (at least) these arguments anywhere in the command line
 (let ((new-args nil)
 	(arg      nil))
 (while args
 (setq arg (pop args))
 (cond
 ((or (string= arg "-q")
 	    (string= arg "-no-init-file"))
-	(setq init-file-user nil))
+	(setq load-user-init-file-p nil))
 ((string= arg "-no-site-file")
 	(setq site-start-file nil))
 ((or (string= arg "-no-early-packages")
 	    (string= arg "--no-early-packages"))
 	(setq inhibit-early-packages t))
 ((or (string= arg "-vanilla")
 	    (string= arg "--vanilla")
 	    ;; Some work on this one already done in emacs.c.
 	    (string= arg "-no-autoloads")
 	    (string= arg "--no-autoloads"))
-	(setq init-file-user nil
+	(setq load-user-init-file-p nil
 	      site-start-file nil))
+((string= arg "-user-init-file")
+	(setq user-init-file (pop args)))
+((string= arg "-user-init-directory")
+	(setq user-init-directory (file-name-as-directory (pop args))))
 ((or (string= arg "-u")
 	    (string= arg "-user"))
-	(setq init-file-user (pop args)))
+	(let* ((user (pop args))
+	       (home-user (concat "~" user)))
+	  (setq user-init-file (find-user-init-file home-user)
+		user-init-directory (file-name-as-directory
+				     (paths-construct-path
+				      (list home-user user-init-directory-base))))))
 ((string= arg "-debug-init")
 	(setq init-file-debug t))
 ((string= arg "-unmapped")
 	(setq initial-frame-unmapped-p t))
 ((or (string= arg "-debug-paths")
 	t)
 ((or (string= arg "--") (string= arg "-"))
 	(while args
 	  (push (pop args) new-args)))
 (t (push arg new-args))))
+(setq init-file-user (and load-user-init-file-p ""))
 (nreverse new-args)))
 (defconst initial-scratch-message "\
 ;; This buffer is for notes you don't want to save, and for Lisp evaluation.
 ;; If you want to create a file, first visit that file with C-x C-f,
 ;; When not in batch mode, this creates the first visible frame,
 ;; and deletes the stdio device.
 (frame-initialize))
+;; Reinitialize faces if necessary.  This function changes face if
+;; it is created during auto-autoloads loading.  Otherwise, it
+;; does nothing.
+(startup-initialize-custom-faces)
 ;;
 ;; We have normality, I repeat, we have normality.  Anything you still
 ;; can't cope with is therefore your own problem.  (And we don't need
 ;; to kill XEmacs for it.)
 ;;
 ;;; Load init files.
 (load-init-file)
 (with-current-buffer (get-buffer "*scratch*")
 (erase-buffer)
 ;; (insert initial-scratch-message)
 (set-buffer-modified-p nil)
 (when (eq major-mode 'fundamental-mode)
 ;; until after the splash screen.
 (setq inhibit-warning-display nil)
 ;; If -batch, terminate after processing the command options.
 (when (noninteractive) (kill-emacs t))))
 (defun load-terminal-library ()
 (when term-file-prefix
 (let ((term (getenv "TERM"))
 	  hyphend)
 (while (and term
 		  (not (load (concat term-file-prefix term) t t)))
 	;; Strip off last hyphen and what follows, then try again
 	(if (setq hyphend (string-match "[-_][^-_]+\\'" term))
 	    (setq term (substring term 0 hyphend))
 	  (setq term nil))))))
-(defconst user-init-directory "/.xemacs/"
+(defun find-user-init-file (&optional directory)
-"Directory where user-installed packages may go.")
+"Determine the user's init file."
-(define-obsolete-variable-alias
+(unless directory
-'emacs-user-extension-dir
+(setq directory "~"))
-'user-init-directory)
+(dolist (file user-init-file-base-list)
+(let ((expanded (paths-construct-path (list directory file))))
-(defun load-user-init-file (init-file-user)
+(when (file-exists-p expanded)
+	(return expanded)))))
+(defun load-user-init-file ()
 "This function actually reads the init file, .emacs."
-(when init-file-user
+(if (not user-init-file)
-;; purge references to init.el and options.el
+(setq user-init-file (find-user-init-file)))
-;; convert these to use paths-construct-path for eventual migration to init.el
+(load user-init-file t t t)
-;; needs to be converted when idiom for constructing "~user" paths is created
+(unless inhibit-default-init
-;    (setq user-init-file
+(let ((inhibit-startup-message nil))
-;	  (paths-construct-path (list (concat "~" init-file-user)
+;; Users are supposed to be told their rights.
-;				      user-init-directory
+;; (Plus how to get help and how to undo.)
-;				      "init.el")))
+;; Don't you dare turn this off for anyone except yourself.
-;    (unless (file-exists-p (expand-file-name user-init-file))
+(load "default" t t))))
-(setq user-init-file
-	  (paths-construct-path (list (concat "~" init-file-user)
-				      (cond
-				       ((eq system-type 'ms-dos) "_emacs")
-				       (t ".emacs")))))
-;    )
-(load user-init-file t t t)
-;; This should not be loaded since custom stuff currently goes into .emacs
-;    (let ((default-custom-file
-;	    (paths-construct-path (list (concat "~" init-file-user)
-;				        user-init-directory
-;				        "options.el")))
-;      (when (string= custom-file default-custom-file)
-;	(load default-custom-file t t)))
-(unless inhibit-default-init
-(let ((inhibit-startup-message nil))
-	;; Users are supposed to be told their rights.
-	;; (Plus how to get help and how to undo.)
-	;; Don't you dare turn this off for anyone except yourself.
-	(load "default" t t)))))
 ;;; Load user's init file and default ones.
 (defun load-init-file ()
 (run-hooks 'before-init-hook)
 (let (debug-on-error-from-init-file
 	debug-on-error-should-be-set
 	(debug-on-error-initial
 	 (if (eq init-file-debug t) 'startup init-file-debug)))
 (let ((debug-on-error debug-on-error-initial))
-(if init-file-debug
+(if (and load-user-init-file-p init-file-debug)
 	  ;; Do this without a condition-case if the user wants to debug.
-	  (load-user-init-file init-file-user)
+	  (load-user-init-file)
 	(condition-case error
 	    (progn
-	      (load-user-init-file init-file-user)
+	      (if load-user-init-file-p
+		  (load-user-init-file))
 	      (setq init-file-had-error nil))
 (error
 	   (message "Error in init file: %s" (error-message-string error))
 	   (display-warning 'initialization
 	     (format "\
 	 ;; This is worthless; the `unixoid' way is "./file". -jwz
 	 ((or (string= arg "-") (string= arg "--"))
 	  (setq end-of-options t))
 	 (t
 	  (setq file-p t)))
 	(when file-p
 	  (setq file-p nil)
 	  (incf file-count)
 	  (setq arg (expand-file-name arg dir))
 	  (cond
 	     (let ((map e)
 		   (overriding-local-map (indirect-function e)))
 	       (setq e (read-key-sequence
 			(let ((p (keymap-prompt map t)))
 			  (cond ((symbolp map)
 				 (if p
 				     (format "%s %s " map p)
 				   (format "%s " map)))
 				(p)
 				(t
 				 (prin1-to-string map))))))
 (error "WTF!?"))))
 (defun startup-center-spaces (glyph)
 ;; Return the number of spaces to insert in order to center
 ;; the given glyph (may be a string or a pixmap).
 ;; Assume spaces are as wide as avg-pixwidth.
 ;; Won't be quite right for proportional fonts, but it's the best we can do.
 ;; Maybe the new redisplay will export something a glyph-width function.
 ;;; #### Yes, there is a glyph-width function but it isn't quite what
 ;;; #### this was expecting.  Or is it?
 ;; (An alternate way to get avg-pixwidth would be to use x-font-properties
 ;; and calculate RESOLUTION_X * AVERAGE_WIDTH / 722.7, but it's no better.)
 ;; This function is used in about.el too.
 (let* ((avg-pixwidth     (round (/ (frame-pixel-width) (frame-width))))
 	 (fill-area-width  (* avg-pixwidth (- fill-column left-margin)))
 	 (glyph-pixwidth   (cond ((stringp glyph)
 				  (* avg-pixwidth (length glyph)))
 				 ;; #### the pixmap option should be removed
 				 ;;((pixmapp glyph)
 				 ;; (pixmap-width glyph))
 				 ((glyphp glyph)
 "Please visit the XEmacs website at http://www.xemacs.org !\n\n"
 ,@(if (featurep 'sparcworks)
 	   `( "\
 Sun provides support for the WorkShop/XEmacs integration package only.
 All other XEmacs packages are provided to you \"AS IS\".\n"
 	      ,@(let ((lang (or (getenv "LC_ALL") (getenv "LC_MESSAGES")
 				(getenv "LANG"))))
 		  (if (and
 		       (not (featurep 'mule)) ;; Already got mule?
 		       ;; No Mule support on tty's yet
 		       (not (eq 'tty (console-type)))
 		       lang ;; Non-English locale?
 		       (not (string= lang "C"))
 		       (not (string-match "^en" lang))
 		       ;; Comes with Sun WorkShop
 		       (locate-file "xemacs-mule" exec-path))
 This version of XEmacs has been built with support for Latin-1 languages only.
 To handle other languages you need to run a Multi-lingual (`Mule') version of
 XEmacs, by either running the command `xemacs-mule', or by using the X resource
 `ESERVE*defaultXEmacsPath: xemacs-mule' when starting XEmacs from Sun WorkShop.
 \n")))))
 ((key describe-no-warranty)
 ": "(face (red bold) "XEmacs comes with ABSOLUTELY NO WARRANTY\n"))
 ((key describe-copying)
 ": conditions to give out copies of XEmacs\n")
 ((key describe-distribution)
 ": how to get the latest version\n")
 "\n--\n"
 (face italic "\
-Copyright (C) 1985-1998 Free Software Foundation, Inc.
+Copyright (C) 1985-1999 Free Software Foundation, Inc.
 Copyright (C) 1990-1994 Lucid, Inc.
 Copyright (C) 1993-1997 Sun Microsystems, Inc. All Rights Reserved.
 Copyright (C) 1994-1996 Board of Trustees, University of Illinois
 Copyright (C) 1995-1996 Ben Wing\n"))
 ((face (blue bold underline) "\nInformation, on-line help:\n\n")
 "XEmacs comes with plenty of documentation...\n\n"
 ,@(if (string-match "beta" emacs-version)
 	   `((key describe-beta)
 	     ": " (face (red bold)
 			"This is an Experimental version of XEmacs.\n"))
 	 `( "\n"))
 ((key xemacs-local-faq)
 ": read the XEmacs FAQ (a " (face underline "capital") " F!)\n")
 ((key help-command)
 ": get help on using XEmacs (also available through the "
 (face bold "Help") " menu)\n")
 ((key info) ": read the on-line documentation\n\n")
 ((key describe-project) ": read about the GNU project\n")
-((key about-xemacs) ": see who's developping XEmacs\n"))
+((key about-xemacs) ": see who's developing XEmacs\n"))
 ((face (blue bold underline) "\nUseful stuff:\n\n")
 "Things that you should know rather quickly...\n\n"
 ((key find-file) ": visit a file\n")
 ((key save-buffer) ": save changes\n")
 ;; I really hate global variables, oh well.
 ;(defvar xemacs-startup-logo-function nil
 ;  "If non-nil, function called to provide the startup logo.
 ;This function should return an initialized glyph if it is used.")
-;; This will hopefully go away when gettext is functionnal.
+;; This will hopefully go away when gettext is functional.
 (defconst splash-frame-static-body
 `(,(emacs-version) "\n\n"
 (face italic "`C-' means the control key,`M-' means the meta key\n\n")))
 	    (if (= indice (- (length elements) 1))
 		0
 	      (1+ indice )))
 )))
-;; ### This function now returns the (possibly nil) timeout circulating the
+;; #### This function now returns the (possibly nil) timeout circulating the
 ;; splash-frame elements
 (defun display-splash-frame ()
 (let ((logo xemacs-logo)
 	(buffer-read-only nil)
 (cramped-p (eq 'tty (console-type))))
 (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)))
-(defun startup-setup-paths (roots &optional
+(defun startup-setup-paths (roots user-init-directory
+				  &optional
 				  inhibit-early-packages inhibit-site-lisp
 				  debug-paths)
 "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.
 (apply #'(lambda (early late last)
 	     (setq early-packages (and (not inhibit-early-packages)
 				       early))
 	     (setq late-packages late)
 	     (setq last-packages last))
-	 (packages-find-packages roots))
+	 (packages-find-packages
+	  roots
+	  (packages-compute-package-locations user-init-directory)))
 (setq early-package-load-path (packages-find-package-load-path early-packages))
 (setq late-package-load-path (packages-find-package-load-path late-packages))
 (setq last-package-load-path (packages-find-package-load-path last-packages))
 (setq Info-directory-list
 	(paths-construct-info-path roots
 				   early-packages late-packages last-packages))
 (if debug-paths
 (princ (format "Info-directory-list:\n%S\n" Info-directory-list)
 	     'external-debugging-output))
 (if (boundp 'lock-directory)
 (progn
 	(setq lock-directory (paths-find-lock-directory roots))
 	(setq superlock-file (paths-find-superlock-file lock-directory))
 	(if debug-paths
 	    (progn
 	      (princ (format "lock-directory:\n%S\n" lock-directory)
 		     'external-debugging-output)
 	      (princ (format "superlock-file:\n%S\n" superlock-file)
 				   early-packages late-packages last-packages))
 (if debug-paths
 (princ (format "exec-path:\n%S\n" exec-path)
 	     'external-debugging-output))
 (setq doc-directory (paths-find-doc-directory roots))
 (if debug-paths
 (princ (format "doc-directory:\n%S\n" doc-directory)
 	     'external-debugging-output))

Mercurial > hg > xemacs-beta

comparison lisp/startup.el @ 398:74fd4e045ea6 r21-2-29