X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/5c2f2631f8c64dba6367610acbd01304049631c9..4f85b47922a2e316ccd05be6be85842b2b5c03e3:/lisp/startup.el diff --git a/lisp/startup.el b/lisp/startup.el index 6c65b30fe3..3f4923afb2 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -1,6 +1,6 @@ ;;; startup.el --- process Emacs shell arguments -*- lexical-binding: t -*- -;; Copyright (C) 1985-1986, 1992, 1994-2012 Free Software Foundation, Inc. +;; Copyright (C) 1985-1986, 1992, 1994-2013 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: internal @@ -41,9 +41,10 @@ (defcustom initial-buffer-choice nil "Buffer to show after starting Emacs. If the value is nil and `inhibit-startup-screen' is nil, show the -startup screen. If the value is a string, visit the specified file -or directory using `find-file'. If t, open the `*scratch*' -buffer. +startup screen. If the value is a string, switch to a buffer +visiting the file or directory specified by that string. If the +value is a function, switch to the buffer returned by that +function. If t, open the `*scratch*' buffer. A string value also causes emacsclient to open the specified file or directory when no target file is specified." @@ -51,8 +52,10 @@ or directory when no target file is specified." (const :tag "Startup screen" nil) (directory :tag "Directory" :value "~/") (file :tag "File" :value "~/.emacs") + (const :tag "Notes buffer" remember-notes) + (function :tag "Function") (const :tag "Lisp scratch buffer" t)) - :version "23.1" + :version "24.4" :group 'initialization) (defcustom inhibit-startup-screen nil @@ -394,8 +397,6 @@ from being initialized." (defvar no-blinking-cursor nil) -(defvar default-frame-background-mode) - (defvar pure-space-overflow nil "Non-nil if building Emacs overflowed pure space.") @@ -410,14 +411,20 @@ Warning Warning!!! Pure space overflow !!!Warning Warning :type 'directory :initialize 'custom-initialize-delay) -(defconst package-subdirectory-regexp - "\\([^.].*?\\)-\\([0-9]+\\(?:[.][0-9]+\\|\\(?:pre\\|beta\\|alpha\\)[0-9]+\\)*\\)" - "Regular expression matching the name of a package subdirectory. -The first subexpression is the package name. -The second subexpression is the version string. - -The regexp should not contain a starting \"\\`\" or a trailing - \"\\'\"; those are added automatically by callers.") +(defvar package--builtin-versions + ;; Mostly populated by loaddefs.el via autoload-builtin-package-versions. + (purecopy `((emacs . ,(version-to-list emacs-version)))) + "Alist giving the version of each versioned builtin package. +I.e. each element of the list is of the form (NAME . VERSION) where +NAME is the package name as a symbol, and VERSION is its version +as a list.") + +(defun package--description-file (dir) + (concat (let ((subdir (file-name-nondirectory + (directory-file-name dir)))) + (if (string-match "\\([^.].*?\\)-\\([0-9]+\\(?:[.][0-9]+\\|\\(?:pre\\|beta\\|alpha\\)[0-9]+\\)*\\)" subdir) + (match-string 1 subdir) subdir)) + "-pkg.el")) (defun normal-top-level-add-subdirs-to-load-path () "Add all subdirectories of `default-directory' to `load-path'. @@ -434,8 +441,8 @@ or `CVS', and any subdirectory that contains a file named `.nosearch'." (let* ((this-dir (car dirs)) (contents (directory-files this-dir)) (default-directory this-dir) - (canonicalized (if (fboundp 'untranslated-canonical-name) - (untranslated-canonical-name this-dir)))) + (canonicalized (if (fboundp 'w32-untranslated-canonical-name) + (w32-untranslated-canonical-name this-dir)))) ;; The Windows version doesn't report meaningful inode numbers, so ;; use the canonicalized absolute file name of the directory instead. (setq attrs (or canonicalized @@ -484,6 +491,7 @@ It is the default value of the variable `top-level'." (setq command-line-processed t) (let ((dir default-directory)) (with-current-buffer "*Messages*" + (messages-buffer-mode) ;; Make it easy to do like "tail -f". (set (make-local-variable 'window-point-insertion-type) t) ;; Give *Messages* the same default-directory as *scratch*, @@ -712,7 +720,7 @@ opening the first frame (e.g. open a connection to an X server).") default-frame-alist)) (t (push argi rest))))) - (nreverse rest))) + (nconc (nreverse rest) args))) (declare-function x-get-resource "frame.c" (attribute class &optional component subclass)) @@ -767,11 +775,20 @@ Amongst another things, it parses the command-line arguments." (locate-file "simple" load-path (get-load-suffixes))) lisp-dir) ;; Don't abort if simple.el cannot be found, but print a warning. + ;; Although in most usage we are going to cryptically abort a moment + ;; later anyway, due to missing required bidi data files (eg bug#13430). (if (null simple-file-name) - (progn - (princ "Warning: Could not find simple.el nor simple.elc" - 'external-debugging-output) - (terpri 'external-debugging-output)) + (let ((standard-output 'external-debugging-output) + (lispdir (expand-file-name "../lisp" data-directory))) + (princ "Warning: Could not find simple.el or simple.elc") + (terpri) + (when (getenv "EMACSLOADPATH") + (princ "The EMACSLOADPATH environment variable is set, \ +please check its value") + (terpri)) + (unless (file-readable-p lispdir) + (princ (format "Lisp directory %s not readable?" lispdir)) + (terpri))) (setq lisp-dir (file-truename (file-name-directory simple-file-name))) (setq load-history (mapcar (lambda (elt) @@ -1182,10 +1199,12 @@ the `--debug-init' option to view a complete error backtrace." (dolist (dir dirs) (when (file-directory-p dir) (dolist (subdir (directory-files dir)) - (when (and (file-directory-p (expand-file-name subdir dir)) - (string-match - (concat "\\`" package-subdirectory-regexp "\\'") - subdir)) + (when (let ((subdir (expand-file-name subdir dir))) + (and (file-directory-p subdir) + (file-exists-p + (expand-file-name + (package--description-file subdir) + subdir)))) (throw 'package-dir-found t))))))) (package-initialize)) @@ -1454,6 +1473,7 @@ Each element in the list should be a list of strings or pairs (suppress-keymap map) (set-keymap-parent map button-buffer-map) (define-key map "\C-?" 'scroll-down-command) + (define-key map [?\S-\ ] 'scroll-down-command) (define-key map " " 'scroll-up-command) (define-key map "q" 'exit-splash-screen) map) @@ -1519,7 +1539,7 @@ a face or button specification." (t "splash.pbm"))) (img (create-image image-file)) (image-width (and img (car (image-size img)))) - (window-width (window-width (selected-window)))) + (window-width (window-width))) (when img (when (> window-width image-width) ;; Center the image in the window. @@ -1569,27 +1589,24 @@ a face or button specification." :face '(variable-pitch (:height 0.8)) emacs-copyright "\n") - (and auto-save-list-file-prefix - ;; Don't signal an error if the - ;; directory for auto-save-list files - ;; does not yet exist. - (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) - (fancy-splash-insert :face '(variable-pitch font-lock-comment-face) - "\nIf an Emacs session crashed recently, " - "type " - :face '(fixed-pitch font-lock-comment-face) - "Meta-x recover-session RET" - :face '(variable-pitch font-lock-comment-face) - "\nto recover" - " the files you were editing.")) + (when auto-save-list-file-prefix + (let ((dir (file-name-directory auto-save-list-file-prefix)) + (name (file-name-nondirectory auto-save-list-file-prefix)) + files) + ;; Don't warn if the directory for auto-save-list files does not + ;; yet exist. + (and (file-directory-p dir) + (setq files (directory-files dir nil (concat "\\`" name) t)) + (fancy-splash-insert :face '(variable-pitch font-lock-comment-face) + (if (= (length files) 1) + "\nAn auto-save file list was found. " + "\nAuto-save file lists were found. ") + "If an Emacs session crashed recently,\ntype " + :link `("M-x recover-session RET" + ,(lambda (_button) + (call-interactively + 'recover-session))) + " to recover the files you were editing.")))) (when concise (fancy-splash-insert @@ -1693,7 +1710,6 @@ splash screen in another window." (force-mode-line-update)) (use-local-map splash-screen-keymap) (setq tab-width 22) - (message "%s" (startup-echo-area-message t)) (setq buffer-read-only t) (goto-char (point-min)) (forward-line 3)))) @@ -1847,11 +1863,8 @@ To quit a partially entered command, type Control-g.\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. + "Show a splash screen suitable for displays without mouse support." (let* ((c-h-accessible ;; If normal-erase-is-backspace is used on a tty, there's ;; no way to invoke C-h and you have to use F1 instead. @@ -1929,47 +1942,24 @@ If you have no Meta key, you may instead type ESC followed by the character.)") 'follow-link t) (insert "\n") (insert "\n" (emacs-version) "\n" emacs-copyright "\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)) - (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 - " + (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 ". + (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". + (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 "."))) + (insert-button "getting the latest version" + 'action (lambda (_button) (describe-distribution)) + 'follow-link t) + (insert ".")) (defun normal-about-screen () (insert "\n" (emacs-version) "\n" emacs-copyright "\n\n") @@ -2017,15 +2007,12 @@ Type \\[describe-distribution] for information on ")) 'follow-link t) (insert "\tBuying printed manuals from the FSF\n")) -(defun startup-echo-area-message (&optional about-screen-message) - (cond ((and (daemonp) (not about-screen-message)) - "Starting Emacs daemon.") - ((eq (key-binding "\C-h\C-a") 'about-emacs) - "For information about GNU Emacs and the GNU system, type C-h C-a.") - (t - (substitute-command-keys - "For information about GNU Emacs and the GNU system, type \ -\\[about-emacs].")))) +(defun startup-echo-area-message () + (if (daemonp) + "Starting Emacs daemon." + (substitute-command-keys + "For information about GNU Emacs and the GNU system, type \ +\\[about-emacs]."))) (defun display-startup-echo-area-message () (let ((resize-mini-windows t)) @@ -2327,10 +2314,14 @@ A fancy display is used on graphic displays, normal otherwise." (set-buffer-modified-p nil)))) (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)))) + (let ((buf + (cond ((stringp initial-buffer-choice) + (find-file-noselect initial-buffer-choice)) + ((functionp initial-buffer-choice) + (funcall initial-buffer-choice))))) + (switch-to-buffer + (if (buffer-live-p buf) buf (get-buffer-create "*scratch*")) + 'norecord))) (if (or inhibit-startup-screen initial-buffer-choice @@ -2386,13 +2377,17 @@ A fancy display is used on graphic displays, normal otherwise." ;; Use arg 1 so that we don't collapse // at the start of the file name. ;; That is significant on some systems. ;; However, /// at the beginning is supposed to mean just /, not //. - (if (string-match "^///+" file) + (if (string-match + (if (memq system-type '(ms-dos windows-nt)) + "^\\([\\/][\\/][\\/]\\)+" + "^///+") + file) (setq file (replace-match "/" t t file))) - (and (memq system-type '(ms-dos windows-nt)) - (string-match "^[A-Za-z]:\\(\\\\[\\\\/]\\)" file) ; C:\/ or C:\\ - (setq file (replace-match "/" t t file 1))) - (while (string-match "//+" file 1) - (setq file (replace-match "/" t t file))) + (if (memq system-type '(ms-dos windows-nt)) + (while (string-match "\\([\\/][\\/]\\)+" file 1) + (setq file (replace-match "/" t t file))) + (while (string-match "//+" file 1) + (setq file (replace-match "/" t t file)))) file)) ;;; startup.el ends here