;;; startup.el --- process Emacs shell arguments
-;; Copyright (C) 1985, 86, 92, 94, 95, 96, 97, 1998, 1999 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 86, 92, 94, 95, 96, 97, 98, 99, 2000 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
(cons attrs normal-top-level-add-subdirs-inode-list))
(while contents
(unless (member (car contents) '("." ".." "RCS" "CVS"))
- (when (and (string-match "\\`[a-zA-Z0-9]" (car contents))
+ (when (and (string-match "\\`[[:alnum:]]" (car contents))
;; Avoid doing a `stat' when it isn't necessary
;; because that can cause trouble when an NFS server
;; is down.
;; ...-frame-alist.
(if (fboundp 'frame-notice-user-settings)
(frame-notice-user-settings))
+ (if (fboundp 'frame-set-background-mode)
+ ;; Set the faces for the initial background mode even if
+ ;; frame-notice-user-settings didn't (such as on a tty).
+ ;; frame-set-background-mode is idempotent, so it won't
+ ;; cause any harm if it's already been done.
+ (let ((frame-background-mode frame-background-mode)
+ (frame (selected-frame))
+ term)
+ (when (and (null window-system)
+ ;; Don't override a possibly customized value.
+ (null frame-background-mode)
+ ;; Don't override user specifications.
+ (null (frame-parameter frame 'reverse))
+ (let ((bg (frame-parameter frame 'background-color)))
+ (or (null bg)
+ (member bg '(unspecified "unspecified-bg")))))
+ (setq term (getenv "TERM"))
+ (if (string-match "^\\(xterm\\|rxvt\\|dtterm\\|eterm\\)"
+ term)
+ (setq frame-background-mode 'light)))
+ (frame-set-background-mode (selected-frame))))
+
;; Now we know the user's default font, so add it to the menu.
(if (fboundp 'font-menu-add-default)
(font-menu-add-default))
(and window-setup-hook
(run-hooks 'window-setup-hook))
(or menubar-bindings-done
- (if (memq window-system '(x w32))
+ (if (display-popup-menus-p)
(precompute-menubar-bindings)))))))
;; Precompute the keyboard equivalents in the menu bar items.
(if purify-flag
(garbage-collect))))
(setq submap (cdr submap))))
- (setq define-key-rebound-commands t))
+ (setq define-key-rebound-commands t))
+
+;; Command-line options supported by tty's:
+(defconst tty-long-option-alist
+ '(("--name" . "-name")
+ ("--title" . "-T")
+ ("--reverse-video" . "-reverse")
+ ("--foreground-color" . "-fg")
+ ("--background-color" . "-bg")))
+
+;; Handle the X-like command line parameters "-fg", "-bg", "-name", etc.
+(defun tty-handle-args (args)
+ (let ((rest nil))
+ (message "%s" args)
+ (while (and args
+ (not (equal (car args) "--")))
+ (let* ((this (car args))
+ (orig-this this)
+ completion argval)
+ (setq args (cdr args))
+ ;; Check for long options with attached arguments
+ ;; and separate out the attached option argument into argval.
+ (if (string-match "^--[^=]*=" this)
+ (setq argval (substring this (match-end 0))
+ this (substring this 0 (1- (match-end 0)))))
+ (when (string-match "^--" this)
+ (setq completion (try-completion this tty-long-option-alist))
+ (if (eq completion t)
+ ;; Exact match for long option.
+ (setq this (cdr (assoc this tty-long-option-alist)))
+ (if (stringp completion)
+ (let ((elt (assoc completion tty-long-option-alist)))
+ ;; Check for abbreviated long option.
+ (or elt
+ (error "Option `%s' is ambiguous" this))
+ (setq this (cdr elt)))
+ ;; Check for a short option.
+ (setq argval nil this orig-this))))
+ (cond ((or (string= this "-fg") (string= this "-foreground"))
+ (or argval (setq argval (car args) args (cdr args)))
+ (setq default-frame-alist
+ (cons (cons 'foreground-color argval)
+ default-frame-alist)))
+ ((or (string= this "-bg") (string= this "-background"))
+ (or argval (setq argval (car args) args (cdr args)))
+ (setq default-frame-alist
+ (cons (cons 'background-color argval)
+ default-frame-alist)))
+ ((or (string= this "-T") (string= this "-name"))
+ (or argval (setq argval (car args) args (cdr args)))
+ (setq default-frame-alist
+ (cons
+ (cons 'title
+ (if (stringp argval)
+ argval
+ (let ((case-fold-search t)
+ i)
+ (setq argval (invocation-name))
+
+ ;; Change any . or * characters in name to
+ ;; hyphens, so as to emulate behavior on X.
+ (while
+ (setq i (string-match "[.*]" argval))
+ (aset argval i ?-))
+ argval)))
+ default-frame-alist)))
+ ((or (string= this "-r")
+ (string= this "-rv")
+ (string= this "-reverse"))
+ (setq default-frame-alist
+ (cons '(reverse . t)
+ default-frame-alist)))
+ (t (setq rest (cons this rest))))))
+ (nreverse rest)))
(defun command-line ()
(setq command-line-default-directory default-directory)
(setq window-system nil)
(kill-emacs)))
+ ;; Windowed displays do this inside their *-win.el.
+ (when (and (not (display-graphic-p))
+ (not noninteractive))
+ (setq command-line-args (tty-handle-args command-line-args)))
+
(let ((done nil)
(args (cdr command-line-args)))
(> (cdr (assq 'menu-bar-lines (frame-parameters))) 0)))
(menu-bar-mode t))
+ ;; If frame was created with a tool bar, switch tool-bar-mode on.
+ (when (and (not noninteractive)
+ (display-graphic-p)
+ (> (frame-parameter nil 'tool-bar-lines) 0))
+ (tool-bar-mode t))
+
;; Can't do this init in defcustom because window-system isn't set.
(when (and (not noninteractive)
(not (eq system-type 'ms-dos))
(setq-default blink-cursor t)
(blink-cursor-mode 1))
+ ;; Register default TTY colors for the case the terminal hasn't a
+ ;; terminal init file.
+ (or (memq window-system '(x w32))
+ (not (tty-display-color-p))
+ (let* ((colors (cond ((eq window-system 'pc)
+ msdos-color-values)
+ ((eq system-type 'windows-nt)
+ w32-tty-standard-colors)
+ (t tty-standard-colors)))
+ (color (car colors)))
+ (while colors
+ (tty-color-define (car color) (cadr color) (cddr color))
+ (setq colors (cdr colors) color (car colors)))
+ ;; Modifying color mappings means realized faces don't
+ ;; use the right colors, so clear them.
+ (clear-face-cache)))
+
(run-hooks 'before-init-hook)
;; Run the site-start library if it exists. The point of this file is
(set-buffer "*scratch*")
(if (eq major-mode 'fundamental-mode)
(funcall initial-major-mode))))
-
- ;; Register default TTY colors for the case the terminal hasn't a
- ;; terminal init file.
- (or (memq window-system '(x w32))
- (not (tty-display-color-p))
- (let* ((colors (cond ((eq window-system 'pc)
- msdos-color-values)
- ((eq system-type 'windows-nt)
- w32-tty-standard-colors)
- (t tty-standard-colors)))
- (color (car colors)))
- (while colors
- (tty-color-define (car color) (cadr color) (cddr color))
- (setq colors (cdr colors) color (car colors)))
- ;; Modifying color mappings means realized faces don't
- ;; use the right colors, so clear them.
- (clear-face-cache)))
;; Load library for our terminal type.
;; User init file can set term-file-prefix to nil to prevent this.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar fancy-splash-text
- '((:face 'variable-pitch
- "The menu bar and scroll bar are sufficient \
-for basic editing with the mouse.\n\n"
- :face '(variable-pitch :weight bold)
+ '((:face variable-pitch
+ "You can do basic editing with the menu bar and scroll bar \
+using the mouse.\n\n"
+ :face (variable-pitch :weight bold)
"Useful Files menu items:\n"
- :face 'variable-pitch "\
+ :face variable-pitch "\
Exit Emacs (or type Control-x followed by Control-c)
Recover Session recover files you were editing before a crash
"
)
- (:face 'variable-pitch
- "The menu bar and scroll bar are sufficient \
-for basic editing with the mouse.\n\n"
- :face '(variable-pitch :weight bold)
+ (:face variable-pitch
+ "You can do basic editing with the menu bar and scroll bar \
+using the mouse.\n\n"
+ :face (variable-pitch :weight bold)
"Important Help menu items:\n"
- :face 'variable-pitch "\
+ :face variable-pitch "\
Emacs Tutorial Learn-by-doing tutorial for using Emacs efficiently.
Emacs FAQ Frequently asked questions and answers
\(Non)Warranty GNU Emacs comes with "
- :face '(variable-pitch :slant oblique)
+ :face (variable-pitch :slant oblique)
"ABSOLUTELY NO WARRANTY\n"
- :face `variable-pitch
- "Copying Conditions Conditions for redistributing and \
-changing Emacs\n"))
+ :face variable-pitch
+ "\
+Copying Conditions Conditions for redistributing and changing Emacs\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.")
+(defgroup fancy-splash-screen ()
+ "Fancy splash screen when Emacs starts."
+ :version "21.1"
+ :group 'initialization)
+
+
(defcustom fancy-splash-delay 5
- "Delay in seconds between splash screens."
- :group 'splash-screen
+ "*Delay in seconds between splash screens."
+ :group 'fancy-splash-screen
:type 'integer)
-(defcustom fancy-splash-image "splash.xpm"
- "The image to show in the splash screens."
- :group 'splash-screen
- :type 'file)
+(defcustom fancy-splash-image nil
+ "*The image to show in the splash screens, or nil for defaults."
+ :group 'fancy-splash-screen
+ :type '(choice (const :tag "Default" nil)
+ (file :tag "File")))
+
+
+;; These are temporary storage areas for the splash screen display.
+
+(defvar fancy-current-text nil)
+(defvar fancy-splash-help-echo nil)
(defun fancy-splash-insert (&rest args)
(while args
(if (eq (car args) :face)
(setq args (cdr args) current-face (car args))
- (insert (propertize (car args) 'face current-face)))
+ (insert (propertize (car args)
+ 'face current-face
+ 'help-echo fancy-splash-help-echo)))
(setq args (cdr args)))))
(defun fancy-splash-head ()
"Insert the head part of the splash screen into the current buffer."
- (let* ((img (create-image fancy-splash-image))
+ (let* ((img (create-image (or fancy-splash-image
+ (if (and (display-color-p)
+ (image-type-available-p 'xpm))
+ "splash.xpm" "splash.pbm"))))
(image-width (and img (car (image-size img))))
(window-width (window-width (selected-window))))
(when img
(when (> window-width image-width)
+ ;; Center the image in the window.
(let ((pos (/ (- window-width image-width) 2)))
(insert (propertize " " 'display `(space :align-to ,pos))))
- (insert-image img)
+
+ ;; Change the color of the XPM version of the splash image
+ ;; so that it is visible with a dark frame background.
+ (when (and (memq 'xpm img)
+ (eq (frame-parameter nil 'background-mode) 'dark))
+ (setq img (append img '(:color-symbols (("#000000" . "gray"))))))
+
+ ;; 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"))))
- (when (eq system-type 'gnu/linux)
+ (if (eq system-type 'gnu/linux)
+ (fancy-splash-insert
+ :face '(variable-pitch :foreground "red")
+ "GNU Emacs is one component of a Linux-based GNU system.")
(fancy-splash-insert
:face '(variable-pitch :foreground "red")
- "GNU Emacs is one component of a Linux-based GNU system."))
+ "GNU Emacs is one component of the GNU operating system."))
(insert "\n"))
(defun fancy-splash-tail ()
"Insert the tail part of the splash screen into the current buffer."
- (fancy-splash-insert
- :face '(variable-pitch :foreground "darkblue")
- "\nThis is "
- (emacs-version)
- "\n"
- :face '(variable-pitch :height 0.5)
- "Copyright (C) 2000 Free Software Foundation, Inc."))
+ (let ((fg (if (eq (frame-parameter nil 'background-mode) 'dark)
+ "cyan" "darkblue")))
+ (fancy-splash-insert :face `(variable-pitch :foreground ,fg)
+ "\nThis is "
+ (emacs-version)
+ "\n"
+ :face '(variable-pitch :height 0.5)
+ "Copyright (C) 2000 Free Software Foundation, Inc.")))
+
+
+(defun fancy-splash-screens-1 (buffer)
+ "Timer function displaying a splash screen."
+ (unless fancy-current-text
+ (setq fancy-current-text fancy-splash-text))
+ (let ((text (car fancy-current-text)))
+ (set-buffer buffer)
+ (erase-buffer)
+ (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 ()
+ "Default action for events in the splash screen buffer."
+ (interactive)
+ (push last-command-event unread-command-events)
+ (throw 'exit nil))
(defun fancy-splash-screens ()
- (let* ((old-cursor-type cursor-type)
- stop)
+ "Display fancy splash screens when Emacs starts."
+ (setq fancy-splash-help-echo (startup-echo-area-message))
+ (switch-to-buffer "GNU Emacs")
+ (let ((old-busy-cursor display-busy-cursor)
+ (splash-buffer (current-buffer))
+ timer)
(unwind-protect
- (progn
- (setq cursor-type nil)
- (while (not stop)
- (let ((texts fancy-splash-text))
- (while (and texts (not stop))
- (erase-buffer)
- (fancy-splash-head)
- (apply #'fancy-splash-insert (car texts))
- (fancy-splash-tail)
- (goto-char (point-min))
- (set-buffer-modified-p nil)
- (force-mode-line-update)
- (setq texts (cdr texts))
- (setq stop (not (sit-for fancy-splash-delay)))))))
- (setq cursor-type old-cursor-type))
- (erase-buffer)))
+ (let ((map (make-sparse-keymap))
+ (show-help-function nil))
+ (use-local-map map)
+ (define-key map [t] 'fancy-splash-default-action)
+ (define-key map [mouse-movement] 'ignore)
+ (setq cursor-type nil
+ display-busy-cursor nil
+ buffer-undo-list t
+ mode-line-format
+ (propertize "---- %b %-" 'face '(:weight bold))
+ timer (run-with-timer 0 fancy-splash-delay
+ #'fancy-splash-screens-1
+ splash-buffer))
+ (recursive-edit))
+ (cancel-timer timer)
+ (setq display-busy-cursor old-busy-cursor)
+ (kill-buffer splash-buffer))))
+
+
+(defun startup-echo-area-message ()
+ (if (eq (key-binding "\C-h\C-p") 'describe-project)
+ "For information about the GNU Project and its goals, type C-h C-p."
+ (substitute-command-keys
+ "For information about the GNU Project and its goals, type \
+\\[describe-project].")))
+
+
+(defun display-startup-echo-area-message ()
+ (message (startup-echo-area-message)))
(defun command-line-1 (command-line-args-left)
(or noninteractive (input-pending-p) init-file-had-error
- (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 (string= 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 (string= init-file-user "")
- (user-login-name)
- init-file-user)))
- "[ \t\n]*)")
- nil t))
- (error nil))
- (kill-buffer buffer)))))
- (message (if (eq (key-binding "\C-h\C-p") 'describe-project)
- "For information about the GNU Project and its goals, type C-h C-p."
- (substitute-command-keys
- "For information about the GNU Project and its goals, type \\[describe-project]."))))
+ (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 (string= 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 (string= init-file-user "")
+ (user-login-name)
+ init-file-user)))
+ "[ \t\n]*)")
+ nil t))
+ (error nil))
+ (kill-buffer buffer)))))
+ (display-startup-echo-area-message))
(if (null command-line-args-left)
(cond ((and (not inhibit-startup-message) (not noninteractive)
;; Don't clobber a non-scratch buffer if init file
;; display the startup message; otherwise, the settings
;; won't take effect until the user gives the first
;; keystroke, and that's distracting.
- (if (fboundp 'frame-notice-user-settings)
- (frame-notice-user-settings))
-
- (and window-setup-hook
- (run-hooks 'window-setup-hook))
- (setq window-setup-hook nil)
+ (when (fboundp 'frame-notice-user-settings)
+ (frame-notice-user-settings))
+
+ (when window-setup-hook
+ (run-hooks 'window-setup-hook)
+ (setq window-setup-hook nil))
+
+ (when (display-popup-menus-p)
+ (precompute-menubar-bindings))
+ (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 (memq window-system '(x w32))
- (precompute-menubar-bindings))
- (setq menubar-bindings-done t)
(when (= (buffer-size) 0)
- (let ((buffer-undo-list t))
+ (let ((buffer-undo-list t)
+ (wait-for-input t))
(unwind-protect
(when (not (input-pending-p))
(goto-char (point-max))
(if (eq system-type 'gnu/linux)
(insert ", one component of a Linux-based GNU system."))
(insert "\n")
+
(if (assq 'display (frame-parameters))
- (if (and (display-color-p)
- (image-type-available-p 'xpm))
- (fancy-splash-screens)
+
+ (if (or (and (display-color-p)
+ (image-type-available-p 'xpm))
+ (image-type-available-p 'pbm))
+ (progn
+ (setq wait-for-input nil)
+ (fancy-splash-screens))
(progn
(insert "\
-The menu bar and scroll bar are sufficient for basic editing with the mouse.
+You can do basic editing with the menu bar and scroll bar using the mouse.
Useful Files menu items:
Exit Emacs (or type Control-x followed by Control-c)
Getting New Versions How to obtain the latest version of Emacs.
")
(insert "\n\n" (emacs-version)
- "
+ "
Copyright (C) 2000 Free Software Foundation, Inc.")))
+
;; If keys have their default meanings,
;; use precomputed string to save lots of time.
(if (and (eq (key-binding "\C-h") 'help-command)
(insert (substitute-command-keys "
Activate menubar \\[tmm-menubar]")))
- ;; Windows and MSDOS (currently) do not count as
- ;; window systems, but do have mouse support.
- (if window-system
+ (if (display-mouse-p)
(insert "
Mode-specific menu C-mouse-3 (third button, with CTRL)"))
;; Many users seem to have problems with these.
(goto-char (point-min))
(set-buffer-modified-p nil)
- (sit-for 120))
+ (when wait-for-input
+ (sit-for 120)))
+
(with-current-buffer (get-buffer "*scratch*")
(erase-buffer)
- (and initial-scratch-message
- (insert initial-scratch-message))
+ (when initial-scratch-message
+ (insert initial-scratch-message))
(set-buffer-modified-p nil)))))))
+
;; Delay 2 seconds after the init file error message
;; was displayed, so user can read it.
(if init-file-had-error
(file-count 0)
first-file-buffer
tem
- just-files ;; t if this follows the magic -- option.
+ 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
(funcall (cdr tem) argi))
(funcall (cdr tem) argi)))
- ((or (string-equal argi "-f") ;what the manual claims
+ ((or (string-equal argi "-f") ;what the manual claims
(string-equal argi "-funcall")
(string-equal argi "-e")) ; what the source used to say
(if argval
(progn (other-window 1)
(buffer-menu)))))))
+
(defun command-line-normalize-file-name (file)
"Collapse multiple slashes to one, to handle non-Emacs file names."
(save-match-data
HCoop / bpt / emacs.git / blobdiff