Mercurial > emacs
diff lisp/startup.el @ 83653:2a69b973fae2
Merge from emacs--devo--0
Patches applied:
* emacs--devo--0 (patch 852-856)
- Update from CVS
- Merge from emacs--rel--22
* emacs--rel--22 (patch 93-96)
- Update from CVS
- Merge from gnus--rel--5.10
* gnus--rel--5.10 (patch 245)
- Update from CVS
Revision: emacs@sv.gnu.org/emacs--multi-tty--0--patch-32
| author | Miles Bader <miles@gnu.org> |
|---|---|
| date | Tue, 21 Aug 2007 04:55:30 +0000 |
| parents | 984b1dfd7601 d06f03347805 |
| children | 67f4cd925834 |
line wrap: on
line diff
--- a/lisp/startup.el Mon Aug 13 13:51:08 2007 +0000 +++ b/lisp/startup.el Tue Aug 21 04:55:30 2007 +0000 @@ -45,7 +45,20 @@ (defgroup initialization nil "Emacs start-up procedure." - :group 'internal) + :group 'environment) + +(defcustom initial-buffer-choice nil + "Buffer to show after starting Emacs. +If the value is nil and `inhibit-splash-screen' is nil, show the +startup screen. If the value is string, visit the specified file or +directory using `find-file'. If t, open the `*scratch*' buffer." + :type '(choice + (const :tag "Splash screen" nil) + (directory :tag "Directory" :value "~/") + (file :tag "File" :value "~/file.txt") + (const :tag "Lisp scratch buffer" t)) + :version "23.1" + :group 'initialization) (defcustom inhibit-splash-screen nil "Non-nil inhibits the startup screen. @@ -1062,10 +1075,7 @@ (if (get-buffer "*scratch*") (with-current-buffer "*scratch*" (if (eq major-mode 'fundamental-mode) - (funcall initial-major-mode)) - ;; Don't lose text that users type in *scratch*. - (setq buffer-offer-save t) - (auto-save-mode 1))) + (funcall initial-major-mode)))) ;; Load library for our terminal type. ;; User init file can set term-file-prefix to nil to prevent this. @@ -1115,6 +1125,8 @@ '((:face (variable-pitch :weight bold) "Important Help menu items:\n" :face variable-pitch + :link ("Emacs Tutorial" (lambda (button) (help-with-tutorial))) + "\tLearn how to use Emacs efficiently" (lambda () (let* ((en "TUTORIAL") (tut (or (get-language-info current-language-environment @@ -1128,47 +1140,47 @@ (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 " + (if (string= en tut) + "" + (concat " (" title ")")))) + "\n" + :face variable-pitch + :link ("Emacs FAQ" (lambda (button) (view-emacs-FAQ))) + "\tFrequently asked questions and answers\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 - "\ -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" + :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 ("More Manuals / Ordering Manuals" (lambda (button) (view-order-manuals))) + " Buying printed manuals from the FSF\n") + (:face (variable-pitch :weight bold) + "Useful tasks:\n" :face variable-pitch - ". - -Emacs Guided Tour\t\tSee http://www.gnu.org/software/emacs/tour/ + :link ("Visit New File" + (lambda (button) (call-interactively 'find-file))) + "\tSpecify a new file's name, to edit the file\n" + :link ("Open Home Directory" + (lambda (button) (dired "~"))) + "\tOpen your home directory, to operate on its files\n" + :link ("Open *scratch* buffer" + (lambda (button) (switch-to-buffer (get-buffer-create "*scratch*")))) + "\tOpen buffer for notes you don't want to save\n" + :link ("Customize Startup" + (lambda (button) (customize-group 'initialization))) + "\tChange initialization settings including this screen\n" -" - :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" - )) + "\nEmacs Guided Tour\tSee " + :link ("http://www.gnu.org/software/emacs/tour/" + (lambda (button) (browse-url "http://www.gnu.org/software/emacs/tour/"))) + + )) "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.") @@ -1200,13 +1212,22 @@ (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. @@ -1216,14 +1237,21 @@ `put-text-property'." (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))) + ((eq (car args) :link) + (setq args (cdr args)) + (let ((spec (car args))) + (insert-button (car spec) + 'face (list 'link current-face) + 'action (cadr spec) + '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))))) @@ -1253,18 +1281,12 @@ (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 the image with a help-echo and a link. + (make-button (prog1 (point) (insert-image img)) (point) + 'face 'default + 'help-echo "mouse-2: browse http://www.gnu.org/" + 'action (lambda (button) (browse-url "http://www.gnu.org/")) + 'follow-link t) (insert "\n")))) (fancy-splash-insert :face '(variable-pitch :foreground "red") @@ -1275,19 +1297,22 @@ (fancy-splash-insert :face 'variable-pitch "You can do basic editing with the menu bar and scroll bar \ -using the mouse.\n\n") +using the mouse.\n" + :face 'variable-pitch + "To quit a partially entered command, type " + :face 'default + "Control-g" + :face 'variable-pitch + "." + "\n\n") (when fancy-splash-outer-buffer (fancy-splash-insert :face 'variable-pitch "Type " :face 'default - "Control-l" + "`q'" :face 'variable-pitch - " to begin editing" - (if (equal (buffer-name fancy-splash-outer-buffer) - "*scratch*") - ".\n" - " your file.\n")))) + " to exit from this screen.\n"))) (defun fancy-splash-tail () "Insert the tail part of the splash screen into the current buffer." @@ -1319,7 +1344,7 @@ "Meta-x recover-session RET" :face '(variable-pitch :foreground "red") "\nto recover" - " the files you were editing.")))) + " the files you were editing.\n")))) (defun fancy-splash-screens-1 (buffer) "Timer function displaying a splash screen." @@ -1327,7 +1352,8 @@ (throw 'stop-splashing nil)) (unless fancy-current-text (setq fancy-current-text fancy-splash-text)) - (let ((text (car fancy-current-text))) + (let ((text (car fancy-current-text)) + (inhibit-read-only t)) (set-buffer buffer) (erase-buffer) (if pure-space-overflow @@ -1359,32 +1385,30 @@ (push last-command-event unread-command-events)) (throw 'exit nil)) -(defun fancy-splash-exit () +(defun exit-splash-screen () "Exit the splash screen." - (if (get-buffer "GNU Emacs") - (throw 'stop-splashing nil))) + (if (get-buffer "*About GNU Emacs*") + (throw 'stop-splashing nil) + (quit-window t))) (defun fancy-splash-delete-frame (frame) "Exit the splash screen after the frame is deleted." ;; We can not throw from `delete-frame-events', so we set up a timer ;; to exit the recursive edit as soon as Emacs is idle again. (if (frame-live-p frame) - (run-at-time 0 nil 'fancy-splash-exit))) + (run-at-time 0 nil 'exit-splash-screen))) -(defun fancy-splash-screens (&optional hide-on-input) +(defun fancy-splash-screens (&optional static) "Display fancy splash screens when Emacs starts." - (if hide-on-input + (if (not static) (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") + (switch-to-buffer "*About GNU Emacs*") (make-local-variable 'cursor-type) (setq splash-buffer (current-buffer)) (catch 'stop-splashing @@ -1416,8 +1440,6 @@ '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) @@ -1426,7 +1448,10 @@ timer (run-with-timer 0 fancy-splash-delay #'fancy-splash-screens-1 splash-buffer)) + (use-local-map splash-screen-keymap) + (setq tab-width 22) (message "%s" (startup-echo-area-message)) + (setq buffer-read-only t) (recursive-edit)) (cancel-timer timer) (setq display-hourglass old-hourglass @@ -1447,7 +1472,7 @@ (if (or (window-minibuffer-p) (window-dedicated-p (selected-window))) (pop-to-buffer (current-buffer)) - (switch-to-buffer "*About GNU Emacs*")) + (switch-to-buffer "*GNU Emacs*")) (setq buffer-read-only nil) (erase-buffer) (if pure-space-overflow @@ -1463,6 +1488,8 @@ (delete-region (point) (point-max)) (insert "\n") (fancy-splash-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)) @@ -1510,15 +1537,15 @@ (> frame-height (+ image-height 19))))))) -(defun normal-splash-screen (&optional hide-on-input) +(defun normal-splash-screen (&optional static) "Display splash screen when Emacs starts." (let ((prev-buffer (current-buffer))) (unwind-protect - (with-current-buffer (get-buffer-create "GNU Emacs") + (with-current-buffer (get-buffer-create "*About GNU Emacs*") (setq buffer-read-only nil) (erase-buffer) (set (make-local-variable 'tab-width) 8) - (if hide-on-input + (if (not static) (set (make-local-variable 'mode-line-format) (propertize "---- %b %-" 'face 'mode-line-buffer-id))) @@ -1536,13 +1563,10 @@ ", one component of the GNU/Linux operating system.\n" ", a part of the GNU operating system.\n")) - (if hide-on-input + (if (not static) (insert (substitute-command-keys (concat - "\nType \\[recenter] to begin editing" - (if (equal (buffer-name prev-buffer) "*scratch*") - ".\n" - " your file.\n"))))) + "\nType \\[recenter] to quit from this screen.\n")))) (if (display-mouse-p) ;; The user can use the mouse to activate menus @@ -1550,22 +1574,58 @@ (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. - -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 +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) + (insert "\nImportant Help menu items:\n") + (insert-button "Emacs Tutorial" + 'action (lambda (button) (help-with-tutorial)) + 'follow-link t) + (insert "\t\tLearn how to use Emacs efficiently\n") + (insert-button "Emacs FAQ" + 'action (lambda (button) (view-emacs-FAQ)) + 'follow-link t) + (insert "\t\tFrequently asked questions and answers\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 "Getting New Versions" + 'action (lambda (button) (describe-distribution)) + 'follow-link t) + (insert "\tHow to obtain the latest version of 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") + + (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 "Open *scratch* buffer" + 'action (lambda (button) (switch-to-buffer + (get-buffer-create "*scratch*"))) + 'follow-link t) + (insert "\tOpen buffer for notes you don't want to save\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. @@ -1579,57 +1639,139 @@ (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 " + (progn + (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") +") + (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-terminal] -Browse manuals \\[info]" - (let ((where (where-is-internal - 'help-command nil t))) - (if where - (key-description where) - "M-x help")))))) +" + (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" \\[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 + " \\[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-emacs]"))) - ;; 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 " \(`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) + ;; Insert links to useful tasks + (insert "\nUseful tasks:\n") + + (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") + + (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) (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. + (progn + (insert + "\n +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 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. +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 + "\n +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 the conditions. -Type \\[describe-distribution] for information on getting the latest version.")))) +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 "."))) ;; The rest of the startup screen is the same on all ;; kinds of terminals. @@ -1650,7 +1792,9 @@ t) (insert "\n\nIf an Emacs session crashed recently, " "type Meta-x recover-session RET\nto recover" - " the files you were editing.")) + " the files you were editing.\n")) + + (use-local-map splash-screen-keymap) ;; Display the input that we set up in the buffer. (set-buffer-modified-p nil) @@ -1671,10 +1815,10 @@ (condition-case nil (switch-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))))) + (if (not static) + (kill-buffer "*About GNU Emacs*") + (switch-to-buffer "*About GNU Emacs*") + (rename-buffer "*GNU Emacs*" t))))) (defun startup-echo-area-message () @@ -1728,14 +1872,14 @@ (message "%s" (startup-echo-area-message)))))) -(defun display-splash-screen (&optional hide-on-input) +(defun display-splash-screen (&optional static) "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") ;; Prevent recursive calls from server-process-filter. - (if (not (get-buffer "GNU Emacs")) + (if (not (get-buffer "*About GNU Emacs*")) (if (use-fancy-splash-screens-p) (fancy-splash-screens hide-on-input) (normal-splash-screen hide-on-input)))) @@ -1960,8 +2104,15 @@ (or (get-buffer-window first-file-buffer) (list-buffers))))) + (when initial-buffer-choice + (cond ((eq initial-buffer-choice t) + (switch-to-buffer (get-buffer-create "*scratch*"))) + ((stringp initial-buffer-choice) + (find-file initial-buffer-choice)))) + ;; Maybe display a startup screen. (unless (or inhibit-startup-message + initial-buffer-choice noninteractive emacs-quick-startup) ;; Display a startup screen, after some preparations.