Commit 22a58255 authored by Chong Yidong's avatar Chong Yidong
Browse files

(startup-screen-inhibit-startup-screen)

(pure-space-overflow-message): New vars.
(fancy-splash-insert): Allow functions for face and link specs.
(fancy-splash-head): Remove unused arg.  Move splash text...
(fancy-startup-text, fancy-about-text): ...here.
(fancy-startup-tail): Rename from fancy-splash-tail.
(fancy-startup-screen, fancy-about-screen): Split off from
fancy-splash-screens.
(display-startup-screen): New function.
(display-about-screen): Rename from display-splash-screen.
(command-line-1): Use concise startup screen if necessary.
parent 6794a919
......@@ -72,6 +72,8 @@ you are familiar with the contents of the startup screen."
(defvaralias 'inhibit-splash-screen 'inhibit-startup-screen)
(defvaralias 'inhibit-startup-message 'inhibit-startup-screen)
(defvar startup-screen-inhibit-startup-screen nil)
(defcustom inhibit-startup-echo-area-message nil
"*Non-nil inhibits the initial startup echo area message.
Setting this variable takes effect
......@@ -316,6 +318,10 @@ from being initialized."
(defvar pure-space-overflow nil
"Non-nil if building Emacs overflowed pure space.")
(defvar pure-space-overflow-message "\
Warning Warning!!! Pure space overflow !!!Warning Warning
\(See the node Pure Storage in the Lisp manual for details.)\n")
(defvar tutorial-directory nil
"Directory containing the Emacs TUTORIAL files.")
......@@ -1136,9 +1142,21 @@ regardless of the value of this variable."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar fancy-startup-text
'((:face variable-pitch
'((:face '(variable-pitch :foreground "red")
"Welcome to "
:link ("GNU Emacs" (lambda (button) (browse-url "http://www.gnu.org/software/emacs/")))
", one component of the "
:link
(lambda ()
(if (eq system-type 'gnu/linux)
'("GNU/Linux" (lambda (button) (browse-url "http://www.gnu.org/gnu/linux-and-gnu.html")))
'("GNU" (lambda (button) (describe-project)))))
" operating system.\n"
:face 'variable-pitch "To quit a partially entered command, type "
:face 'default "Control-g"
:face 'variable-pitch ".\n\n"
:link ("Emacs Tutorial" (lambda (button) (help-with-tutorial)))
"\tLearn basic Emacs keystroke commands"
"\tLearn basic keystroke commands"
(lambda ()
(let* ((en "TUTORIAL")
(tut (or (get-language-info current-language-environment
......@@ -1169,25 +1187,35 @@ regardless of the value of this variable."
:face variable-pitch
:link ("Copying Conditions" (lambda (button) (describe-copying)))
"\tConditions for redistributing and changing Emacs\n"
:link ("More Manuals / Ordering" (lambda (button) (view-order-manuals)))
"\tThe FSF sells printed copies of several manuals for Emacs\n"
"\n"
"To start... "
:link ("Open a File"
(lambda (button) (call-interactively 'find-file)))
" "
:link ("Open Home Directory"
(lambda (button) (dired "~")))
" "
:link ("Customize Startup"
(lambda (button) (customize-group 'initialization)))
:link ("Ordering Manuals" (lambda (button) (view-order-manuals)))
"\tPurchasing printed copies of manuals\n"
"\n"))
"A list of texts to show in the middle part of splash screens.
Each element in the list should be a list of strings or pairs
`:face FACE', like `fancy-splash-insert' accepts them.")
(defvar fancy-about-text
'((:face variable-pitch
'((:face '(variable-pitch :foreground "red")
"This is "
:link ("GNU Emacs" (lambda (button) (browse-url "http://www.gnu.org/software/emacs/")))
", one component of the "
:link
(lambda ()
(if (eq system-type 'gnu/linux)
'("GNU/Linux" (lambda (button) (browse-url "http://www.gnu.org/gnu/linux-and-gnu.html")))
'("GNU" (lambda (button) (describe-project)))))
" operating system.\n"
:face (lambda ()
(list 'variable-pitch :foreground
(if (eq (frame-parameter nil 'background-mode) 'dark)
"cyan" "darkblue")))
"\n"
(lambda () (emacs-version))
"\n"
:face '(variable-pitch :height 0.5)
(lambda () emacs-copyright)
"\n\n"
:face variable-pitch
:link ("Authors"
(lambda (button)
(view-file (expand-file-name "AUTHORS" data-directory))
......@@ -1269,17 +1297,25 @@ Each element in the list should be a list of strings or pairs
(defun fancy-splash-insert (&rest args)
"Insert text into the current buffer, with faces.
Arguments from ARGS should be either strings, functions called
with no args that return a string, or pairs `:face FACE',
where FACE is a valid face specification, as it can be used with
`put-text-property'."
Arguments from ARGS should be either strings; functions called
with no args that return a string; pairs `:face FACE', where FACE
is a face specification usable with `put-text-property'; or pairs
`:link LINK' where LINK is a list of arguments to pass to
`insert-button', of the form (LABEL ACTION), which specifies the
button's label and `action' property. FACE and LINK can also be
functions, which are evaluated to obtain a face or button
specification."
(let ((current-face nil))
(while args
(cond ((eq (car args) :face)
(setq args (cdr args) current-face (car args)))
(setq args (cdr args) current-face (car args))
(if (functionp current-face)
(setq current-face (funcall current-face))))
((eq (car args) :link)
(setq args (cdr args))
(let ((spec (car args)))
(if (functionp spec)
(setq spec (funcall spec)))
(insert-button (car spec)
'face (list 'link current-face)
'action (cadr spec)
......@@ -1293,7 +1329,7 @@ where FACE is a valid face specification, as it can be used with
(setq args (cdr args)))))
(defun fancy-splash-head (&optional startup)
(defun fancy-splash-head ()
"Insert the head part of the splash screen into the current buffer."
(let* ((image-file (cond ((stringp fancy-splash-image)
fancy-splash-image)
......@@ -1325,55 +1361,20 @@ where FACE is a valid face specification, as it can be used with
'help-echo "mouse-2: browse http://www.gnu.org/"
'action (lambda (button) (browse-url "http://www.gnu.org/"))
'follow-link t)
(insert "\n"))))
(insert "\n")
(fancy-splash-insert
:face '(variable-pitch :foreground "red")
(if startup "Welcome to " "This is ")
:link
'("GNU Emacs" (lambda (button) (browse-url "http://www.gnu.org/software/emacs/")))
", one component of the "
:link
(if (eq system-type 'gnu/linux)
'("GNU/Linux" (lambda (button) (browse-url "http://www.gnu.org/gnu/linux-and-gnu.html")))
'("GNU" (lambda (button) (describe-project))))
" operating system.\n")
(if startup
(fancy-splash-insert
:face 'variable-pitch
"You can do basic editing with the menu bar and scroll bar \
using the mouse.\n"
:face 'variable-pitch
"To quit a partially entered command, type "
:face 'default
"Control-g"
:face 'variable-pitch
"."
"\n\n")
(let ((fg (if (eq (frame-parameter nil 'background-mode) 'dark)
"cyan" "darkblue")))
(fancy-splash-insert :face `(variable-pitch :foreground ,fg)
"\n"
(emacs-version)
"\n"
:face '(variable-pitch :height 0.5)
emacs-copyright
"\n\n"))))
(insert "\n\n")))))
(defun fancy-splash-tail (&optional startup)
(defun fancy-startup-tail ()
"Insert the tail part of the splash screen into the current buffer."
(let ((fg (if (eq (frame-parameter nil 'background-mode) 'dark)
"cyan" "darkblue")))
(if startup
(fancy-splash-insert :face `(variable-pitch :foreground ,fg)
"\nThis is "
(emacs-version)
"\n"
:face '(variable-pitch :height 0.5)
emacs-copyright
"\n"))
(and startup
auto-save-list-file-prefix
"\n")
(and auto-save-list-file-prefix
;; Don't signal an error if the
;; directory for auto-save-list files
;; does not yet exist.
......@@ -1393,19 +1394,77 @@ using the mouse.\n"
"Meta-x recover-session RET"
:face '(variable-pitch :foreground "red")
"\nto recover"
" the files you were editing.\n"))))
" the files you were editing."))
(fancy-splash-insert
:face 'variable-pitch "\n\n"
:link '("Dismiss" (lambda (button)
(when startup-screen-inhibit-startup-screen
(customize-set-variable 'inhibit-splash-screen t)
(customize-mark-to-save 'inhibit-splash-screen)
(custom-save-all))
(let ((w (get-buffer-window "*GNU Emacs*")))
(and w (not (one-window-p)) (delete-window w)))
(kill-buffer "*GNU Emacs*")))
" ")
(when (or user-init-file custom-file)
(let ((checked (create-image "\300\300\141\143\067\076\034\030"
'xbm t :width 8 :height 8 :background "grey75"
:foreground "black" :relief -2 :ascent 'center))
(unchecked (create-image (make-string 8 0)
'xbm t :width 8 :height 8 :background "grey75"
:foreground "black" :relief -2 :ascent 'center)))
(insert-button
" " :on-glyph checked :off-glyph unchecked 'checked nil
'display unchecked 'follow-link t
'action (lambda (button)
(if (overlay-get button 'checked)
(progn (overlay-put button 'checked nil)
(overlay-put button 'display (overlay-get button :off-glyph))
(setq startup-screen-inhibit-startup-screen nil))
(overlay-put button 'checked t)
(overlay-put button 'display (overlay-get button :on-glyph))
(setq startup-screen-inhibit-startup-screen t)))))
(fancy-splash-insert :face '(variable-pitch :height 0.9)
" Don't show this message again."))))
(defun exit-splash-screen ()
"Stop displaying the splash screen buffer."
(interactive)
(quit-window t))
(defun fancy-splash-screens (&optional startup)
"Display fancy splash screens.
If optional argument STARTUP is non-nil, display the startup screen
after Emacs starts. If STARTUP is nil, display the About screen."
(if (not startup)
;; Display About screen
(defun fancy-startup-screen (concise)
"Display fancy startup screen.
If CONCISE is non-nil, display a concise version of the splash
screen."
(if (or (window-minibuffer-p)
(window-dedicated-p (selected-window)))
(pop-to-buffer (current-buffer))
(switch-to-buffer "*GNU Emacs*"))
(let ((inhibit-read-only t))
(erase-buffer)
(make-local-variable 'startup-screen-inhibit-startup-screen)
(if pure-space-overflow
(insert pure-space-overflow-message))
(unless concise
(fancy-splash-head))
(dolist (text fancy-startup-text)
(apply #'fancy-splash-insert text)
(insert "\n"))
(skip-chars-backward "\n")
(delete-region (point) (point-max))
(insert "\n")
(fancy-startup-tail))
(use-local-map splash-screen-keymap)
(setq tab-width 22)
(set-buffer-modified-p nil)
(setq buffer-read-only t)
(if (and view-read-only (not view-mode))
(view-mode-enter nil 'kill-buffer))
(goto-char (point-min)))
(defun fancy-about-screen ()
"Display fancy About screen."
(let ((frame (fancy-splash-frame)))
(save-selected-window
(select-frame frame)
......@@ -1416,14 +1475,11 @@ after Emacs starts. If STARTUP is nil, display the About screen."
(let ((inhibit-read-only t))
(erase-buffer)
(if pure-space-overflow
(insert "\
Warning Warning!!! Pure space overflow !!!Warning Warning
\(See the node Pure Storage in the Lisp manual for details.)\n"))
(fancy-splash-head startup)
(insert pure-space-overflow-message))
(fancy-splash-head)
(dolist (text fancy-about-text)
(apply #'fancy-splash-insert text)
(insert "\n"))
(fancy-splash-tail startup)
(unless (current-message)
(message fancy-splash-help-echo))
(set-buffer-modified-p nil)
......@@ -1433,34 +1489,7 @@ Warning Warning!!! Pure space overflow !!!Warning Warning
(setq tab-width 22)
(message "%s" (startup-echo-area-message))
(setq buffer-read-only t)
(goto-char (point-min))))
;; If startup is non-nil, display startup fancy splash screen.
(if (or (window-minibuffer-p)
(window-dedicated-p (selected-window)))
(pop-to-buffer (current-buffer))
(switch-to-buffer "*GNU Emacs*"))
(let ((inhibit-read-only t))
(erase-buffer)
(if pure-space-overflow
(insert "\
Warning Warning!!! Pure space overflow !!!Warning Warning
\(See the node Pure Storage in the Lisp manual for details.)\n"))
(fancy-splash-head startup)
(dolist (text fancy-startup-text)
(apply #'fancy-splash-insert text)
(insert "\n"))
(skip-chars-backward "\n")
(delete-region (point) (point-max))
(insert "\n")
(fancy-splash-tail startup))
(use-local-map splash-screen-keymap)
(setq tab-width 22)
(set-buffer-modified-p nil)
(setq buffer-read-only t)
(if (and view-read-only (not view-mode))
(view-mode-enter nil 'kill-buffer))
(goto-char (point-min))))
(goto-char (point-min)))))
(defun fancy-splash-frame ()
"Return the frame to use for the fancy splash screen.
......@@ -1508,16 +1537,12 @@ after Emacs starts. If STARTUP is nil, display the About screen."
(propertize "---- %b %-" 'face 'mode-line-buffer-id)))
(if pure-space-overflow
(insert "\
Warning Warning!!! Pure space overflow !!!Warning Warning
\(See the node Pure Storage in the Lisp manual for details.)\n"))
(insert pure-space-overflow-message))
;; The convention for this piece of code is that
;; each piece of output starts with one or two newlines
;; and does not end with any newlines.
(if startup
(insert "Welcome to GNU Emacs")
(insert "This is GNU Emacs"))
(insert (if startup "Welcome to GNU Emacs" "This is GNU Emacs"))
(insert
(if (eq system-type 'gnu/linux)
", one component of the GNU/Linux operating system.\n"
......@@ -1843,21 +1868,29 @@ Type \\[describe-distribution] for information on "))
(kill-buffer buffer)))))
(message "%s" (startup-echo-area-message)))))
(defun display-startup-screen (concise)
"Display startup screen according to display.
A fancy display is used on graphic displays, normal otherwise.
(defun display-splash-screen (&optional startup)
"Display splash screen according to display.
Fancy splash screens are used on graphic displays, normal otherwise.
If optional argument STARTUP is non-nil, display the startup screen
after Emacs starts. If STARTUP is nil, display the About screen."
(interactive "P")
If CONCISE is non-nil, display a concise version of the startup
screen."
;; Prevent recursive calls from server-process-filter.
(if (not (get-buffer "*About GNU Emacs*"))
(if (use-fancy-splash-screens-p)
(fancy-splash-screens startup)
(normal-splash-screen startup))))
(fancy-startup-screen concise)
(normal-splash-screen t))))
(defun display-about-screen ()
"Display the *About GNU Emacs* buffer.
A fancy display is used on graphic displays, normal otherwise."
(interactive)
(if (not (get-buffer "*About GNU Emacs*"))
(if (use-fancy-splash-screens-p)
(fancy-about-screen)
(normal-splash-screen nil))))
(defalias 'about-emacs 'display-splash-screen)
(defalias 'about-emacs 'display-about-screen)
(defalias 'display-splash 'display-about-screen)
(defun command-line-1 (command-line-args-left)
(display-startup-echo-area-message)
......@@ -1874,11 +1907,11 @@ after Emacs starts. If STARTUP is nil, display the About screen."
"Building Emacs overflowed pure space. (See the node Pure Storage in the Lisp manual for details.)"
:warning))
(let ((file-count 0)
first-file-buffer)
(when command-line-args-left
;; We have command args; process them.
(let ((dir command-line-default-directory)
(file-count 0)
first-file-buffer
tem
;; This approach loses for "-batch -L DIR --eval "(require foo)",
;; if foo is intended to be found in DIR.
......@@ -2041,7 +2074,7 @@ after Emacs starts. If STARTUP is nil, display the About screen."
(t
;; We have almost exhausted our options. See if the
;; user has made any other command-line options available
(let ((hooks command-line-functions) ;; lrs 7/31/89
(let ((hooks command-line-functions)
(did-hook nil))
(while (and hooks
(not (setq did-hook (funcall (car hooks)))))
......@@ -2069,15 +2102,7 @@ after Emacs starts. If STARTUP is nil, display the About screen."
;; to command-line options can cause the last visible frame
;; to be deleted. In this case, kill emacs to avoid an
;; abort later.
(unless (frame-live-p (selected-frame)) (kill-emacs nil))))
;; If 3 or more files visited, and not all visible,
;; show user what they all are. But leave the last one current.
(and (> file-count 2)
(not noninteractive)
(not inhibit-startup-buffer-menu)
(or (get-buffer-window first-file-buffer)
(list-buffers)))))
(unless (frame-live-p (selected-frame)) (kill-emacs nil))))))
(when initial-buffer-choice
(cond ((eq initial-buffer-choice t)
......@@ -2085,11 +2110,19 @@ after Emacs starts. If STARTUP is nil, display the About screen."
((stringp initial-buffer-choice)
(find-file initial-buffer-choice))))
;; Maybe display a startup screen.
(unless (or inhibit-startup-message
(if (or inhibit-splash-screen
initial-buffer-choice
noninteractive
emacs-quick-startup)
;; Not displaying a startup screen. If 3 or more files
;; visited, and not all visible, show user what they all are.
(and (> file-count 2)
(not noninteractive)
(not inhibit-startup-buffer-menu)
(or (get-buffer-window first-file-buffer)
(list-buffers)))
;; Display a startup screen, after some preparations.
;; If there are no switches to process, we might as well
......@@ -2130,11 +2163,17 @@ after Emacs starts. If STARTUP is nil, display the About screen."
(insert initial-scratch-message)
(set-buffer-modified-p nil))))
;; If user typed input during all that work,
;; abort the startup screen. Otherwise, display it now.
(unless (input-pending-p)
(display-splash-screen t))))
(cond ((= file-count 0)
(display-startup-screen nil))
((or (= file-count 1) inhibit-startup-buffer-menu)
(let ((buf (current-buffer))
(first-window (get-buffer-window first-file-buffer)))
(if first-window (select-window first-window))
(display-startup-screen t)
(display-buffer buf)))
(t
(display-startup-screen t)
(display-buffer (list-buffers-noselect)))))))
(defun command-line-normalize-file-name (file)
"Collapse multiple slashes to one, to handle non-Emacs file names."
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment