[COMMIT] The splash screen change

NOTE: This patch has been committed. lisp/ChangeLog addition: 2005-01-25 Ben Wing <ben(a)xemacs.org&gt; * startup.el: * startup.el (splash-frame-timeout): Removed. * startup.el (command-line-1): * startup.el (startup-presentation-hack-keymap): Removed. * startup.el (startup-presentation-hack-help): * startup.el (startup-presentation-hack): Removed. * startup.el (splash-frame-present): Removed. * startup.el (splash-screen-present): New. * startup.el (splash-frame-present-hack): Removed. * startup.el (startup-presentation-activate): New. * startup.el (splash-screen-present-hack): New. * startup.el (startup-center-spaces): * startup.el (splash-frame-body): Removed. * startup.el (splash-screen-window-body): New. * startup.el (splash-screen-tty-body): New. * startup.el (splash-frame-static-body): Removed. * startup.el (circulate-splash-frame-elements): Removed. * startup.el (display-splash-frame): Removed. * startup.el (splash-screen-static-body): New. * startup.el ('splash-frame-static-body): New. * startup.el (display-splash-screen): New. * startup.el (xemacs-splash-buffer): New. Rename "splash-frame" -> "splash-screen" (its change long ago from screen to frame happened during the general screen->frame sub and was a mistake). Compress all info onto one screen rather than cycling through 3 of them. Update copyright years and some other random stuff. * menubar-items.el: * menubar-items.el (default-menubar): * menubar-items.el (xemacs-splash-buffer): Removed. frame->screen and rewrite to fix bugginess. Add menu items for beta and distribution info. splash-screen-change source patch: Diff command: bash -ci "cvs-diff --show-c-function -no-changelog " Files affected: lisp/menubar-items.el lisp/startup.el Index: lisp/startup.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/startup.el,v retrieving revision 1.52 diff -u -p -r1.52 startup.el --- lisp/startup.el 2004/12/27 12:25:15 1.52 +++ lisp/startup.el 2005/01/26 04:55:35 ＠＠ -3,7 +3,7 ＠＠ ;; Copyright (C) 1985-1986, 1990, 1992-1997 Free Software Foundation, Inc. ;; Copyright (c) 1993, 1994 Sun Microsystems, Inc. ;; Copyright (C) 1995 Board of Trustees, University of Illinois -;; Copyright (C) 2001, 2002, 2003 Ben Wing. +;; Copyright (C) 2001, 2002, 2003, 2004, 2005 Ben Wing. ;; Maintainer: XEmacs Development Team ;; Keywords: internal, dumped ＠＠ -72,7 +72,6 ＠＠ (defvar command-line-processed nil "t once command line has been processed") (defconst startup-message-timeout 12000) ; More or less disable the timeout -(defconst splash-frame-timeout 7) ; interval between splash frame elements (defconst inhibit-startup-message nil "*Non-nil inhibits the initial startup message. ＠＠ -1059,7 +1058,7 ＠＠ a new format, when variables have change (when (string= (buffer-name) "*scratch*") (unless (or inhibit-startup-message (input-pending-p)) - (let (tmout circ-tmout) + (let (tmout) (unwind-protect ;; Guts of with-timeout (catch 'tmout ＠＠ -1069,13 +1068,12 ＠＠ a new format, when variables have change (throw 'tmout t) (error nil))) nil)) - (setq circ-tmout (display-splash-frame)) + (display-splash-screen) (or nil;; (pos-visible-in-window-p (point-min)) (goto-char (point-min))) (sit-for 0) (setq unread-command-event (next-command-event))) - (when tmout (disable-timeout tmout)) - (when circ-tmout (disable-timeout circ-tmout))))) + (when tmout (disable-timeout tmout))))) (with-current-buffer (get-buffer "*scratch*") ;; In case the XEmacs server has already selected ;; another buffer, erase the one our message is in. ＠＠ -1125,55 +1123,20 ＠＠ a new format, when variables have change (goto-line line) (setq line nil)))))))) -(defvar startup-presentation-hack-keymap - (let ((map (make-sparse-keymap))) - (set-keymap-name map 'startup-presentation-hack-keymap) - (define-key map '[button1] 'startup-presentation-hack) - (define-key map '[button2] 'startup-presentation-hack) - map) - "Putting yesterday in the future tomorrow.") - -(defun startup-presentation-hack () - (interactive) - (let ((e last-command-event)) - (and (button-press-event-p e) - (setq e (extent-at (event-point e) - (event-buffer e) - 'startup-presentation-hack)) - (setq e (extent-property e 'startup-presentation-hack)) - (if (consp e) - (apply (car e) (cdr e)) - (while (keymapp (indirect-function e)) - (let ((map e) - (overriding-local-map (indirect-function e))) - (setq e (read-key-sequence - (let ((p (keymap-prompt map t))) - (cond ((symbolp map) - (if p - (format "%s %s " map p) - (format "%s " map))) - (p) - (t - (prin1-to-string map)))))) - (if (and (button-release-event-p (elt e 0)) - (null (key-binding e))) - (setq e map) ; try again - (setq e (key-binding e))))) - (call-interactively e))))) - + (defun startup-presentation-hack-help (e) (setq e (extent-property e 'startup-presentation-hack)) - (if (consp e) - (format "Evaluate %S" e) - (symbol-name e))) - -(defun splash-frame-present-hack (e v) - ;; (set-extent-property e 'mouse-face 'highlight) - ;; (set-extent-property e 'keymap - ;; startup-presentation-hack-keymap) - ;; (set-extent-property e 'startup-presentation-hack v) - ;; (set-extent-property e 'help-echo - ;; 'startup-presentation-hack-help) + (symbol-name e)) + +(defun startup-presentation-activate (ev ex) + (call-interactively (extent-property ex 'startup-presentation-hack))) + +(defun splash-screen-present-hack (e v) +; (set-extent-property e 'mouse-face 'highlight) +; (set-extent-property e 'startup-presentation-hack v) +; (set-extent-property e 'help-echo +; 'startup-presentation-hack-help) +; (set-extent-property e 'activate-function 'startup-presentation-activate) ) (defun splash-hack-version-string () ＠＠ -1193,35 +1156,34 ＠＠ a new format, when variables have change (when (search-forward "." nil t) (delete-region (1- (point)) (point-max)))))) -(defun splash-frame-present (l) +;; parse one page description (see `splash-screen-body') and display +;; at point. +(defun splash-screen-present (l) (cond ((stringp l) (insert l)) ((eq (car-safe l) 'face) ;; (face name string) (let ((p (point))) - (splash-frame-present (elt l 2)) - (if (fboundp 'set-extent-face) - (set-extent-face (make-extent p (point)) - (elt l 1))))) + (splash-screen-present (elt l 2)) + (set-extent-face (make-extent p (point)) + (elt l 1)))) ((eq (car-safe l) 'key) (let* ((c (elt l 1)) (p (point)) (k (where-is-internal c nil t))) (insert (if k (key-description k) (format "M-x %s" c))) - (if (fboundp 'set-extent-face) - (let ((e (make-extent p (point)))) - (set-extent-face e 'bold) - (splash-frame-present-hack e c))))) + (let ((e (make-extent p (point)))) + (set-extent-face e 'bold) + (splash-screen-present-hack e c)))) ((eq (car-safe l) 'funcall) ;; (funcall (fun . args) string) (let ((p (point))) - (splash-frame-present (elt l 2)) - (if (fboundp 'set-extent-face) - (splash-frame-present-hack (make-extent p (point)) - (elt l 1))))) + (splash-screen-present (elt l 2)) + (splash-screen-present-hack (make-extent p (point)) + (elt l 1)))) ((consp l) - (mapcar 'splash-frame-present l)) + (mapcar 'splash-screen-present l)) (t (error "WTF!?")))) ＠＠ -1241,9 +1203,6 ＠＠ a new format, when variables have change (fill-area-width (* avg-pixwidth (- fill-column left-margin))) (glyph-pixwidth (cond ((stringp glyph) (* avg-pixwidth (length glyph))) - ;; #### the pixmap option should be removed - ;;((pixmapp glyph) - ;; (pixmap-width glyph)) ((glyphp glyph) (glyph-width glyph)) (t ＠＠ -1251,10 +1210,49 ＠＠ a new format, when variables have change (+ left-margin (round (/ (/ (- fill-area-width glyph-pixwidth) 2) avg-pixwidth))))) -(defun splash-frame-body () - `[((face (blue bold underline) - "\nDistribution, copying license, warranty:\n\n") - "Please visit the XEmacs website at http://www.xemacs.org/ !\n\n" +;; the splash screen originated in 19.10 as splash-screen-*. When +;; Chuck made the global screen->frame change for 19.12, he +;; accidentally changed these too. This randomness is getting on my +;; nerves, so let's fix it and provide minimal aliases for the +;; `locale' mule package. --ben + +;; returns either of vector of page descriptions, each describing one +;; screenful of information, or just one such page descriptions Each +;; page description is a list of textual elements describing how to +;; display a section of text. The elements are processed in turn and +;; the results inserted one after the previous in a buffer. Each +;; textual element is either: + +;; -- a string, inserted as-is with no decoration. +;; -- a list of (face FACES "text"), where FACES is the name of a face +;; or a list of such names, and specifies the face(s) used when +;; displaying the text. +;; -- a list of (key COMMAND-NAME); the key sequence corresponding to +;; the command will be inserted, in boldface. +;; -- a list of textual elements. + +(defun splash-screen-window-body () + `( + (face (blue bold underline) + "Useful Help-menu entries:\n\n") + ,＠(if (string-match "beta" emacs-version) + `((face bold "Beta Info:") + (face (red bold) + " This is an Experimental version of XEmacs.\n")) + `( "")) + (face bold "XEmacs FAQ:") + " Read the XEmacs FAQ.\n" + (face bold "Info (Online Docs):") + " Read the on-line documentation.\n" + (face bold "Tutorial:") + " XEmacs tutorial.\n" + (face bold "Samples->View Sample init.el:") + " A useful initialization file.\n" + (face bold "About XEmacs:") + " See who's developing XEmacs.\n" + "\n" + (face (bold blue) "XEmacs website:") + " http://www.xemacs.org/\n\n" ,＠(if (featurep 'sparcworks) `( "\ Sun provides support for the WorkShop/XEmacs integration package only. ＠＠ -1263,8 +1261,6 ＠＠ All other XEmacs packages are provided t (getenv "LANG")))) (if (and (not (featurep 'mule)) ;; Already got mule? - ;; No Mule support on tty's yet - (not (eq 'tty (console-type))) lang ;; Non-English locale? (not (string= lang "C")) (not (string-match "^en" lang)) ＠＠ -1276,46 +1272,47 ＠＠ To handle other languages you need to ru XEmacs, by either running the command `xemacs-mule', or by using the X resource `ESERVE*defaultXEmacsPath: xemacs-mule' when starting XEmacs from Sun WorkShop. \n"))))) - ((key describe-no-warranty) - ": "(face (red bold) "XEmacs comes with ABSOLUTELY NO WARRANTY\n")) - ((key describe-copying) - ": conditions to give out copies of XEmacs\n") - ((key describe-distribution) - ": how to get the latest version\n") - "\n--\n" (face italic "\ Copyright (C) 1985-1999 Free Software Foundation, Inc. Copyright (C) 1990-1994 Lucid, Inc. Copyright (C) 1993-1997 Sun Microsystems, Inc. All Rights Reserved. -Copyright (C) 1994-1996 Board of Trustees, University of Illinois -Copyright (C) 1995-1996 Ben Wing\n")) - - ((face (blue bold underline) "\nInformation, on-line help:\n\n") - "XEmacs comes with plenty of documentation...\n\n" +Copyright (C) 1994-1996 Board of Trustees, University of Illinois. +Copyright (C) 1995-2005 Ben Wing.\n") + )) + +(defun splash-screen-tty-body () + `( + (face italic "[`C-' means the control key, `M-' means the meta key]\n\n") ,＠(if (string-match "beta" emacs-version) `((key describe-beta) ": " (face (red bold) "This is an Experimental version of XEmacs.\n")) `( "\n")) ((key xemacs-local-faq) - ": read the XEmacs FAQ (a " (face underline "capital") " F!)\n") - ((key help-with-tutorial) - ": read the XEmacs tutorial (also available through the " - (face bold "Help") " menu)\n") + ": Read the XEmacs FAQ. (A " (face underline "capital") " F!)\n") + ((key info) ": Read the on-line documentation.\n") ((key help-command) - ": get help on using XEmacs (also available through the " - (face bold "Help") " menu)\n") - ((key info) ": read the on-line documentation\n\n") - ((key describe-project) ": read about the GNU project\n") - ((key about-xemacs) ": see who's developing XEmacs\n")) - - ((face (blue bold underline) "\nUseful stuff:\n\n") - "Things that you should learn rather quickly...\n\n" - ((key find-file) ": visit a file\n") - ((key save-buffer) ": save changes\n") - ((key undo) ": undo changes\n") - ((key save-buffers-kill-emacs) ": exit XEmacs\n")) - ]) + ": Get help on using XEmacs.\n") + ((key help-with-tutorial) + ": Read the XEmacs tutorial.\n") + ((key view-sample-init-el) + ": View the sample init.el file.\n") + ((key about-xemacs) ": See who's developing XEmacs.\n") + ((key save-buffers-kill-emacs) + ": exit XEmacs\n") + "\n" + (face (bold blue) "XEmacs website: ") + "http://www.xemacs.org/\n\n" + (face italic "\ +Copyright (C) 1985-1999 Free Software Foundation, Inc. +Copyright (C) 1990-1994 Lucid, Inc. +Copyright (C) 1993-1997 Sun Microsystems, Inc. All Rights Reserved. +Copyright (C) 1994-1996 Board of Trustees, University of Illinois. +Copyright (C) 1995-2004 Ben Wing.") +; ((key find-file) ": visit a file; ") +; ((key save-buffer) ": save changes; ") +; ((key undo) ": undo changes; ") + )) ;; I really hate global variables, oh well. ;(defvar xemacs-startup-logo-function nil ＠＠ -1323,67 +1320,58 ＠＠ Copyright (C) 1995-1996 Ben Wing\n")) ;This function should return an initialized glyph if it is used.") ;; This will hopefully go away when gettext is functional. -(defconst splash-frame-static-body - `(,(emacs-version) "\n\n" - (face italic "`C-' means the control key,`M-' means the meta key\n\n"))) - - -(defun circulate-splash-frame-elements (client-data) - (with-current-buffer (aref client-data 2) - (let ((buffer-read-only nil) - (elements (aref client-data 3)) - (indice (aref client-data 0))) - (goto-char (aref client-data 1)) - (delete-region (point) (point-max)) - (splash-frame-present (aref elements indice)) - (set-buffer-modified-p nil) - (aset client-data 0 - (if (= indice (- (length elements) 1)) - 0 - (1+ indice ))) - ))) - -;; #### This function now returns the (possibly nil) timeout circulating the -;; splash-frame elements -(defun display-splash-frame () +(defconst splash-screen-static-body + `(,(emacs-version) "\n\n")) +;; temporary support for old locale files. +(define-obsolete-variable-alias 'splash-frame-static-body + 'splash-screen-static-body) + +(defun display-splash-screen () + ;; display the splash screen in the current buffer and put it in the + ;; current window. (let ((logo xemacs-logo) (buffer-read-only nil) - (cramped-p (eq 'tty (console-type)))) - (unless cramped-p (insert "\n")) - (indent-to (startup-center-spaces logo)) - (set-extent-begin-glyph (make-extent (point) (point)) logo) - ;;(splash-frame-present-hack (make-extent p (point)) 'about-xemacs)) - (insert "\n\n") - (splash-frame-present splash-frame-static-body) + (tty (eq 'tty (console-type)))) + (unless tty + (insert "\n") + (indent-to (startup-center-spaces logo)) + (set-extent-begin-glyph (make-extent (point) (point)) logo) + ;;(splash-screen-present-hack (make-extent p (point)) 'about-xemacs)) + (insert "\n\n")) + (splash-screen-present splash-screen-static-body) (splash-hack-version-string) (goto-char (point-max)) (let* ((after-change-functions nil) ; no font-lock, thank you - (elements (splash-frame-body)) - (client-data `[ 1 ,(point) ,(current-buffer) ,elements ]) - tmout) - (if (listp elements) ;; A single element to display - (splash-frame-present (splash-frame-body)) - ;; several elements to rotate - (splash-frame-present (aref elements 0)) - (setq tmout (add-timeout splash-frame-timeout - 'circulate-splash-frame-elements - client-data splash-frame-timeout))) - (set-buffer-modified-p nil) - tmout))) + (elements (cond (tty (splash-screen-tty-body)) + (t (splash-screen-window-body))))) + (pop-to-buffer (current-buffer)) + (delete-other-windows) + (splash-screen-present elements) + (set-buffer-modified-p nil)))) +(defun xemacs-splash-buffer () + "Display XEmacs splash screen in a buffer." + (interactive) + (let ((buffer (get-buffer-create "*Splash*"))) + (set-buffer buffer) + (setq buffer-read-only nil) + (erase-buffer buffer) + (display-splash-screen))) + ;; (let ((present-file ;; #'(lambda (f) -;; (splash-frame-present +;; (splash-screen-present ;; (list 'funcall ;; (list 'find-file-other-window ;; (expand-file-name f data-directory)) ;; f))))) ;; (insert "For customization examples, see the files ") -;; (funcall present-file "sample.emacs") +;; (funcall present-file "sample.init.el") ;; (insert " and ") ;; (funcall present-file "sample.Xresources") ;; (insert (format "\nin the directory %s." data-directory))) + (defun startup-set-invocation-environment () ;; XEmacs -- Steven Baur says invocation directory is nil if you ;; try to use XEmacs as a login shell. Index: lisp/menubar-items.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/menubar-items.el,v retrieving revision 1.44 diff -u -p -r1.44 menubar-items.el --- lisp/menubar-items.el 2004/12/06 03:51:22 1.44 +++ lisp/menubar-items.el 2005/01/26 04:55:38 ＠＠ -1619,6 +1619,8 ＠＠ Write your filter like this: ["%_Home Page (www.xemacs.org)" xemacs-www-page :active (fboundp 'browse-url)] ["What's %_New in XEmacs" view-emacs-news] + ["B%_eta Info" describe-beta + :included (string-match "beta" emacs-version)] "-----" ("%_Info (Online Docs)" ["%_Info Contents" (Info-goto-node "(dir)")] ＠＠ -1702,6 +1704,7 ＠＠ Write your filter like this: ("%_Other" ["%_Current Installation Info" describe-installation :active (boundp 'Installation-string)] + ["%_Obtaining the Latest Version" describe-distribution] ["%_No Warranty" describe-no-warranty] ["XEmacs %_License" describe-copying] ["Find %_Packages" finder-by-keyword] ＠＠ -2105,27 +2108,6 ＠＠ items by redefining the function `format ;; In an effort to avoid massive menu clutter, this mostly worthless menu is ;; superseded by any local popup menu... (setq-default mode-popup-menu default-popup-menu) - - -;; misc - -(defun xemacs-splash-buffer () - "Redisplay XEmacs splash screen in a buffer." - (interactive) - (let ((buffer (get-buffer-create "*Splash*")) - tmout) - (set-buffer buffer) - (setq buffer-read-only t) - (erase-buffer buffer) - (setq tmout (display-splash-frame)) - (when tmout - (make-local-hook 'kill-buffer-hook) - (add-hook 'kill-buffer-hook - `(lambda () - (disable-timeout ,tmout)) - nil t)) - (pop-to-buffer buffer) - (delete-other-windows)))  ;;; backwards compatibility