comparison lisp/startup.el @ 31759:85e162a05e58

(fancy-splash-head): If frame's background mode is `dark', change the black background of the image to gray. (fancy-splash-screens): Display startup echo area message. (display-startup-echo-area-message): New function. (command-line-1): Use it.

31758:c991844cbf4d

  :version "21.1"
  :group 'initialization)


(defcustom fancy-splash-delay 5
  "Delay in seconds between splash screens."
  :group 'fancy-splash-screen
  :type 'integer)


(defcustom fancy-splash-image "splash.xpm"
  "The image to show in the splash screens."
  :group 'fancy-splash-screen
  :type 'file)


(defun fancy-splash-insert (&rest args)

	 (window-width (window-width (selected-window))))
    (when img
      (when (> window-width image-width)
	(let ((pos (/ (- window-width image-width) 2)))
	  (insert (propertize " " 'display `(space :align-to ,pos))))
	(insert-image img)
	(insert "\n"))))
  (when (eq system-type 'gnu/linux)
    (fancy-splash-insert
     :face '(variable-pitch :foreground "red")

	      (while (and texts (not stop))
		(erase-buffer)
		(fancy-splash-head)
		(apply #'fancy-splash-insert (car texts))
		(fancy-splash-tail)
		(goto-char (point-min))
		(set-buffer-modified-p nil)
		(force-mode-line-update)
		(setq texts (cdr texts))
		(setq stop (not (sit-for fancy-splash-delay)))))))
      (setq cursor-type old-cursor-type))
    (erase-buffer)))


(defun command-line-1 (command-line-args-left)
  (or noninteractive (input-pending-p) init-file-had-error
      (and inhibit-startup-echo-area-message
	   user-init-file
	   (or (and (get 'inhibit-startup-echo-area-message 'saved-value)
		    (equal inhibit-startup-echo-area-message
			   (if (string= init-file-user "")
			       (user-login-name)
			     init-file-user)))
	       ;; Wasn't set with custom; see if .emacs has a setq.
	       (let ((buffer (get-buffer-create " *temp*")))
		 (prog1
		     (condition-case nil
			 (save-excursion
			   (set-buffer buffer)
			   (insert-file-contents user-init-file)
			   (re-search-forward
			    (concat
			     "([ \t\n]*setq[ \t\n]+"
			     "inhibit-startup-echo-area-message[ \t\n]+"
			     (regexp-quote
			      (prin1-to-string
			       (if (string= init-file-user "")
				   (user-login-name)
				 init-file-user)))
			     "[ \t\n]*)")
			    nil t))
		       (error nil))
		   (kill-buffer buffer)))))
      (message (if (eq (key-binding "\C-h\C-p") 'describe-project)
		   "For information about the GNU Project and its goals, type C-h C-p."
		 (substitute-command-keys
		  "For information about the GNU Project and its goals, type \\[describe-project]."))))
  (if (null command-line-args-left)
      (cond ((and (not inhibit-startup-message) (not noninteractive)
		  ;; Don't clobber a non-scratch buffer if init file
		  ;; has selected it.
		  (string= (buffer-name) "*scratch*"))

\(Non)Warranty		GNU Emacs comes with ABSOLUTELY NO WARRANTY
Copying Conditions	Conditions for redistributing and changing Emacs.
Getting New Versions	How to obtain the latest version of Emacs.
")
			       (insert "\n\n" (emacs-version)
				     "
Copyright (C) 2000 Free Software Foundation, Inc.")))
			 ;; If keys have their default meanings,
			 ;; use precomputed string to save lots of time.
			 (if (and (eq (key-binding "\C-h") 'help-command)
				  (eq (key-binding "\C-xu") 'advertised-undo)

			     (insert "
Activate menubar   F10  or  ESC `  or   M-`")
			   (insert (substitute-command-keys "
Activate menubar     \\[tmm-menubar]")))

		       ;; Windows and MSDOS (currently) do not count as
		       ;; window systems, but do have mouse support.
			 (if window-system
			     (insert "
Mode-specific menu   C-mouse-3 (third button, with CTRL)"))
			 ;; Many users seem to have problems with these.
			 (insert "

	(sit-for 2))
    (let ((dir command-line-default-directory)
	  (file-count 0)
	  first-file-buffer
	  tem
	  just-files  ;; t if this follows the magic -- option.
	  ;; This includes our standard options' long versions
	  ;; and long versions of what's on command-switch-alist.
	  (longopts
	   (append '(("--funcall") ("--load") ("--insert") ("--kill")
		     ("--directory") ("--eval") ("--execute")

		     (let ((command-line-args-left
			    (cons argval command-line-args-left)))
		       (funcall (cdr tem) argi))
		   (funcall (cdr tem) argi)))
		
		((or (string-equal argi "-f")  ;what the manual claims
		     (string-equal argi "-funcall")
		     (string-equal argi "-e")) ; what the source used to say
		 (if argval
		     (setq tem (intern argval))
		   (setq tem (intern (car command-line-args-left)))

	   (not noninteractive)
	   (or (get-buffer-window first-file-buffer)
	       (progn (other-window 1)
		      (buffer-menu)))))))

(defun command-line-normalize-file-name (file)
  "Collapse multiple slashes to one, to handle non-Emacs file names."
  (save-match-data
    ;; Use arg 1 so that we don't collapse // at the start of the file name.
    ;; That is significant on some systems.

31759:85e162a05e58

  :version "21.1"
  :group 'initialization)


(defcustom fancy-splash-delay 5
  "*Delay in seconds between splash screens."
  :group 'fancy-splash-screen
  :type 'integer)


(defcustom fancy-splash-image "splash.xpm"
  "*The image to show in the splash screens."
  :group 'fancy-splash-screen
  :type 'file)


(defun fancy-splash-insert (&rest args)

	 (window-width (window-width (selected-window))))
    (when img
      (when (> window-width image-width)
	(let ((pos (/ (- window-width image-width) 2)))
	  (insert (propertize " " 'display `(space :align-to ,pos))))
	(when (eq (frame-parameter nil 'background-mode) 'dark)
	  (setq img (append img '(:color-symbols (("#000000" . "gray"))))))
	(insert-image img)
	(insert "\n"))))
  (when (eq system-type 'gnu/linux)
    (fancy-splash-insert
     :face '(variable-pitch :foreground "red")

	      (while (and texts (not stop))
		(erase-buffer)
		(fancy-splash-head)
		(apply #'fancy-splash-insert (car texts))
		(fancy-splash-tail)
		(display-startup-echo-area-message)
		(goto-char (point-min))
		(set-buffer-modified-p nil)
		(force-mode-line-update)
		(setq texts (cdr texts))
		(setq stop (not (sit-for fancy-splash-delay)))))))
      (setq cursor-type old-cursor-type))
    (erase-buffer)))


(defun display-startup-echo-area-message ()
  (message (if (eq (key-binding "\C-h\C-p") 'describe-project)
	       "For information about the GNU Project and its goals, type C-h C-p."
	     (substitute-command-keys
	      "For information about the GNU Project and its goals, type \\[describe-project]."))))

(defun command-line-1 (command-line-args-left)
  (or noninteractive (input-pending-p) init-file-had-error
	(and inhibit-startup-echo-area-message
	     user-init-file
	     (or (and (get 'inhibit-startup-echo-area-message 'saved-value)
		      (equal inhibit-startup-echo-area-message
			     (if (string= init-file-user "")
				 (user-login-name)
			       init-file-user)))
		 ;; Wasn't set with custom; see if .emacs has a setq.
		 (let ((buffer (get-buffer-create " *temp*")))
		   (prog1
		       (condition-case nil
			   (save-excursion
			     (set-buffer buffer)
			     (insert-file-contents user-init-file)
			     (re-search-forward
			      (concat
			       "([ \t\n]*setq[ \t\n]+"
			       "inhibit-startup-echo-area-message[ \t\n]+"
			       (regexp-quote
				(prin1-to-string
				 (if (string= init-file-user "")
				     (user-login-name)
				   init-file-user)))
			       "[ \t\n]*)")
			      nil t))
			 (error nil))
		     (kill-buffer buffer)))))
	(display-startup-echo-area-message))
  (if (null command-line-args-left)
      (cond ((and (not inhibit-startup-message) (not noninteractive)
		  ;; Don't clobber a non-scratch buffer if init file
		  ;; has selected it.
		  (string= (buffer-name) "*scratch*"))

\(Non)Warranty		GNU Emacs comes with ABSOLUTELY NO WARRANTY
Copying Conditions	Conditions for redistributing and changing Emacs.
Getting New Versions	How to obtain the latest version of Emacs.
")
			       (insert "\n\n" (emacs-version)
				       "
Copyright (C) 2000 Free Software Foundation, Inc.")))
			 ;; If keys have their default meanings,
			 ;; use precomputed string to save lots of time.
			 (if (and (eq (key-binding "\C-h") 'help-command)
				  (eq (key-binding "\C-xu") 'advertised-undo)

			     (insert "
Activate menubar   F10  or  ESC `  or   M-`")
			   (insert (substitute-command-keys "
Activate menubar     \\[tmm-menubar]")))

			 ;; Windows and MSDOS (currently) do not count as
			 ;; window systems, but do have mouse support.
			 (if window-system
			     (insert "
Mode-specific menu   C-mouse-3 (third button, with CTRL)"))
			 ;; Many users seem to have problems with these.
			 (insert "

	(sit-for 2))
    (let ((dir command-line-default-directory)
	  (file-count 0)
	  first-file-buffer
	  tem
	  just-files;; t if this follows the magic -- option.
	  ;; This includes our standard options' long versions
	  ;; and long versions of what's on command-switch-alist.
	  (longopts
	   (append '(("--funcall") ("--load") ("--insert") ("--kill")
		     ("--directory") ("--eval") ("--execute")

		     (let ((command-line-args-left
			    (cons argval command-line-args-left)))
		       (funcall (cdr tem) argi))
		   (funcall (cdr tem) argi)))
		
		((or (string-equal argi "-f") ;what the manual claims
		     (string-equal argi "-funcall")
		     (string-equal argi "-e")) ; what the source used to say
		 (if argval
		     (setq tem (intern argval))
		   (setq tem (intern (car command-line-args-left)))

	   (not noninteractive)
	   (or (get-buffer-window first-file-buffer)
	       (progn (other-window 1)
		      (buffer-menu)))))))


(defun command-line-normalize-file-name (file)
  "Collapse multiple slashes to one, to handle non-Emacs file names."
  (save-match-data
    ;; Use arg 1 so that we don't collapse // at the start of the file name.
    ;; That is significant on some systems.