Mercurial > hg > xemacs-beta

comparison lisp/startup.el @ 396:6719134a07c2 r21-2-13

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-13
author cvs
date Mon, 13 Aug 2007 11:12:05 +0200
parents 8626e4521993
children 74fd4e045ea6
comparison
equal deleted inserted replaced
395:de2c2a7459d2 396:6719134a07c2
41 (setq top-level '(normal-top-level)) 41 (setq top-level '(normal-top-level))
42 42
43 (defvar command-line-processed nil "t once command line has been processed") 43 (defvar command-line-processed nil "t once command line has been processed")
44 44
45 (defconst startup-message-timeout 12000) ; More or less disable the timeout 45 (defconst startup-message-timeout 12000) ; More or less disable the timeout
46 (defconst splash-frame-timeout 7) ; interval between splash frame elements
46 47
47 (defconst inhibit-startup-message nil 48 (defconst inhibit-startup-message nil
48 "*Non-nil inhibits the initial startup message. 49 "*Non-nil inhibits the initial startup message.
49 This is for use in your personal init file, once you are familiar 50 This is for use in your personal init file, once you are familiar
50 with the contents of the startup message.") 51 with the contents of the startup message.")
733 ;; Don't clobber a non-scratch buffer if init file 734 ;; Don't clobber a non-scratch buffer if init file
734 ;; has selected it. 735 ;; has selected it.
735 (when (string= (buffer-name) "*scratch*") 736 (when (string= (buffer-name) "*scratch*")
736 (unless (or inhibit-startup-message 737 (unless (or inhibit-startup-message
737 (input-pending-p)) 738 (input-pending-p))
738 (let ((timeout nil)) 739 (let (tmout circ-tmout)
739 (unwind-protect 740 (unwind-protect
740 ;; Guts of with-timeout 741 ;; Guts of with-timeout
741 (catch 'timeout 742 (catch 'tmout
742 (setq timeout (add-timeout startup-message-timeout 743 (setq tmout (add-timeout startup-message-timeout
743 (lambda (ignore) 744 (lambda (ignore)
744 (condition-case nil 745 (condition-case nil
745 (throw 'timeout t) 746 (throw 'tmout t)
746 (error nil))) 747 (error nil)))
747 nil)) 748 nil))
748 (startup-splash-frame) 749 (setq circ-tmout (display-splash-frame))
749 (or nil;; (pos-visible-in-window-p (point-min)) 750 (or nil;; (pos-visible-in-window-p (point-min))
750 (goto-char (point-min))) 751 (goto-char (point-min)))
751 (sit-for 0) 752 (sit-for 0)
752 (setq unread-command-event (next-command-event))) 753 (setq unread-command-event (next-command-event)))
753 (when timeout (disable-timeout timeout))))) 754 (when tmout (disable-timeout tmout))
755 (when circ-tmout (disable-timeout circ-tmout)))))
754 (with-current-buffer (get-buffer "*scratch*") 756 (with-current-buffer (get-buffer "*scratch*")
755 ;; In case the XEmacs server has already selected 757 ;; In case the XEmacs server has already selected
756 ;; another buffer, erase the one our message is in. 758 ;; another buffer, erase the one our message is in.
757 (erase-buffer) 759 (erase-buffer)
758 (when (stringp initial-scratch-message) 760 (when (stringp initial-scratch-message)
841 (if (consp e) 843 (if (consp e)
842 (format "Evaluate %S" e) 844 (format "Evaluate %S" e)
843 (symbol-name e))) 845 (symbol-name e)))
844 846
845 (defun splash-frame-present-hack (e v) 847 (defun splash-frame-present-hack (e v)
846 ;; (set-extent-property e 'mouse-face 'highlight) 848 ;; (set-extent-property e 'mouse-face 'highlight)
847 ;; (set-extent-property e 'keymap 849 ;; (set-extent-property e 'keymap
848 ;; startup-presentation-hack-keymap) 850 ;; startup-presentation-hack-keymap)
849 ;; (set-extent-property e 'startup-presentation-hack v) 851 ;; (set-extent-property e 'startup-presentation-hack v)
850 ;; (set-extent-property e 'help-echo 852 ;; (set-extent-property e 'help-echo
851 ;; 'startup-presentation-hack-help)) 853 ;; 'startup-presentation-hack-help)
852 ) 854 )
853 855
854 (defun splash-hack-version-string () 856 (defun splash-hack-version-string ()
855 (save-excursion 857 (save-excursion
856 (save-restriction 858 (save-restriction
924 (t 926 (t
925 (error "startup-center-spaces: bad arg"))))) 927 (error "startup-center-spaces: bad arg")))))
926 (+ left-margin 928 (+ left-margin
927 (round (/ (/ (- fill-area-width glyph-pixwidth) 2) avg-pixwidth))))) 929 (round (/ (/ (- fill-area-width glyph-pixwidth) 2) avg-pixwidth)))))
928 930
929 (defun startup-splash-frame-body () 931 (defun splash-frame-body ()
930 `("\n" ,(emacs-version) "\n" 932 `[((face (blue bold underline)
931 ,@(if (string-match "beta" emacs-version) 933 "\nDistribution, copying license, warranty:\n\n")
932 `( (face (bold blue) ( "This is an Experimental version of XEmacs. " 934 "Please visit the XEmacs website at http://www.xemacs.org !\n\n"
933 " Type " (key describe-beta) 935 ,@(if (featurep 'sparcworks)
934 " to see what this means.\n"))) 936 `( "\
935 `( "\n")) 937 Sun provides support for the WorkShop/XEmacs integration package only.
936 (face bold-italic "\ 938 All other XEmacs packages are provided to you \"AS IS\".\n"
939 ,@(let ((lang (or (getenv "LC_ALL") (getenv "LC_MESSAGES")
940 (getenv "LANG"))))
941 (if (and
942 (not (featurep 'mule)) ;; Already got mule?
943 ;; No Mule support on tty's yet
944 (not (eq 'tty (console-type)))
945 lang ;; Non-English locale?
946 (not (string= lang "C"))
947 (not (string-match "^en" lang))
948 ;; Comes with Sun WorkShop
949 (locate-file "xemacs-mule" exec-path))
950 '( "\
951 This version of XEmacs has been built with support for Latin-1 languages only.
952 To handle other languages you need to run a Multi-lingual (`Mule') version of
953 XEmacs, by either running the command `xemacs-mule', or by using the X resource
954 `ESERVE*defaultXEmacsPath: xemacs-mule' when starting XEmacs from Sun WorkShop.
955 \n")))))
956 ((key describe-no-warranty)
957 ": "(face (red bold) "XEmacs comes with ABSOLUTELY NO WARRANTY\n"))
958 ((key describe-copying)
959 ": conditions to give out copies of XEmacs\n")
960 ((key describe-distribution)
961 ": how to get the latest version\n")
962 "\n--\n"
963 (face italic "\
937 Copyright (C) 1985-1998 Free Software Foundation, Inc. 964 Copyright (C) 1985-1998 Free Software Foundation, Inc.
938 Copyright (C) 1990-1994 Lucid, Inc. 965 Copyright (C) 1990-1994 Lucid, Inc.
939 Copyright (C) 1993-1997 Sun Microsystems, Inc. All Rights Reserved. 966 Copyright (C) 1993-1997 Sun Microsystems, Inc. All Rights Reserved.
940 Copyright (C) 1994-1996 Board of Trustees, University of Illinois 967 Copyright (C) 1994-1996 Board of Trustees, University of Illinois
941 Copyright (C) 1995-1996 Ben Wing\n\n") 968 Copyright (C) 1995-1996 Ben Wing\n"))
942 969
943 ,@(if (featurep 'sparcworks) 970 ((face (blue bold underline) "\nInformation, on-line help:\n\n")
944 `( "\ 971 "XEmacs comes with plenty of documentation...\n\n"
945 Sun provides support for the WorkShop/XEmacs integration package only. 972 ,@(if (string-match "beta" emacs-version)
946 All other XEmacs packages are provided to you \"AS IS\". 973 `((key describe-beta)
947 For full details, type " (key describe-no-warranty) 974 ": " (face (red bold)
948 " to refer to the GPL Version 2, dated June 1991.\n\n" 975 "This is an Experimental version of XEmacs.\n"))
949 ,@(let ((lang (or (getenv "LC_ALL") (getenv "LC_MESSAGES") (getenv "LANG")))) 976 `( "\n"))
950 (if (and 977 ((key xemacs-local-faq)
951 (not (featurep 'mule)) ; Already got mule? 978 ": read the XEmacs FAQ (a " (face underline "capital") " F!)\n")
952 (not (eq 'tty (console-type))) ; No Mule support on tty's yet 979 ((key help-with-tutorial)
953 lang ; Non-English locale? 980 ": read the XEmacs tutorial (also available through the "
954 (not (string= lang "C")) 981 (face bold "Help") " menu)\n")
955 (not (string-match "^en" lang)) 982 ((key help-command)
956 (locate-file "xemacs-mule" exec-path)) ; Comes with Sun WorkShop 983 ": get help on using XEmacs (also available through the "
957 '( "\ 984 (face bold "Help") " menu)\n")
958 This version of XEmacs has been built with support for Latin-1 languages only. 985 ((key info) ": read the on-line documentation\n\n")
959 To handle other languages you need to run a Multi-lingual (`Mule') version of 986 ((key describe-project) ": read about the GNU project\n")
960 XEmacs, by either running the command `xemacs-mule', or by using the X resource 987 ((key about-xemacs) ": see who's developping XEmacs\n"))
961 `ESERVE*defaultXEmacsPath: xemacs-mule' when starting XEmacs from Sun WorkShop.\n\n")))) 988
962 989 ((face (blue bold underline) "\nUseful stuff:\n\n")
963 '("XEmacs comes with ABSOLUTELY NO WARRANTY; type " 990 "Things that you should know rather quickly...\n\n"
964 (key describe-no-warranty) " for full details.\n")) 991 ((key find-file) ": visit a file\n")
965 992 ((key save-buffer) ": save changes\n")
966 "You may give out copies of XEmacs; type " 993 ((key advertised-undo) ": undo changes\n")
967 (key describe-copying) " to see the conditions.\n" 994 ((key save-buffers-kill-emacs) ": exit XEmacs\n"))
968 "Type " (key describe-distribution) 995 ])
969 " for information on getting the latest version.\n\n"
970
971 "Type " (key help-command) " or use the " (face bold "Help") " menu to get help.\n"
972 "Type " (key advertised-undo) " to undo changes (`C-' means use the Control key).\n"
973 "To get out of XEmacs, type " (key save-buffers-kill-emacs) ".\n"
974 "Type " (key help-with-tutorial) " for a tutorial on using XEmacs.\n"
975 "Type " (key info) " to enter Info, "
976 "which you can use to read online documentation.\n"
977 (face (bold red) ( "\
978 For tips and answers to frequently asked questions, see the XEmacs FAQ.
979 \(It's on the Help menu, or type " (key xemacs-local-faq) " [a capital F!].\)"))))
980 996
981 ;; I really hate global variables, oh well. 997 ;; I really hate global variables, oh well.
982 ;(defvar xemacs-startup-logo-function nil 998 ;(defvar xemacs-startup-logo-function nil
983 ; "If non-nil, function called to provide the startup logo. 999 ; "If non-nil, function called to provide the startup logo.
984 ;This function should return an initialized glyph if it is used.") 1000 ;This function should return an initialized glyph if it is used.")
985 1001
986 (defun startup-splash-frame () 1002 ;; This will hopefully go away when gettext is functionnal.
987 (let ((p (point)) 1003 (defconst splash-frame-static-body
988 ; (logo (cond (xemacs-startup-logo-function 1004 `(,(emacs-version) "\n\n"
989 ; (funcall xemacs-startup-logo-function)) 1005 (face italic "`C-' means the control key,`M-' means the meta key\n\n")))
990 ; (t xemacs-logo))) 1006
991 (logo xemacs-logo) 1007
1008 (defun circulate-splash-frame-elements (client-data)
1009 (with-current-buffer (aref client-data 2)
1010 (let ((buffer-read-only nil)
1011 (elements (aref client-data 3))
1012 (indice (aref client-data 0)))
1013 (goto-char (aref client-data 1))
1014 (delete-region (point) (point-max))
1015 (splash-frame-present (aref elements indice))
1016 (set-buffer-modified-p nil)
1017 (aset client-data 0
1018 (if (= indice (- (length elements) 1))
1019 0
1020 (1+ indice )))
1021 )))
1022
1023 ;; ### This function now returns the (possibly nil) timeout circulating the
1024 ;; splash-frame elements
1025 (defun display-splash-frame ()
1026 (let ((logo xemacs-logo)
1027 (buffer-read-only nil)
992 (cramped-p (eq 'tty (console-type)))) 1028 (cramped-p (eq 'tty (console-type))))
993 (unless cramped-p (insert "\n")) 1029 (unless cramped-p (insert "\n"))
994 (indent-to (startup-center-spaces logo)) 1030 (indent-to (startup-center-spaces logo))
995 (set-extent-begin-glyph (make-extent (point) (point)) logo) 1031 (set-extent-begin-glyph (make-extent (point) (point)) logo)
996 (insert (if cramped-p "\n" "\n\n")) 1032 ;;(splash-frame-present-hack (make-extent p (point)) 'about-xemacs))
997 (splash-frame-present-hack (make-extent p (point)) 'about-xemacs)) 1033 (insert "\n\n")
998 1034 (splash-frame-present splash-frame-static-body)
999 (let ((after-change-functions nil)) ; no font-lock, thank you 1035 (splash-hack-version-string)
1000 (dolist (l (startup-splash-frame-body)) 1036 (goto-char (point-max))
1001 (splash-frame-present l))) 1037 (let* ((after-change-functions nil) ; no font-lock, thank you
1002 (splash-hack-version-string) 1038 (elements (splash-frame-body))
1003 (set-buffer-modified-p nil)) 1039 (client-data `[ 1 ,(point) ,(current-buffer) ,elements ])
1040 tmout)
1041 (if (listp elements) ;; A single element to display
1042 (splash-frame-present (splash-frame-body))
1043 ;; several elements to rotate
1044 (splash-frame-present (aref elements 0))
1045 (setq tmout (add-timeout splash-frame-timeout
1046 'circulate-splash-frame-elements
1047 client-data splash-frame-timeout)))
1048 (set-buffer-modified-p nil)
1049 tmout)))
1004 1050
1005 ;; (let ((present-file 1051 ;; (let ((present-file
1006 ;; #'(lambda (f) 1052 ;; #'(lambda (f)
1007 ;; (splash-frame-present 1053 ;; (splash-frame-present
1008 ;; (list 'funcall 1054 ;; (list 'funcall