[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] Changes to emacs/lisp/startup.el,v
From: |
Chong Yidong |
Subject: |
[Emacs-diffs] Changes to emacs/lisp/startup.el,v |
Date: |
Mon, 10 Sep 2007 22:07:27 +0000 |
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."
- [Emacs-diffs] Changes to emacs/lisp/startup.el,v, Juri Linkov, 2007/09/04
- [Emacs-diffs] Changes to emacs/lisp/startup.el,v, Richard M. Stallman, 2007/09/05
- [Emacs-diffs] Changes to emacs/lisp/startup.el,v, Juri Linkov, 2007/09/09
- [Emacs-diffs] Changes to emacs/lisp/startup.el,v,
Chong Yidong <=
- [Emacs-diffs] Changes to emacs/lisp/startup.el,v, Glenn Morris, 2007/09/14
- [Emacs-diffs] Changes to emacs/lisp/startup.el,v, Stefan Monnier, 2007/09/21
- [Emacs-diffs] Changes to emacs/lisp/startup.el,v, Stefan Monnier, 2007/09/21
- [Emacs-diffs] Changes to emacs/lisp/startup.el,v, Juri Linkov, 2007/09/22
- [Emacs-diffs] Changes to emacs/lisp/startup.el,v, Juri Linkov, 2007/09/22
- [Emacs-diffs] Changes to emacs/lisp/startup.el,v, Juanma Barranquero, 2007/09/25
- [Emacs-diffs] Changes to emacs/lisp/startup.el,v, David Kastrup, 2007/09/30