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"))))
(defun fancy-splash-tail (&optional startup)
(insert "\n\n")))))
(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
(fancy-splash-insert :face `(variable-pitch :foreground ,fg)
"\nThis is "
(emacs-version)
"\n"
:face '(variable-pitch :height 0.5)
emacs-copyright
"\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,74 +1394,102 @@ 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
(let ((frame (fancy-splash-frame)))
(save-selected-window
(select-frame frame)
(switch-to-buffer "*About GNU Emacs*")
(setq buffer-undo-list t
mode-line-format (propertize "---- %b %-"
'face 'mode-line-buffer-id))
(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-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)
(goto-char (point-min))
(force-mode-line-update))
(use-local-map splash-screen-keymap)
(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))))
(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)
(switch-to-buffer "*About GNU Emacs*")
(setq buffer-undo-list t
mode-line-format (propertize "---- %b %-"
'face 'mode-line-buffer-id))
(let ((inhibit-read-only t))
(erase-buffer)
(if pure-space-overflow
(insert pure-space-overflow-message))
(fancy-splash-head)
(dolist (text fancy-about-text)
(apply #'fancy-splash-insert text)
(insert "\n"))
(unless (current-message)
(message fancy-splash-help-echo))
(set-buffer-modified-p nil)
(goto-char (point-min))
(force-mode-line-update))
(use-local-map splash-screen-keymap)
(setq tab-width 22)
(message "%s" (startup-echo-area-message))
(setq buffer-read-only t)
(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,267 +1907,273 @@ 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))
(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.
;;
;; ;; The directories listed in --directory/-L options will *appear*
;; ;; at the front of `load-path' in the order they appear on the
;; ;; command-line. We cannot do this by *placing* them at the front
;; ;; in the order they appear, so we need this variable to hold them,
;; ;; temporarily.
;; extra-load-path
;;
;; To DTRT we keep track of the splice point and modify `load-path'
;; straight away upon any --directory/-L option.
splice
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") ("--no-splash")
("--find-file") ("--visit") ("--file") ("--no-desktop"))
(mapcar (lambda (elt)
(list (concat "-" (car elt))))
command-switch-alist)))
(line 0)
(column 0))
;; Add the long X options to longopts.
(dolist (tem command-line-x-option-alist)
(if (string-match "^--" (car tem))
(push (list (car tem)) longopts)))
;; Loop, processing options.
(while command-line-args-left
(let* ((argi (car command-line-args-left))
(orig-argi argi)
argval completion)
(setq command-line-args-left (cdr command-line-args-left))
;; Do preliminary decoding of the option.
(if just-files
;; After --, don't look for options; treat all args as files.
(setq argi "")
;; Convert long options to ordinary options
;; and separate out an attached option argument into argval.
(when (string-match "^\\(--[^=]*\\)=" argi)
(setq argval (substring argi (match-end 0))
argi (match-string 1 argi)))
(if (equal argi "--")
(setq completion nil)
(setq completion (try-completion argi longopts)))
(if (eq completion t)
(setq argi (substring argi 1))
(if (stringp completion)
(let ((elt (assoc completion longopts)))
(or elt
(error "Option `%s' is ambiguous" argi))
(setq argi (substring (car elt) 1)))
(setq argval nil
argi orig-argi))))
;; Execute the option.
(cond ((setq tem (assoc argi command-switch-alist))
(if argval
(let ((command-line-args-left
(cons argval command-line-args-left)))
(funcall (cdr tem) argi))
(funcall (cdr tem) argi)))
((equal argi "-no-splash")
(setq inhibit-startup-message t))
((member argi '("-f" ; what the manual claims
"-funcall"
"-e")) ; what the source used to say
(setq tem (intern (or argval (pop command-line-args-left))))
(if (commandp tem)
(command-execute tem)
(funcall tem)))
((member argi '("-eval" "-execute"))
(eval (read (or argval (pop command-line-args-left)))))
((member argi '("-L" "-directory"))
(setq tem (expand-file-name
(command-line-normalize-file-name
(or argval (pop command-line-args-left)))))
(cond (splice (setcdr splice (cons tem (cdr splice)))
(setq splice (cdr splice)))
(t (setq load-path (cons tem load-path)
splice load-path))))
((member argi '("-l" "-load"))
(let* ((file (command-line-normalize-file-name
(or argval (pop command-line-args-left))))
;; Take file from default dir if it exists there;
;; otherwise let `load' search for it.
(file-ex (expand-file-name file)))
(when (file-exists-p file-ex)
(setq file file-ex))
(load file nil t)))
;; This is used to handle -script. It's not clear
;; we need to document it.
((member argi '("-scriptload"))
(let* ((file (command-line-normalize-file-name
(or argval (pop command-line-args-left))))
;; Take file from default dir.
(file-ex (expand-file-name file)))
(load file-ex nil t t)))
((equal argi "-insert")
(setq tem (or argval (pop command-line-args-left)))
(or (stringp tem)
(error "File name omitted from `-insert' option"))
(insert-file-contents (command-line-normalize-file-name tem)))
((equal argi "-kill")
(kill-emacs t))
;; This is for when they use --no-desktop with -q, or
;; don't load Desktop in their .emacs. If desktop.el
;; _is_ loaded, it will handle this switch, and we
;; won't see it by the time we get here.
((equal argi "-no-desktop")
(message "\"--no-desktop\" ignored because the Desktop package is not loaded"))
((string-match "^\\+[0-9]+\\'" argi)
(setq line (string-to-number argi)))
((string-match "^\\+\\([0-9]+\\):\\([0-9]+\\)\\'" argi)
(setq line (string-to-number (match-string 1 argi))
column (string-to-number (match-string 2 argi))))
((setq tem (assoc argi command-line-x-option-alist))
;; Ignore X-windows options and their args if not using X.
(setq command-line-args-left
(nthcdr (nth 1 tem) command-line-args-left)))
((member argi '("-find-file" "-file" "-visit"))
;; An explicit option to specify visiting a file.
(setq tem (or argval (pop command-line-args-left)))
(unless (stringp tem)
(error "File name omitted from `%s' option" argi))
(setq file-count (1+ file-count))
(let ((file (expand-file-name
(command-line-normalize-file-name tem) dir)))
(if (= file-count 1)
(setq first-file-buffer (find-file file))
(find-file-other-window file)))
(or (zerop line)
(goto-line line))
(setq line 0)
(unless (< column 1)
(move-to-column (1- column)))
(setq column 0))
((equal argi "--")
(setq just-files t))
(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
(did-hook nil))
(while (and hooks
(not (setq did-hook (funcall (car hooks)))))
(setq hooks (cdr hooks)))
(if (not did-hook)
;; Presume that the argument is a file name.
(progn
(if (string-match "\\`-" argi)
(error "Unknown option `%s'" argi))
(setq file-count (1+ file-count))
(let ((file
(expand-file-name
(command-line-normalize-file-name orig-argi)
dir)))
(if (= file-count 1)
(setq first-file-buffer (find-file file))
(find-file-other-window file)))
(or (zerop line)
(goto-line line))
(setq line 0)
(unless (< column 1)
(move-to-column (1- column)))
(setq column 0))))))
;; In unusual circumstances, the execution of Lisp code due
;; 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-star