[Emacs-diffs] Changes to emacs/lisp/startup.el,v

[Chong Yidong]

CVSROOT:        /sources/emacs
Module name:    emacs
Changes by:     Chong Yidong <cyd>      07/09/10 22:07:27

Index: startup.el
===================================================================
RCS file: /sources/emacs/emacs/lisp/startup.el,v
retrieving revision 1.455
retrieving revision 1.456
diff -u -b -r1.455 -r1.456
--- startup.el  9 Sep 2007 12:10:14 -0000       1.455
+++ startup.el  10 Sep 2007 22:07:27 -0000      1.456
@@ -72,6 +72,8 @@
 (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 @@
 (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 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (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 @@
      :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 @@
 
 (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 @@
       (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 @@
                     '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 @@
                              "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 @@
          (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 @@
          (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 @@
               (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 @@
                     (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 @@
      "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 @@
                 (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 @@
          ;; 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 @@
          ((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 @@
              (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."