Mercurial > emacs
changeset 79366:9c6165181df8
Backport startup screen related changes from the trunk.
| author | Juri Linkov <juri@jurta.org> |
|---|---|
| date | Sat, 10 Nov 2007 21:18:48 +0000 |
| parents | 329636cf01af |
| children | e11b8c88390e |
| files | lisp/startup.el |
| diffstat | 1 files changed, 871 insertions(+), 705 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/startup.el Sat Nov 10 03:06:45 2007 +0000 +++ b/lisp/startup.el Sat Nov 10 21:18:48 2007 +0000 @@ -38,9 +38,9 @@ (defgroup initialization nil "Emacs start-up procedure." - :group 'internal) + :group 'environment) -(defcustom inhibit-splash-screen nil +(defcustom inhibit-startup-screen nil "Non-nil inhibits the startup screen. It also inhibits display of the initial message in the `*scratch*' buffer. @@ -49,7 +49,10 @@ :type 'boolean :group 'initialization) -(defvaralias 'inhibit-startup-message 'inhibit-splash-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. @@ -295,6 +298,10 @@ (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") + (defun normal-top-level-add-subdirs-to-load-path () "Add all subdirectories of current directory to `load-path'. More precisely, this uses only the subdirectories whose names @@ -823,8 +830,8 @@ (load site-run-file t t)) ;; Sites should not disable this. Only individuals should disable - ;; the startup message. - (setq inhibit-startup-message nil) + ;; the startup screen. + (setq inhibit-startup-screen nil) ;; Warn for invalid user name. (when init-file-user @@ -918,7 +925,7 @@ (setq user-init-file source)))) (unless inhibit-default-init - (let ((inhibit-startup-message nil)) + (let ((inhibit-startup-screen 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 @@ -1117,7 +1124,7 @@ ") "Initial message displayed in *scratch* buffer at startup. If this is nil, no message will be displayed. -If `inhibit-splash-screen' is non-nil, then no message is displayed, +If `inhibit-startup-screen' is non-nil, then no message is displayed, regardless of the value of this variable." :type '(choice (text :tag "Message") (const :tag "none" nil)) @@ -1128,65 +1135,131 @@ ;;; Fancy splash screen ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar fancy-splash-text - '((:face (variable-pitch :weight bold) - "Important Help menu items:\n" - :face variable-pitch - (lambda () - (let* ((en "TUTORIAL") - (tut (or (get-language-info current-language-environment - 'tutorial) - en)) - (title (with-temp-buffer - (insert-file-contents - (expand-file-name tut data-directory) - nil 0 256) - (search-forward ".") - (buffer-substring (point-min) (1- (point)))))) - ;; If there is a specific tutorial for the current language - ;; environment and it is not English, append its title. - (concat - "Emacs Tutorial\t\tLearn how to use Emacs efficiently" - (if (string= en tut) - "" - (concat " (" title ")")) - "\n"))) - :face variable-pitch "\ -Emacs FAQ\t\tFrequently asked questions and answers -View Emacs Manual\t\tView the Emacs manual using Info -Absence of Warranty\tGNU Emacs comes with " - :face (variable-pitch :slant oblique) - "ABSOLUTELY NO WARRANTY\n" - :face variable-pitch - "\ -Copying Conditions\t\tConditions for redistributing and changing Emacs -Getting New Versions\tHow to obtain the latest version of Emacs -More Manuals / Ordering Manuals Buying printed manuals from the FSF\n") - (:face variable-pitch - "\nTo quit a partially entered command, type " - :face default - "Control-g" - :face variable-pitch - ". +(defvar fancy-startup-text + '((:face (variable-pitch :foreground "red") + "Welcome to " + :link ("GNU Emacs" + (lambda (button) (browse-url "http://www.gnu.org/software/emacs/")) + "Browse 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")) + "Browse http://www.gnu.org/gnu/linux-and-gnu.html") + '("GNU" (lambda (button) (describe-project)) + "Display info on the GNU 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 keystroke commands" + (lambda () + (let* ((en "TUTORIAL") + (tut (or (get-language-info current-language-environment + 'tutorial) + en)) + (title (with-temp-buffer + (insert-file-contents + (expand-file-name tut data-directory) + nil 0 256) + (search-forward ".") + (buffer-substring (point-min) (1- (point)))))) + ;; If there is a specific tutorial for the current language + ;; environment and it is not English, append its title. + (if (string= en tut) + "" + (concat " (" title ")")))) + "\n" + :face variable-pitch + :link ("Emacs Guided Tour" + (lambda (button) (browse-url "http://www.gnu.org/software/emacs/tour/")) + "Browse http://www.gnu.org/software/emacs/tour/") + "\tOverview of Emacs features\n" + :link ("View Emacs Manual" (lambda (button) (info-emacs-manual))) + "\tView the Emacs manual using Info\n" + :link ("Absence of Warranty" (lambda (button) (describe-no-warranty))) + "\tGNU Emacs comes with " + :face (variable-pitch :slant oblique) + "ABSOLUTELY NO WARRANTY\n" + :face variable-pitch + :link ("Copying Conditions" (lambda (button) (describe-copying))) + "\tConditions for redistributing and changing Emacs\n" + :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.") -Emacs Guided Tour\t\tSee http://www.gnu.org/software/emacs/tour/ - -" - :face (variable-pitch :weight bold) - "Useful File menu items:\n" - :face variable-pitch - "Exit Emacs\t\t(Or type " - :face default - "Control-x" - :face variable-pitch - " followed by " - :face default - "Control-c" - :face variable-pitch - ") -Recover Crashed Session\tRecover files you were editing before a crash\n" - )) - "A list of texts to show in the middle part of splash screens. +(defvar fancy-about-text + '((:face (variable-pitch :foreground "red") + "This is " + :link ("GNU Emacs" + (lambda (button) (browse-url "http://www.gnu.org/software/emacs/")) + "Browse 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")) + "Browse http://www.gnu.org/gnu/linux-and-gnu.html") + '("GNU" (lambda (button) (describe-project)) + "Display info on the GNU 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 ("GNU and Freedom" (lambda (button) (describe-project))) + "\tWhy we developed GNU Emacs, and the GNU operating system\n" + :link ("Absence of Warranty" (lambda (button) (describe-no-warranty))) + "\tGNU Emacs comes with " + :face (variable-pitch :slant oblique) + "ABSOLUTELY NO WARRANTY\n" + :face variable-pitch + :link ("Copying Conditions" (lambda (button) (describe-copying))) + "\tConditions for redistributing and changing Emacs\n" + :link ("Getting New Versions" (lambda (button) (describe-distribution))) + "\tHow to obtain the latest version of Emacs\n" + :link ("Ordering Manuals" (lambda (button) (view-order-manuals))) + "\tBuying printed manuals from the FSF\n" + "\n" + :link ("Emacs Tutorial" (lambda (button) (help-with-tutorial))) + "\tLearn basic Emacs keystroke commands" + (lambda () + (let* ((en "TUTORIAL") + (tut (or (get-language-info current-language-environment + 'tutorial) + en)) + (title (with-temp-buffer + (insert-file-contents + (expand-file-name tut data-directory) + nil 0 256) + (search-forward ".") + (buffer-substring (point-min) (1- (point)))))) + ;; If there is a specific tutorial for the current language + ;; environment and it is not English, append its title. + (if (string= en tut) + "" + (concat " (" title ")")))) + "\n" + :link ("Emacs Guided Tour" + (lambda (button) (browse-url "http://www.gnu.org/software/emacs/tour/")) + "Browse http://www.gnu.org/software/emacs/tour/") + "\tSee an overview of the many facilities of GNU Emacs" + )) + "A list of texts to show in the middle part of the About screen. Each element in the list should be a list of strings or pairs `:face FACE', like `fancy-splash-insert' accepts them.") @@ -1196,20 +1269,6 @@ :version "21.1" :group 'initialization) - -(defcustom fancy-splash-delay 7 - "*Delay in seconds between splash screens." - :group 'fancy-splash-screen - :type 'integer) - - -(defcustom fancy-splash-max-time 30 - "*Show splash screens for at most this number of seconds. -Values less than twice `fancy-splash-delay' are ignored." - :group 'fancy-splash-screen - :type 'integer) - - (defcustom fancy-splash-image nil "*The image to show in the splash screens, or nil for defaults." :group 'fancy-splash-screen @@ -1217,30 +1276,54 @@ (file :tag "File"))) +(defvar splash-screen-keymap + (let ((map (make-sparse-keymap))) + (suppress-keymap map) + (set-keymap-parent map button-buffer-map) + (define-key map "\C-?" 'scroll-down) + (define-key map " " 'scroll-up) + (define-key map "q" 'exit-splash-screen) + map) + "Keymap for splash screen buffer.") + ;; These are temporary storage areas for the splash screen display. -(defvar fancy-current-text nil) (defvar fancy-splash-help-echo nil) -(defvar fancy-splash-stop-time nil) -(defvar fancy-splash-outer-buffer nil) -(defvar fancy-splash-last-input-event nil) (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 [HELP-ECHO]), which +specifies the button's label, `action' property and help-echo string. +FACE and LINK can also be functions, which are evaluated to obtain +a face or button specification." (let ((current-face nil)) (while args - (if (eq (car args) :face) - (setq args (cdr args) current-face (car args)) - (insert (propertize (let ((it (car args))) - (if (functionp it) - (funcall it) - it)) - 'face current-face - 'help-echo fancy-splash-help-echo))) + (cond ((eq (car args) :face) + (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) + 'help-echo (concat "mouse-2, RET: " + (or (nth 2 spec) + "Follow this link")) + 'follow-link t))) + (t (insert (propertize (let ((it (car args))) + (if (functionp it) + (funcall it) + it)) + 'face current-face + 'help-echo fancy-splash-help-echo)))) (setq args (cdr args))))) @@ -1250,11 +1333,11 @@ fancy-splash-image) ((and (display-color-p) (image-type-available-p 'xpm)) - (if (and (fboundp 'x-display-planes) - (= (funcall 'x-display-planes) 8)) - "splash8.xpm" - "splash.xpm")) - (t "splash.pbm"))) + (if (and (fboundp 'x-display-planes) + (= (funcall 'x-display-planes) 8)) + "splash8.xpm" + "splash.xpm")) + (t "splash.pbm"))) (img (create-image image-file)) (image-width (and img (car (image-size img)))) (window-width (window-width (selected-window)))) @@ -1270,52 +1353,41 @@ (eq (frame-parameter nil 'background-mode) 'dark)) (setq img (append img '(:color-symbols (("#000000" . "gray30")))))) - ;; Insert the image with a help-echo and a keymap. - (let ((map (make-sparse-keymap)) - (help-echo "mouse-2: browse http://www.gnu.org/")) - (define-key map [mouse-2] - (lambda () - (interactive) - (browse-url "http://www.gnu.org/") - (throw 'exit nil))) - (define-key map [down-mouse-2] 'ignore) - (define-key map [up-mouse-2] 'ignore) - (insert-image img (propertize "xxx" 'help-echo help-echo - 'keymap map))) - (insert "\n")))) - (fancy-splash-insert - :face '(variable-pitch :foreground "red") - (if (eq system-type 'gnu/linux) - "GNU Emacs is one component of the GNU/Linux operating system." - "GNU Emacs is one component of the GNU operating system.")) - (insert "\n") - (fancy-splash-insert - :face 'variable-pitch - "You can do basic editing with the menu bar and scroll bar \ -using the mouse.\n\n") - (when fancy-splash-outer-buffer - (fancy-splash-insert - :face 'variable-pitch - "Type " - :face 'default - "Control-l" - :face 'variable-pitch - " to begin editing" - (if (equal (buffer-name fancy-splash-outer-buffer) - "*scratch*") - ".\n" - " your file.\n")))) + ;; Insert the image with a help-echo and a link. + (make-button (prog1 (point) (insert-image img)) (point) + 'face 'default + 'help-echo "mouse-2, RET: Browse http://www.gnu.org/" + 'action (lambda (button) (browse-url "http://www.gnu.org/")) + 'follow-link t) + (insert "\n\n"))))) -(defun fancy-splash-tail () +(defun fancy-startup-tail (&optional concise) "Insert the tail part of the splash screen into the current buffer." (let ((fg (if (eq (frame-parameter nil 'background-mode) 'dark) "cyan" "darkblue"))) + (unless concise + (fancy-splash-insert + :face 'variable-pitch + "\nTo start... " + :link '("Open a File" + (lambda (button) (call-interactively 'find-file)) + "Specify a new file's name, to edit the file") + " " + :link '("Open Home Directory" + (lambda (button) (dired "~")) + "Open your home directory, to operate on its files") + " " + :link '("Customize Startup" + (lambda (button) (customize-group 'initialization)) + "Change initialization settings including this screen") + "\n")) (fancy-splash-insert :face `(variable-pitch :foreground ,fg) "\nThis is " (emacs-version) "\n" :face '(variable-pitch :height 0.5) - "Copyright (C) 2007 Free Software Foundation, Inc.") + emacs-copyright + "\n") (and auto-save-list-file-prefix ;; Don't signal an error if the ;; directory for auto-save-list files @@ -1330,151 +1402,120 @@ auto-save-list-file-prefix))) t) (fancy-splash-insert :face '(variable-pitch :foreground "red") - "\n\nIf an Emacs session crashed recently, " + "\nIf an Emacs session crashed recently, " "type " :face '(fixed-pitch :foreground "red") "Meta-x recover-session RET" :face '(variable-pitch :foreground "red") "\nto recover" - " the files you were editing.")))) - -(defun fancy-splash-screens-1 (buffer) - "Timer function displaying a splash screen." - (when (> (float-time) fancy-splash-stop-time) - (throw 'stop-splashing nil)) - (unless fancy-current-text - (setq fancy-current-text fancy-splash-text)) - (let ((text (car fancy-current-text))) - (set-buffer buffer) - (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) - (apply #'fancy-splash-insert text) - (fancy-splash-tail) - (unless (current-message) - (message fancy-splash-help-echo)) - (set-buffer-modified-p nil) - (goto-char (point-min)) - (force-mode-line-update) - (setq fancy-current-text (cdr fancy-current-text)))) - - -(defun fancy-splash-default-action () - "Stop displaying the splash screen buffer. -This is an internal function used to turn off the splash screen after -the user caused an input event by hitting a key or clicking with the -mouse." - (interactive) - (if (and (memq 'down (event-modifiers last-command-event)) - (eq (posn-window (event-start last-command-event)) - (selected-window))) - ;; This is a mouse-down event in the spash screen window. - ;; Ignore it and consume the corresponding mouse-up event. - (read-event) - (push last-command-event unread-command-events)) - (throw 'exit nil)) - -(defun fancy-splash-special-event-action () - "Save the last event and stop displaying the splash screen buffer. -This is an internal function used to turn off the splash screen after -the user caused an input event that is bound in `special-event-map'" - (interactive) - (setq fancy-splash-last-input-event last-input-event) - (throw 'exit nil)) - + " the files you were editing.")) -(defun fancy-splash-screens (&optional hide-on-input) - "Display fancy splash screens when Emacs starts." - (if hide-on-input - (let ((old-hourglass display-hourglass) - (fancy-splash-outer-buffer (current-buffer)) - splash-buffer - (old-minor-mode-map-alist minor-mode-map-alist) - (old-emulation-mode-map-alists emulation-mode-map-alists) - (old-special-event-map special-event-map) - (frame (fancy-splash-frame)) - timer) - (save-selected-window - (select-frame frame) - (switch-to-buffer " GNU Emacs") - (make-local-variable 'cursor-type) - (setq splash-buffer (current-buffer)) - (catch 'stop-splashing - (unwind-protect - (let ((map (make-sparse-keymap)) - (cursor-type nil)) - (use-local-map map) - (define-key map [switch-frame] 'ignore) - (define-key map [t] 'fancy-splash-default-action) - (define-key map [mouse-movement] 'ignore) - (define-key map [mode-line t] 'ignore) - ;; Temporarily bind special events to - ;; fancy-splash-special-event-action so as to stop - ;; displaying splash screens with such events. - ;; Otherwise, drag-n-drop into splash screens may - ;; leave us in recursive editing with invisible - ;; cursors for a while. - (setq special-event-map (make-sparse-keymap)) - (map-keymap - (lambda (key def) - (define-key special-event-map (vector key) - (if (eq def 'ignore) - 'ignore - 'fancy-splash-special-event-action))) - old-special-event-map) - (setq display-hourglass nil - minor-mode-map-alist nil - emulation-mode-map-alists nil - buffer-undo-list t - mode-line-format (propertize "---- %b %-" - 'face 'mode-line-buffer-id) - fancy-splash-stop-time (+ (float-time) - fancy-splash-max-time) - timer (run-with-timer 0 fancy-splash-delay - #'fancy-splash-screens-1 - splash-buffer)) - (message "%s" (startup-echo-area-message)) - (recursive-edit)) - (cancel-timer timer) - (setq display-hourglass old-hourglass - minor-mode-map-alist old-minor-mode-map-alist - emulation-mode-map-alists old-emulation-mode-map-alists - special-event-map old-special-event-map) - (kill-buffer splash-buffer) - (when fancy-splash-last-input-event - (setq last-input-event fancy-splash-last-input-event - fancy-splash-last-input-event nil) - (command-execute (lookup-key special-event-map - (vector last-input-event)) - nil (vector last-input-event) t)))))) - ;; If hide-on-input is nil, don't hide the buffer on input. - (if (or (window-minibuffer-p) - (window-dedicated-p (selected-window))) - (pop-to-buffer (current-buffer)) - (switch-to-buffer "*About GNU Emacs*")) - (setq buffer-read-only nil) - (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")) - (let (fancy-splash-outer-buffer) - (fancy-splash-head) - (dolist (text fancy-splash-text) - (apply #'fancy-splash-insert text) - (insert "\n")) - (skip-chars-backward "\n") - (delete-region (point) (point-max)) - (insert "\n") - (fancy-splash-tail) + (when concise + (fancy-splash-insert + :face 'variable-pitch "\n" + :link '("Dismiss this startup screen" + (lambda (button) + (when startup-screen-inhibit-startup-screen + (customize-set-variable 'inhibit-startup-screen t) + (customize-mark-to-save 'inhibit-startup-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) + " Never show it again."))))) + +(defun exit-splash-screen () + "Stop displaying the splash screen buffer." + (interactive) + (quit-window t)) + +(defun fancy-startup-screen (&optional concise) + "Display fancy startup screen. +If CONCISE is non-nil, display a concise version of the +splash screen in another window." + (let ((splash-buffer (get-buffer-create "*GNU Emacs*"))) + (with-current-buffer splash-buffer + (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 concise)) + (use-local-map splash-screen-keymap) + (setq tab-width 22 + buffer-read-only t) (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)) + (forward-line (if concise 2 4))) + (if concise + (progn + (display-buffer splash-buffer) + ;; If the splash screen is in a split window, fit it. + (let ((window (get-buffer-window splash-buffer t))) + (or (null window) + (eq window (selected-window)) + (eq window (next-window window)) + (fit-window-to-buffer window)))) + (switch-to-buffer splash-buffer)))) + +(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)) + (forward-line 3)))) (defun fancy-splash-frame () "Return the frame to use for the fancy splash screen. @@ -1508,241 +1549,360 @@ (> frame-height (+ image-height 19))))))) -(defun normal-splash-screen (&optional hide-on-input) - "Display splash screen when Emacs starts." +(defun normal-splash-screen (&optional startup) + "Display non-graphic splash screen. +If optional argument STARTUP is non-nil, display the startup screen +after Emacs starts. If STARTUP is nil, display the About screen." (let ((prev-buffer (current-buffer))) - (unwind-protect - (with-current-buffer (get-buffer-create "GNU Emacs") - (setq buffer-read-only nil) - (erase-buffer) - (set (make-local-variable 'tab-width) 8) - (if hide-on-input - (set (make-local-variable 'mode-line-format) - (propertize "---- %b %-" 'face 'mode-line-buffer-id))) + (with-current-buffer (get-buffer-create "*About GNU Emacs*") + (setq buffer-read-only nil) + (erase-buffer) + (set (make-local-variable 'tab-width) 8) + (if (not startup) + (set (make-local-variable 'mode-line-format) + (propertize "---- %b %-" 'face 'mode-line-buffer-id))) + + (if pure-space-overflow + (insert pure-space-overflow-message)) - (if pure-space-overflow - (insert "\ -Warning Warning!!! Pure space overflow !!!Warning Warning -\(See the node Pure Storage in the Lisp manual for details.)\n")) + ;; 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. + (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" + ", a part of the GNU operating system.\n")) + + (if startup + (if (display-mouse-p) + ;; The user can use the mouse to activate menus + ;; so give help in terms of menu items. + (normal-mouse-startup-screen) + + ;; No mouse menus, so give help using kbd commands. + (normal-no-mouse-startup-screen)) + + (normal-about-screen)) - ;; 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. - (insert "Welcome to GNU Emacs") - (insert - (if (eq system-type 'gnu/linux) - ", one component of the GNU/Linux operating system.\n" - ", a part of the GNU operating system.\n")) + ;; The rest of the startup screen is the same on all + ;; kinds of terminals. - (if hide-on-input - (insert (substitute-command-keys - (concat - "\nType \\[recenter] to begin editing" - (if (equal (buffer-name prev-buffer) "*scratch*") - ".\n" - " your file.\n"))))) + ;; Give information on recovering, if there was a crash. + (and startup + auto-save-list-file-prefix + ;; Don't signal an error if the + ;; directory for auto-save-list files + ;; does not yet exist. + (file-directory-p (file-name-directory + auto-save-list-file-prefix)) + (directory-files + (file-name-directory auto-save-list-file-prefix) + nil + (concat "\\`" + (regexp-quote (file-name-nondirectory + auto-save-list-file-prefix))) + t) + (insert "\n\nIf an Emacs session crashed recently, " + "type Meta-x recover-session RET\nto recover" + " the files you were editing.\n")) - (if (display-mouse-p) - ;; The user can use the mouse to activate menus - ;; so give help in terms of menu items. - (progn - (insert "\ -You can do basic editing with the menu bar and scroll bar using the mouse. -To quit a partially entered command, type Control-g. + (use-local-map splash-screen-keymap) -Useful File menu items: -Exit Emacs (or type Control-x followed by Control-c) -Recover Crashed Session Recover files you were editing before a crash + ;; Display the input that we set up in the buffer. + (set-buffer-modified-p nil) + (setq buffer-read-only t) + (if (and view-read-only (not view-mode)) + (view-mode-enter nil 'kill-buffer)) + (switch-to-buffer "*About GNU Emacs*") + (if startup (rename-buffer "*GNU Emacs*" t)) + (goto-char (point-min))))) + +(defun normal-mouse-startup-screen () + ;; The user can use the mouse to activate menus + ;; so give help in terms of menu items. + (insert "\ +To follow a link, click Mouse-1 on it, or move to it and type RET. +To quit a partially entered command, type Control-g.\n") -Important Help menu items: -Emacs Tutorial Learn how to use Emacs efficiently -Emacs FAQ Frequently asked questions and answers -Read the Emacs Manual View the Emacs manual using Info -\(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 -More Manuals / Ordering Manuals How to order printed manuals from the FSF -") - (insert "\n\n" (emacs-version) - " -Copyright (C) 2007 Free Software Foundation, Inc.")) + (insert "\nImportant Help menu items:\n") + (insert-button "Emacs Tutorial" + 'action (lambda (button) (help-with-tutorial)) + 'follow-link t) + (insert "\t\tLearn basic Emacs keystroke commands\n") + (insert-button "Read the Emacs Manual" + 'action (lambda (button) (info-emacs-manual)) + 'follow-link t) + (insert "\tView the Emacs manual using Info\n") + (insert-button "\(Non)Warranty" + 'action (lambda (button) (describe-no-warranty)) + 'follow-link t) + (insert "\t\tGNU Emacs comes with ABSOLUTELY NO WARRANTY\n") + (insert-button "Copying Conditions" + 'action (lambda (button) (describe-copying)) + 'follow-link t) + (insert "\tConditions for redistributing and changing Emacs\n") + (insert-button "More Manuals / Ordering Manuals" + 'action (lambda (button) (view-order-manuals)) + 'follow-link t) + (insert " How to order printed manuals from the FSF\n") - ;; No mouse menus, so give help using kbd commands. + (insert "\nUseful tasks:\n") + (insert-button "Visit New File" + 'action (lambda (button) (call-interactively 'find-file)) + 'follow-link t) + (insert "\t\tSpecify a new file's name, to edit the file\n") + (insert-button "Open Home Directory" + 'action (lambda (button) (dired "~")) + 'follow-link t) + (insert "\tOpen your home directory, to operate on its files\n") + (insert-button "Customize Startup" + 'action (lambda (button) (customize-group 'initialization)) + 'follow-link t) + (insert "\tChange initialization settings including this screen\n") + + (insert "\n" (emacs-version) + "\n" emacs-copyright)) + +;; No mouse menus, so give help using kbd commands. +(defun normal-no-mouse-startup-screen () - ;; 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) - (eq (key-binding "\C-x\C-c") 'save-buffers-kill-emacs) - (eq (key-binding "\C-ht") 'help-with-tutorial) - (eq (key-binding "\C-hi") 'info) - (eq (key-binding "\C-hr") 'info-emacs-manual) - (eq (key-binding "\C-h\C-n") 'view-emacs-news)) - (insert " -Get help C-h (Hold down CTRL and press h) -Emacs manual C-h r -Emacs tutorial C-h t Undo changes C-x u -Buy manuals C-h C-m Exit Emacs C-x C-c -Browse manuals C-h i") + ;; 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) + (eq (key-binding "\C-x\C-c") 'save-buffers-kill-terminal) + (eq (key-binding "\C-ht") 'help-with-tutorial) + (eq (key-binding "\C-hi") 'info) + (eq (key-binding "\C-hr") 'info-emacs-manual) + (eq (key-binding "\C-h\C-n") 'view-emacs-news)) + (progn + (insert " +Get help\t C-h (Hold down CTRL and press h) +") + (insert-button "Emacs manual" + 'action (lambda (button) (info-emacs-manual)) + 'follow-link t) + (insert " C-h r\t") + (insert-button "Browse manuals" + 'action (lambda (button) (Info-directory)) + 'follow-link t) + (insert "\t C-h i +") + (insert-button "Emacs tutorial" + 'action (lambda (button) (help-with-tutorial)) + 'follow-link t) + (insert " C-h t\tUndo changes\t C-x u +") + (insert-button "Buy manuals" + 'action (lambda (button) (view-order-manuals)) + 'follow-link t) + (insert "\t C-h C-m\tExit Emacs\t C-x C-c")) - (insert (substitute-command-keys - (format "\n -Get help %s -Emacs manual \\[info-emacs-manual] -Emacs tutorial \\[help-with-tutorial]\tUndo changes\t\\[advertised-undo] -Buy manuals \\[view-order-manuals]\tExit Emacs\t\\[save-buffers-kill-emacs] -Browse manuals \\[info]" - (let ((where (where-is-internal - 'help-command nil t))) - (if where - (key-description where) - "M-x help")))))) + (insert (format " +Get help\t %s +" + (let ((where (where-is-internal + 'help-command nil t))) + (if where + (key-description where) + "M-x help")))) + (insert-button "Emacs manual" + 'action (lambda (button) (info-emacs-manual)) + 'follow-link t) + (insert (substitute-command-keys"\t \\[info-emacs-manual]\t")) + (insert-button "Browse manuals" + 'action (lambda (button) (Info-directory)) + 'follow-link t) + (insert (substitute-command-keys "\t \\[info] +")) + (insert-button "Emacs tutorial" + 'action (lambda (button) (help-with-tutorial)) + 'follow-link t) + (insert (substitute-command-keys + "\t \\[help-with-tutorial]\tUndo changes\t \\[advertised-undo] +")) + (insert-button "Buy manuals" + 'action (lambda (button) (view-order-manuals)) + 'follow-link t) + (insert (substitute-command-keys + "\t \\[view-order-manuals]\tExit Emacs\t \\[save-buffers-kill-terminal]"))) - ;; Say how to use the menu bar with the keyboard. - (if (and (eq (key-binding "\M-`") 'tmm-menubar) - (eq (key-binding [f10]) 'tmm-menubar)) - (insert " -Activate menubar F10 or ESC ` or M-`") - (insert (substitute-command-keys " -Activate menubar \\[tmm-menubar]"))) + ;; Say how to use the menu bar with the keyboard. + (insert "\n") + (insert-button "Activate menubar" + 'action (lambda (button) (tmm-menubar)) + 'follow-link t) + (if (and (eq (key-binding "\M-`") 'tmm-menubar) + (eq (key-binding [f10]) 'tmm-menubar)) + (insert " F10 or ESC ` or M-`") + (insert (substitute-command-keys " \\[tmm-menubar]"))) - ;; Many users seem to have problems with these. - (insert " + ;; Many users seem to have problems with these. + (insert " \(`C-' means use the CTRL key. `M-' means use the Meta (or Alt) key. If you have no Meta key, you may instead type ESC followed by the character.)") - (insert "\n\n" (emacs-version) - " -Copyright (C) 2007 Free Software Foundation, Inc.") + ;; Insert links to useful tasks + (insert "\nUseful tasks:\n") - (if (and (eq (key-binding "\C-h\C-c") 'describe-copying) - (eq (key-binding "\C-h\C-d") 'describe-distribution) - (eq (key-binding "\C-h\C-w") 'describe-no-warranty)) - (insert - "\n -GNU Emacs comes with ABSOLUTELY NO WARRANTY; type C-h C-w for full details. -Emacs is Free Software--Free as in Freedom--so you can redistribute copies -of Emacs and modify it; type C-h C-c to see the conditions. -Type C-h C-d for information on getting the latest version.") - (insert (substitute-command-keys - "\n -GNU Emacs comes with ABSOLUTELY NO WARRANTY; type \\[describe-no-warranty] for full details. -Emacs is Free Software--Free as in Freedom--so you can redistribute copies -of Emacs and modify it; type \\[describe-copying] to see the conditions. -Type \\[describe-distribution] for information on getting the latest version.")))) + (insert-button "Visit New File" + 'action (lambda (button) (call-interactively 'find-file)) + 'follow-link t) + (insert "\t\t\t") + (insert-button "Open Home Directory" + 'action (lambda (button) (dired "~")) + 'follow-link t) + (insert "\n") - ;; The rest of the startup screen is the same on all - ;; kinds of terminals. + (insert-button "Customize Startup" + 'action (lambda (button) (customize-group 'initialization)) + 'follow-link t) + (insert "\t\t") + (insert-button "Open *scratch* buffer" + 'action (lambda (button) (switch-to-buffer + (get-buffer-create "*scratch*"))) + 'follow-link t) + (insert "\n") + (insert "\n" (emacs-version) "\n" emacs-copyright "\n") - ;; Give information on recovering, if there was a crash. - (and auto-save-list-file-prefix - ;; Don't signal an error if the - ;; directory for auto-save-list files - ;; does not yet exist. - (file-directory-p (file-name-directory - auto-save-list-file-prefix)) - (directory-files - (file-name-directory auto-save-list-file-prefix) - nil - (concat "\\`" - (regexp-quote (file-name-nondirectory - auto-save-list-file-prefix))) - t) - (insert "\n\nIf an Emacs session crashed recently, " - "type Meta-x recover-session RET\nto recover" - " the files you were editing.")) + (if (and (eq (key-binding "\C-h\C-c") 'describe-copying) + (eq (key-binding "\C-h\C-d") 'describe-distribution) + (eq (key-binding "\C-h\C-w") 'describe-no-warranty)) + (progn + (insert + " +GNU Emacs comes with ABSOLUTELY NO WARRANTY; type C-h C-w for ") + (insert-button "full details" + 'action (lambda (button) (describe-no-warranty)) + 'follow-link t) + (insert ". +Emacs is Free Software--Free as in Freedom--so you can redistribute copies +of Emacs and modify it; type C-h C-c to see ") + (insert-button "the conditions" + 'action (lambda (button) (describe-copying)) + 'follow-link t) + (insert ". +Type C-h C-d for information on ") + (insert-button "getting the latest version" + 'action (lambda (button) (describe-distribution)) + 'follow-link t) + (insert ".")) + (insert (substitute-command-keys + " +GNU Emacs comes with ABSOLUTELY NO WARRANTY; type \\[describe-no-warranty] for ")) + (insert-button "full details" + 'action (lambda (button) (describe-no-warranty)) + 'follow-link t) + (insert (substitute-command-keys ". +Emacs is Free Software--Free as in Freedom--so you can redistribute copies +of Emacs and modify it; type \\[describe-copying] to see ")) + (insert-button "the conditions" + 'action (lambda (button) (describe-copying)) + 'follow-link t) + (insert (substitute-command-keys". +Type \\[describe-distribution] for information on ")) + (insert-button "getting the latest version" + 'action (lambda (button) (describe-distribution)) + 'follow-link t) + (insert "."))) - ;; Display the input that we set up in the buffer. - (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)) - (if hide-on-input - (if (or (window-minibuffer-p) - (window-dedicated-p (selected-window))) - ;; If hide-on-input is nil, creating a new frame will - ;; generate enough events that the subsequent `sit-for' - ;; will immediately return anyway. - nil ;; (pop-to-buffer (current-buffer)) - (save-window-excursion - (switch-to-buffer (current-buffer)) - (sit-for 120))) - (condition-case nil - (switch-to-buffer (current-buffer)) - ;; In case the window is dedicated or something. - (error (pop-to-buffer (current-buffer)))))) - ;; Unwind ... ensure splash buffer is killed - (if hide-on-input - (kill-buffer "GNU Emacs") - (switch-to-buffer "GNU Emacs") - (rename-buffer "*About GNU Emacs*" t))))) +(defun normal-about-screen () + (insert "\n" (emacs-version) "\n" emacs-copyright "\n\n") + + (insert "To follow a link, click Mouse-1 on it, or move to it and type RET.\n\n") + + (insert-button "GNU and Freedom" + 'action (lambda (button) (describe-project)) + 'follow-link t) + (insert "\t\tWhy we developed GNU Emacs and the GNU system\n") + + (insert-button "Absence of Warranty" + 'action (lambda (button) (describe-no-warranty)) + 'follow-link t) + (insert "\tGNU Emacs comes with ABSOLUTELY NO WARRANTY\n") + (insert-button "Copying Conditions" + 'action (lambda (button) (describe-copying)) + 'follow-link t) + (insert "\tConditions for redistributing and changing Emacs\n") + + (insert-button "Getting New Versions" + 'action (lambda (button) (describe-distribution)) + 'follow-link t) + (insert "\tHow to get the latest version of GNU Emacs\n") + + (insert-button "More Manuals / Ordering Manuals" + 'action (lambda (button) (view-order-manuals)) + 'follow-link t) + (insert "\tBuying printed manuals from the FSF\n")) (defun startup-echo-area-message () (if (eq (key-binding "\C-h\C-p") 'describe-project) - "For information about the GNU system and GNU/Linux, type C-h C-p." + "For information about GNU Emacs and the GNU system, type C-h C-a." (substitute-command-keys - "For information about the GNU system and GNU/Linux, type \ -\\[describe-project]."))) + "For information about GNU Emacs and the GNU system, type \ +\\[about-emacs]."))) (defun display-startup-echo-area-message () (let ((resize-mini-windows t)) - (message "%s" (startup-echo-area-message)))) - + (or noninteractive ;(input-pending-p) init-file-had-error + ;; t if the init file says to inhibit the echo area startup message. + (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 (equal 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 (equal init-file-user "") + (user-login-name) + init-file-user))) + "[ \t\n]*)") + nil t)) + (error nil)) + (kill-buffer buffer))))) + (message "%s" (startup-echo-area-message))))) -(defun display-splash-screen (&optional hide-on-input) - "Display splash screen according to display. -Fancy splash screens are used on graphic displays, -normal otherwise. -With a prefix argument, any user input hides the splash screen." - (interactive "P") +(defun display-startup-screen (&optional concise) + "Display startup screen according to display. +A fancy display is used on graphic displays, normal otherwise. + +If CONCISE is non-nil, display a concise version of the startup +screen." + ;; Prevent recursive calls from server-process-filter. + (if (not (get-buffer "*GNU Emacs*")) + (if (use-fancy-splash-screens-p) + (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 (use-fancy-splash-screens-p) - (fancy-splash-screens hide-on-input) - (normal-splash-screen hide-on-input))) + (fancy-about-screen) + (normal-splash-screen nil))) +(defalias 'about-emacs 'display-about-screen) +(defalias 'display-splash-screen 'display-startup-screen) (defun command-line-1 (command-line-args-left) - (or noninteractive (input-pending-p) init-file-had-error - ;; t if the init file says to inhibit the echo area startup message. - (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 (equal 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 (equal init-file-user "") - (user-login-name) - init-file-user))) - "[ \t\n]*)") - nil t)) - (error nil)) - (kill-buffer buffer))))) - ;; display-splash-screen at the end of command-line-1 calls - ;; use-fancy-splash-screens-p. This can cause image.el to be - ;; loaded, putting "Loading image... done" in the echo area. - ;; This hides startup-echo-area-message. So - ;; use-fancy-splash-screens-p is called here simply to get the - ;; loading of image.el (if needed) out of the way before - ;; display-startup-echo-area-message runs. - (progn - (use-fancy-splash-screens-p) - (display-startup-echo-area-message))) + (display-startup-echo-area-message) ;; Delay 2 seconds after an init file error message ;; was displayed, so user can read it. @@ -1756,260 +1916,266 @@ "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)) + (let ((file-count 0) + first-file-buffer) + (when command-line-args-left + ;; We have command args; process them. + (let ((dir command-line-default-directory) + 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))) + ;; 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)) + ;; 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)))) + ;; 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))) + ;; 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)) + ((equal argi "-no-splash") + (setq inhibit-startup-screen t)) + + ((member argi '("-f" ; what the manual claims + "-funcall" + "-e")) ; what the source used to say + (setq inhibit-startup-screen t) + (setq tem (intern (or argval (pop command-line-args-left)))) + (if (commandp tem) + (command-execute tem) + (funcall tem))) - ((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")) + (setq inhibit-startup-screen t) + (eval (read (or argval (pop command-line-args-left))))) - ((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" "-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))) + ((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))) + ;; 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 "-insert") + (setq inhibit-startup-screen t) + (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)) + ((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")) + ;; 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]+\\'" 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)))) + ((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))) - ((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)) + ((member argi '("-find-file" "-file" "-visit")) + (setq inhibit-startup-screen t) + ;; 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)))) + ((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) + (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)) + (unless window-system + (setq inhibit-startup-screen t)) + (setq file-count (1+ file-count)) + (let ((file + (expand-file-name + (command-line-normalize-file-name orig-argi) + dir))) + (cond ((= file-count 1) + (setq first-file-buffer (find-file file))) + (inhibit-startup-screen + (find-file-other-window file)) + (t (find-file 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-startup-buffer-menu) - (or (get-buffer-window first-file-buffer) - (list-buffers))))) + (if (or inhibit-startup-screen + noninteractive + emacs-quick-startup) - ;; Maybe display a startup screen. - (unless (or inhibit-startup-message - noninteractive - emacs-quick-startup) - ;; Display a startup screen, after some preparations. + ;; 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 - ;; run this hook now, and there may be some need to do it - ;; before doing any output. - (run-hooks 'emacs-startup-hook) - (and term-setup-hook - (run-hooks 'term-setup-hook)) - (setq inhibit-startup-hooks t) + ;; If there are no switches to process, we might as well + ;; run this hook now, and there may be some need to do it + ;; before doing any output. + (run-hooks 'emacs-startup-hook) + (and term-setup-hook + (run-hooks 'term-setup-hook)) + (setq inhibit-startup-hooks t) - ;; It's important to notice the user settings before we - ;; display the startup message; otherwise, the settings - ;; won't take effect until the user gives the first - ;; keystroke, and that's distracting. - (when (fboundp 'frame-notice-user-settings) - (frame-notice-user-settings)) + ;; It's important to notice the user settings before we + ;; display the startup message; otherwise, the settings + ;; won't take effect until the user gives the first + ;; keystroke, and that's distracting. + (when (fboundp 'frame-notice-user-settings) + (frame-notice-user-settings)) - ;; If there are no switches to process, we might as well - ;; run this hook now, and there may be some need to do it - ;; before doing any output. - (when window-setup-hook - (run-hooks 'window-setup-hook) - ;; Don't let the hook be run twice. - (setq window-setup-hook nil)) + ;; If there are no switches to process, we might as well + ;; run this hook now, and there may be some need to do it + ;; before doing any output. + (when window-setup-hook + (run-hooks 'window-setup-hook) + ;; Don't let the hook be run twice. + (setq window-setup-hook nil)) - ;; Do this now to avoid an annoying delay if the user - ;; clicks the menu bar during the sit-for. - (when (display-popup-menus-p) - (precompute-menubar-bindings)) - (with-no-warnings - (setq menubar-bindings-done t)) + ;; ;; Do this now to avoid an annoying delay if the user + ;; ;; clicks the menu bar during the sit-for. + ;; (when (display-popup-menus-p) + ;; (precompute-menubar-bindings)) + ;; (with-no-warnings + ;; (setq menubar-bindings-done t)) - ;; If *scratch* exists and is empty, insert initial-scratch-message. - (and initial-scratch-message - (get-buffer "*scratch*") - (with-current-buffer "*scratch*" - (when (zerop (buffer-size)) - (insert initial-scratch-message) - (set-buffer-modified-p nil)))) + ;; If *scratch* exists and is empty, insert initial-scratch-message. + (and initial-scratch-message + (get-buffer "*scratch*") + (with-current-buffer "*scratch*" + (when (zerop (buffer-size)) + (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)))) - + (if (> file-count 0) + (display-startup-screen t) + (display-startup-screen nil))))) (defun command-line-normalize-file-name (file) "Collapse multiple slashes to one, to handle non-Emacs file names."