Mercurial > hg > xemacs-beta
comparison lisp/prim/startup.el @ 0:376386a54a3c r19-14
Import from CVS: tag r19-14
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 08:45:50 +0200 |
| parents | |
| children | ac2d302a0011 |
comparison
equal
deleted
inserted
replaced
| -1:000000000000 | 0:376386a54a3c |
|---|---|
| 1 ;;; startup.el --- process XEmacs shell arguments | |
| 2 | |
| 3 ;; Copyright (C) 1985-1986, 1990, 1992-1995 Free Software Foundation, Inc. | |
| 4 ;; Copyright (c) 1993, 1994 Sun Microsystems, Inc. | |
| 5 ;; Copyright (C) 1995 Board of Trustees, University of Illinois | |
| 6 | |
| 7 ;; Maintainer: XEmacs | |
| 8 ;; Keywords: internal | |
| 9 | |
| 10 ;; This file is part of XEmacs. | |
| 11 | |
| 12 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 13 ;; under the terms of the GNU General Public License as published by | |
| 14 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 15 ;; any later version. | |
| 16 | |
| 17 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 20 ;; General Public License for more details. | |
| 21 | |
| 22 ;; You should have received a copy of the GNU General Public License | |
| 23 ;; along with XEmacs; see the file COPYING. If not, write to the Free | |
| 24 ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
| 25 | |
| 26 ;;; Synched up with: FSF 19.28. | |
| 27 | |
| 28 ;;; Code: | |
| 29 | |
| 30 (defun command-line-do-help (arg) | |
| 31 "Print this message and exit." | |
| 32 (let ((standard-output 'external-debugging-output)) | |
| 33 (princ (emacs-version)) | |
| 34 (princ "\n\n") | |
| 35 (cond ((fboundp 'x-create-frame) | |
| 36 (princ "XEmacs") | |
| 37 (princ " accepts all standard X Toolkit command line options.\ | |
| 38 In addition,\nthe ")) | |
| 39 (t (princ "The "))) | |
| 40 (princ "following options are processed in the order encountered:\n\n") | |
| 41 (let ((l command-switch-alist) | |
| 42 (insert (function (lambda (&rest x) | |
| 43 (princ " ") | |
| 44 (let ((len 2)) | |
| 45 (while x | |
| 46 (princ (car x)) | |
| 47 (setq len (+ len (length (car x)))) | |
| 48 (setq x (cdr x))) | |
| 49 (if (>= len 24) | |
| 50 (progn (terpri) (setq len 0))) | |
| 51 (while (< len 24) | |
| 52 (princ " ") | |
| 53 (setq len (1+ len)))))))) | |
| 54 (while l | |
| 55 (let ((name (car (car l))) | |
| 56 (fn (cdr (car l))) | |
| 57 doc arg cons) | |
| 58 (cond | |
| 59 ((and (symbolp fn) (get fn 'undocumented)) nil) | |
| 60 (t | |
| 61 (setq doc (documentation fn)) | |
| 62 (if (member doc '(nil "")) (setq doc "(undocumented)")) | |
| 63 (cond ((string-match "\n\\(<.*>\\)\n?\\'" doc) | |
| 64 ;; Doc of the form "The frobber switch\n<arg1> <arg2>" | |
| 65 (setq arg (substring doc (match-beginning 1) (match-end 1)) | |
| 66 doc (substring doc 0 (match-beginning 0)))) | |
| 67 ((string-match "\n+\\'" doc) | |
| 68 (setq doc (substring doc 0 (match-beginning 0))))) | |
| 69 (if (and (setq cons (rassq fn command-switch-alist)) | |
| 70 (not (eq cons (car l)))) | |
| 71 (setq doc (format "Same as %s." (car cons)))) | |
| 72 (if arg | |
| 73 (funcall insert name " " arg) | |
| 74 (funcall insert name)) | |
| 75 (princ doc) | |
| 76 (terpri)))) | |
| 77 (setq l (cdr l)))) | |
| 78 (princ "\ | |
| 79 +N <file> Start displaying <file> at line N. | |
| 80 | |
| 81 These options are processed only if they appear before all other options: | |
| 82 | |
| 83 -t <device> Use TTY <device> instead of the terminal for input | |
| 84 and output. This implies the -nw option. | |
| 85 -batch Execute noninteractively (messages go to stderr). | |
| 86 This option must be first in the list after -t. | |
| 87 -nw Inhibit the use of any window-system-specific | |
| 88 display code: use the current tty. | |
| 89 -debug-init Enter the debugger if an error in the init file occurs. | |
| 90 -unmapped Do not map the initial frame. | |
| 91 -no-site-file Do not load the site-specific init file (site-start.el). | |
| 92 -no-init-file Do not load the user-specific init file (~/.emacs). | |
| 93 -q Same as -no-init-file. | |
| 94 -user <user> Load user's init file instead of your own. | |
| 95 -u <user> Same as -user.") | |
| 96 | |
| 97 (princ " | |
| 98 | |
| 99 Anything else is considered a file name, and is placed into a buffer for | |
| 100 editing. | |
| 101 | |
| 102 XEmacs has an online tutorial and manuals. Type ^Ht (Control-h t) after | |
| 103 starting XEmacs to run the tutorial. Type ^Hi to enter the manual browser.\n") | |
| 104 (kill-emacs 0) | |
| 105 )) | |
| 106 | |
| 107 ;;; -batch, -t, and -nw are processed by main() in emacs.c and are | |
| 108 ;;; never seen by lisp code. | |
| 109 | |
| 110 ;;; -version and -help are special-cased as well: they imply -batch, | |
| 111 ;;; but are left on the list for lisp code to process. | |
| 112 | |
| 113 | |
| 114 (setq top-level '(normal-top-level)) | |
| 115 | |
| 116 (defvar command-line-processed nil "t once command line has been processed") | |
| 117 | |
| 118 (defconst startup-message-timeout 120) | |
| 119 | |
| 120 (defconst inhibit-startup-message nil | |
| 121 "*Non-nil inhibits the initial startup message. | |
| 122 This is for use in your personal init file, once you are familiar | |
| 123 with the contents of the startup message.") | |
| 124 | |
| 125 ;; #### FSFmacs randomness | |
| 126 ;(defconst inhibit-startup-echo-area-message nil | |
| 127 ; "*Non-nil inhibits the initial startup echo area message. | |
| 128 ;Inhibition takes effect only if your `.emacs' file contains | |
| 129 ;a line of this form: | |
| 130 ; (setq inhibit-startup-echo-area-message \"YOUR-USER-NAME\") | |
| 131 ;If your `.emacs' file is byte-compiled, use the following form instead: | |
| 132 ; (eval '(setq inhibit-startup-echo-area-message \"YOUR-USER-NAME\")) | |
| 133 ;Thus, someone else using a copy of your `.emacs' file will see | |
| 134 ;the startup message unless he personally acts to inhibit it.") | |
| 135 | |
| 136 (defconst inhibit-default-init nil | |
| 137 "*Non-nil inhibits loading the `default' library.") | |
| 138 | |
| 139 (defconst command-switch-alist nil | |
| 140 "Alist of command-line switches. | |
| 141 Elements look like (SWITCH-STRING . HANDLER-FUNCTION). | |
| 142 HANDLER-FUNCTION receives switch name as sole arg; | |
| 143 remaining command-line args are in the variable `command-line-args-left'.") | |
| 144 | |
| 145 (defvar command-line-args-left nil | |
| 146 "List of command-line args not yet processed.") ; bound by `command-line' | |
| 147 | |
| 148 (defvar command-line-default-directory nil | |
| 149 "Default directory to use for command line arguments. | |
| 150 This is normally copied from `default-directory' when XEmacs starts.") | |
| 151 | |
| 152 (defvar before-init-hook nil | |
| 153 "Functions to call after handling urgent options but before init files. | |
| 154 The frame system uses this to open frames to display messages while | |
| 155 XEmacs loads the user's initialization file.") | |
| 156 | |
| 157 (defvar after-init-hook nil | |
| 158 "Functions to call after loading the init file (`~/.emacs'). | |
| 159 The call is not protected by a condition-case, so you can set `debug-on-error' | |
| 160 in `.emacs', and put all the actual code on `after-init-hook'.") | |
| 161 | |
| 162 (defvar term-setup-hook nil | |
| 163 "Functions to be called after loading terminal-specific Lisp code. | |
| 164 See `run-hooks'. This variable exists for users to set, | |
| 165 so as to override the definitions made by the terminal-specific file. | |
| 166 XEmacs never sets this variable itself.") | |
| 167 | |
| 168 (defvar keyboard-type nil | |
| 169 "The brand of keyboard you are using. | |
| 170 This variable is used to define | |
| 171 the proper function and keypad keys for use under X. It is used in a | |
| 172 fashion analogous to the environment value TERM.") | |
| 173 | |
| 174 (defvar window-setup-hook nil | |
| 175 "Normal hook run to initialize window system display. | |
| 176 XEmacs runs this hook after processing the command line arguments and loading | |
| 177 the user's init file.") | |
| 178 | |
| 179 (defconst initial-major-mode 'lisp-interaction-mode | |
| 180 "Major mode command symbol to use for the initial *scratch* buffer.") | |
| 181 | |
| 182 (defvar init-file-user nil | |
| 183 "Identity of user whose `.emacs' file is or was read. | |
| 184 The value is nil if no init file is being used; otherwise, it may be either | |
| 185 the null string, meaning that the init file was taken from the user that | |
| 186 originally logged in, or it may be a string containing a user's name. | |
| 187 | |
| 188 In either of the latter cases, `(concat \"~\" init-file-user \"/\")' | |
| 189 evaluates to the name of the directory where the `.emacs' file was | |
| 190 looked for. | |
| 191 | |
| 192 Setting `init-file-user' does not prevent Emacs from loading | |
| 193 `site-start.el'. The only way to do that is to use `--no-site-file'.") | |
| 194 | |
| 195 ;; #### called `site-run-file' in FSFmacs | |
| 196 | |
| 197 (defvar site-start-file (purecopy "site-start") | |
| 198 "File containing site-wide run-time initializations. | |
| 199 This file is loaded at run-time before `~/.emacs'. It contains inits | |
| 200 that need to be in place for the entire site, but which, due to their | |
| 201 higher incidence of change, don't make sense to load into XEmacs' | |
| 202 dumped image. Thus, the run-time load order is: 1. file described in | |
| 203 this variable, if non-nil; 2. `~/.emacs'; 3. `default.el'. | |
| 204 | |
| 205 Don't use the `site-start.el' file for things some users may not like. | |
| 206 Put them in `default.el' instead, so that users can more easily | |
| 207 override them. Users can prevent loading `default.el' with the `-q' | |
| 208 option or by setting `inhibit-default-init' in their own init files, | |
| 209 but inhibiting `site-start.el' requires `--no-site-file', which | |
| 210 is less convenient.") | |
| 211 | |
| 212 ;(defconst iso-8859-1-locale-regexp "8859[-_]?1" | |
| 213 ; "Regexp that specifies when to enable the ISO 8859-1 character set. | |
| 214 ;We do that if this regexp matches the locale name | |
| 215 ;specified by the LC_ALL, LC_CTYPE and LANG environment variables.") | |
| 216 | |
| 217 (defvar mail-host-address nil | |
| 218 "*Name of this machine, for purposes of naming users.") | |
| 219 | |
| 220 (defvar user-mail-address nil | |
| 221 "*Full mailing address of this user. | |
| 222 This is initialized based on `mail-host-address', | |
| 223 after your init file is read, in case it sets `mail-host-address'.") | |
| 224 | |
| 225 (defvar auto-save-list-file-prefix "~/.saves-" | |
| 226 "Prefix for generating auto-save-list-file-name. | |
| 227 Emacs's pid and the system name will be appended to | |
| 228 this prefix to create a unique file name.") | |
| 229 | |
| 230 (defvar init-file-debug nil) | |
| 231 | |
| 232 (defvar init-file-had-error nil) | |
| 233 | |
| 234 (defvar init-file-loaded nil | |
| 235 "True after the user's init file has been loaded (or suppressed with -q). | |
| 236 This will be true when `after-init-hook' is run and at all times | |
| 237 after, and will not be true at any time before.") | |
| 238 | |
| 239 (defvar initial-frame-unmapped-p nil) | |
| 240 | |
| 241 | |
| 242 ;;; default switches | |
| 243 ;;; Note: these doc strings are semi-magical. | |
| 244 | |
| 245 (defun command-line-do-funcall (arg) | |
| 246 "Invoke the named lisp function with no arguments. | |
| 247 <function>" | |
| 248 (let ((fn (intern (car command-line-args-left)))) | |
| 249 (setq command-line-args-left (cdr command-line-args-left)) | |
| 250 (funcall fn))) | |
| 251 (fset 'command-line-do-funcall-1 'command-line-do-funcall) | |
| 252 (put 'command-line-do-funcall-1 'undocumented t) | |
| 253 | |
| 254 (defun command-line-do-eval (arg) | |
| 255 "Evaluate the lisp form. Quote it carefully. | |
| 256 <form>" | |
| 257 (let ((form (car command-line-args-left))) | |
| 258 (setq command-line-args-left (cdr command-line-args-left)) | |
| 259 (eval (read form)))) | |
| 260 | |
| 261 (defun command-line-do-load (arg) | |
| 262 "Load the named file of Lisp code into XEmacs. | |
| 263 <file>" | |
| 264 (let ((file (car command-line-args-left))) | |
| 265 ;; Take file from default dir if it exists there; | |
| 266 ;; otherwise let `load' search for it. | |
| 267 (if (file-exists-p (expand-file-name file)) | |
| 268 (setq file (expand-file-name file))) | |
| 269 (load file nil t)) | |
| 270 (setq command-line-args-left (cdr command-line-args-left))) | |
| 271 | |
| 272 (defun command-line-do-insert (arg) | |
| 273 "Insert file into the current buffer. | |
| 274 <file>" | |
| 275 (insert-file-contents (car command-line-args-left)) | |
| 276 (setq command-line-args-left (cdr command-line-args-left))) | |
| 277 | |
| 278 (defun command-line-do-kill (arg) | |
| 279 "Exit XEmacs." | |
| 280 (kill-emacs t)) | |
| 281 | |
| 282 (defun command-line-do-version (arg) | |
| 283 "Print version info and exit." | |
| 284 (princ (concat (emacs-version) "\n") 'external-debugging-output) | |
| 285 (kill-emacs 0)) | |
| 286 | |
| 287 (setq command-switch-alist | |
| 288 (purecopy | |
| 289 '(("-help" . command-line-do-help) | |
| 290 ("-version" . command-line-do-version) | |
| 291 ("-funcall" . command-line-do-funcall) | |
| 292 ("-f" . command-line-do-funcall) | |
| 293 ("-e" . command-line-do-funcall-1) | |
| 294 ("-eval" . command-line-do-eval) | |
| 295 ("-load" . command-line-do-load) | |
| 296 ("-l" . command-line-do-load) | |
| 297 ("-insert" . command-line-do-insert) | |
| 298 ("-i" . command-line-do-insert) | |
| 299 ("-kill" . command-line-do-kill) | |
| 300 ;; Options like +35 are handled specially. | |
| 301 ;; Window-system, site, or package-specific code might add to this. | |
| 302 ;; X11 handles its options by letting Xt remove args from this list. | |
| 303 ))) | |
| 304 | |
| 305 ;;; Processing the command line and loading various init files | |
| 306 | |
| 307 (defun early-error-handler (&rest debugger-args) | |
| 308 "You should probably not be using this." | |
| 309 ;; Used as the debugger during XEmacs initialization; if an error occurs, | |
| 310 ;; print some diagnostics, and kill XEmacs. | |
| 311 | |
| 312 ;; output the contents of the warning buffer, since it won't be seen | |
| 313 ;; otherwise. | |
| 314 ;; #### kludge! The call to Feval forces the pending warnings to | |
| 315 ;; get output. There definitely needs to be a better way. | |
| 316 (let ((buffer (eval (get-buffer-create "*Warnings*")))) | |
| 317 (princ (buffer-substring (point-min buffer) (point-max buffer) buffer) | |
| 318 'external-debugging-output)) | |
| 319 | |
| 320 (let ((string "Initialization error") | |
| 321 (error (nth 1 debugger-args)) | |
| 322 (debug-on-error nil) | |
| 323 (stream 'external-debugging-output)) | |
| 324 (if (null error) | |
| 325 (princ string stream) | |
| 326 (princ (concat "\n" string ": ") stream) | |
| 327 (condition-case () | |
| 328 (display-error error stream) | |
| 329 (error (princ "<<< error printing error message >>>" stream))) | |
| 330 (princ "\n" stream) | |
| 331 (if (memq (car-safe error) '(void-function void-variable)) | |
| 332 (princ " | |
| 333 This probably means that XEmacs is picking up an old version of | |
| 334 the lisp library, or that some .elc files are not up-to-date.\n" | |
| 335 stream))) | |
| 336 (if (not suppress-early-error-handler-backtrace) | |
| 337 (let ((print-length 1000) | |
| 338 (print-level 1000) | |
| 339 (print-escape-newlines t) | |
| 340 (print-readably nil)) | |
| 341 (if (getenv "EMACSLOADPATH") | |
| 342 (princ (format "\n$EMACSLOADPATH is %s" (getenv "EMACSLOADPATH")) | |
| 343 stream)) | |
| 344 (princ (format "\nexec-directory is %S" exec-directory) stream) | |
| 345 (princ (format "\ndata-directory is %S" data-directory) stream) | |
| 346 (princ (format "\ndoc-directory is %S" doc-directory) stream) | |
| 347 (princ (format "\nload-path is %S" load-path) stream) | |
| 348 (princ "\n\n" stream))) | |
| 349 (if (not suppress-early-error-handler-backtrace) | |
| 350 (backtrace stream t))) | |
| 351 (kill-emacs -1)) | |
| 352 | |
| 353 (defun normal-top-level () | |
| 354 (if command-line-processed | |
| 355 (message "Back to top level.") | |
| 356 (setq command-line-processed t) | |
| 357 ;; Canonicalize HOME (PWD is canonicalized by init_buffer in buffer.c) | |
| 358 (if (not (eq system-type 'vax-vms)) | |
| 359 (let ((value (getenv "HOME"))) | |
| 360 (if (and value | |
| 361 (< (length value) (length default-directory)) | |
| 362 (equal (file-attributes default-directory) | |
| 363 (file-attributes value))) | |
| 364 (setq default-directory (file-name-as-directory value))))) | |
| 365 (setq default-directory (abbreviate-file-name default-directory)) | |
| 366 (initialize-xemacs-paths) | |
| 367 (unwind-protect | |
| 368 (command-line) | |
| 369 ;; Do this again, in case .emacs defined more abbreviations. | |
| 370 (setq default-directory (abbreviate-file-name default-directory)) | |
| 371 ;; Specify the file for recording all the auto save files of | |
| 372 ;; this session. This is used by recover-session. | |
| 373 (setq auto-save-list-file-name | |
| 374 (expand-file-name | |
| 375 (format "%s%d-%s" | |
| 376 auto-save-list-file-prefix | |
| 377 (emacs-pid) | |
| 378 (system-name)))) | |
| 379 (run-hooks 'emacs-startup-hook) | |
| 380 (and term-setup-hook | |
| 381 (run-hooks 'term-setup-hook)) | |
| 382 (setq term-setup-hook nil) | |
| 383 ; ;; Modify the initial frame based on what .emacs puts into | |
| 384 ; ;; ...-frame-alist. | |
| 385 (frame-notice-user-settings) | |
| 386 ; ;;####FSFmacs junk | |
| 387 ; ;; Now we know the user's default font, so add it to the menu. | |
| 388 ; (if (fboundp 'font-menu-add-default) | |
| 389 ; (font-menu-add-default)) | |
| 390 (and window-setup-hook | |
| 391 (run-hooks 'window-setup-hook)) | |
| 392 (setq window-setup-hook nil)) | |
| 393 ;;####FSFmacs junk | |
| 394 ; (or menubar-bindings-done | |
| 395 ; (precompute-menubar-bindings)) | |
| 396 )) | |
| 397 | |
| 398 ;;####FSFmacs junk | |
| 399 ;;; Precompute the keyboard equivalents in the menu bar items. | |
| 400 ;(defun precompute-menubar-bindings () | |
| 401 ; (if (eq window-system 'x) | |
| 402 ; (let ((submap (lookup-key global-map [menu-bar]))) | |
| 403 ; (while submap | |
| 404 ; (and (consp (car submap)) | |
| 405 ; (symbolp (car (car submap))) | |
| 406 ; (stringp (car-safe (cdr (car submap)))) | |
| 407 ; (keymapp (cdr (cdr (car submap)))) | |
| 408 ; (x-popup-menu nil (cdr (cdr (car submap))))) | |
| 409 ; (setq submap (cdr submap)))))) | |
| 410 | |
| 411 (defun command-line-early () | |
| 412 ;; This processes those switches which need to be processed before | |
| 413 ;; starting up the window system. | |
| 414 | |
| 415 (setq command-line-default-directory default-directory) | |
| 416 | |
| 417 ;; See if we should import version-control from the environment variable. | |
| 418 (let ((vc (getenv "VERSION_CONTROL"))) | |
| 419 (cond ((eq vc nil)) ;don't do anything if not set | |
| 420 ((or (string= vc "t") | |
| 421 (string= vc "numbered")) | |
| 422 (setq version-control t)) | |
| 423 ((or (string= vc "nil") | |
| 424 (string= vc "existing")) | |
| 425 (setq version-control nil)) | |
| 426 ((or (string= vc "never") | |
| 427 (string= vc "simple")) | |
| 428 (setq version-control 'never)))) | |
| 429 | |
| 430 ;;####FSFmacs | |
| 431 ; (if (let ((ctype | |
| 432 ; ;; Use the first of these three envvars that has a nonempty value. | |
| 433 ; (or (let ((string (getenv "LC_ALL"))) | |
| 434 ; (and (not (equal string "")) string)) | |
| 435 ; (let ((string (getenv "LC_CTYPE"))) | |
| 436 ; (and (not (equal string "")) string)) | |
| 437 ; (let ((string (getenv "LANG"))) | |
| 438 ; (and (not (equal string "")) string))))) | |
| 439 ; (and ctype | |
| 440 ; (string-match iso-8859-1-locale-regexp ctype))) | |
| 441 ; (progn | |
| 442 ; (standard-display-european t) | |
| 443 ; (require 'iso-syntax))) | |
| 444 | |
| 445 (let ((done nil)) | |
| 446 ;; Figure out which user's init file to load, | |
| 447 ;; either from the environment or from the options. | |
| 448 (setq init-file-user (if (noninteractive) nil (user-login-name))) | |
| 449 ;; If user has not done su, use current $HOME to find .emacs. | |
| 450 (and init-file-user (string= init-file-user (user-real-login-name)) | |
| 451 (setq init-file-user "")) | |
| 452 | |
| 453 (while (and (not done) command-line-args-left) | |
| 454 (let ((argi (car command-line-args-left))) | |
| 455 (cond ((or (string-equal argi "-q") | |
| 456 (string-equal argi "-no-init-file")) | |
| 457 (setq init-file-user nil | |
| 458 command-line-args-left (cdr command-line-args-left))) | |
| 459 ((string-equal argi "-no-site-file") | |
| 460 (setq site-start-file nil | |
| 461 command-line-args-left (cdr command-line-args-left))) | |
| 462 ((or (string-equal argi "-u") | |
| 463 (string-equal argi "-user")) | |
| 464 (setq command-line-args-left (cdr command-line-args-left) | |
| 465 init-file-user (car command-line-args-left) | |
| 466 command-line-args-left (cdr command-line-args-left))) | |
| 467 ((string-equal argi "-debug-init") | |
| 468 (setq init-file-debug t | |
| 469 command-line-args-left (cdr command-line-args-left))) | |
| 470 ((string-equal argi "-unmapped") | |
| 471 (setq initial-frame-unmapped-p t | |
| 472 command-line-args-left (cdr command-line-args-left))) | |
| 473 (t (setq done t))))))) | |
| 474 | |
| 475 | |
| 476 (defun command-line () | |
| 477 (let ((command-line-args-left (cdr command-line-args))) | |
| 478 | |
| 479 (let ((debugger 'early-error-handler) | |
| 480 (debug-on-error t)) | |
| 481 (set-default-load-path) | |
| 482 | |
| 483 ;; Process magic command-line switches like -q and -u. Do this | |
| 484 ;; before creating the first frame because some of these switches | |
| 485 ;; may affect that. I think it's ok to do this before establishing | |
| 486 ;; the X connection, and maybe someday things like -nw can be | |
| 487 ;; handled here instead of down in C. | |
| 488 (command-line-early) | |
| 489 | |
| 490 ;; Setup the toolbar icon directory | |
| 491 (if (featurep 'toolbar) | |
| 492 (init-toolbar-location)) | |
| 493 | |
| 494 ;; Initialize the built-in glyphs and the default specifier | |
| 495 ;; lists | |
| 496 (if (not noninteractive) | |
| 497 (init-glyphs)) | |
| 498 | |
| 499 ;; Run the window system's init function. tty is considered to be | |
| 500 ;; a type of window system for this purpose. This creates the | |
| 501 ;; initial (non stdio) device. | |
| 502 (if (and initial-window-system (not noninteractive)) | |
| 503 (funcall (intern (concat "init-" | |
| 504 (symbol-name initial-window-system) | |
| 505 "-win")))) | |
| 506 | |
| 507 ;; When not in batch mode, this creates the first visible frame, | |
| 508 ;; and deletes the stdio device. | |
| 509 (frame-initialize)) | |
| 510 | |
| 511 ;; | |
| 512 ;; We have normality, I repeat, we have normality. Anything you still | |
| 513 ;; can't cope with is therefore your own problem. (And we don't need | |
| 514 ;; to kill XEmacs for it.) | |
| 515 ;; | |
| 516 | |
| 517 ;;; Load init files. | |
| 518 (load-init-file) | |
| 519 | |
| 520 ;; If *scratch* exists and init file didn't change its mode, initialize it. | |
| 521 (if (get-buffer "*scratch*") | |
| 522 (save-excursion | |
| 523 (set-buffer "*scratch*") | |
| 524 (if (eq major-mode 'fundamental-mode) | |
| 525 (funcall initial-major-mode)))) | |
| 526 | |
| 527 ;; Load library for our terminal type. | |
| 528 ;; User init file can set term-file-prefix to nil to prevent this. | |
| 529 ;; Note that for any TTY's opened subsequently, the TTY init | |
| 530 ;; code will run this. | |
| 531 (if (and (eq 'tty (console-type)) | |
| 532 (not (noninteractive))) | |
| 533 (load-terminal-library)) | |
| 534 | |
| 535 ;; Process the remaining args. | |
| 536 (command-line-1) | |
| 537 | |
| 538 ;; it was turned on by default so that the warnings don't get displayed | |
| 539 ;; until after the splash screen. | |
| 540 (setq inhibit-warning-display nil) | |
| 541 ;; If -batch, terminate after processing the command options. | |
| 542 (if (noninteractive) (kill-emacs t)))) | |
| 543 | |
| 544 (defun load-terminal-library () | |
| 545 (and term-file-prefix | |
| 546 (let ((term (getenv "TERM")) | |
| 547 hyphend) | |
| 548 (while (and term | |
| 549 (not (load (concat term-file-prefix term) t t))) | |
| 550 ;; Strip off last hyphen and what follows, then try again | |
| 551 (if (setq hyphend (string-match "[-_][^-_]+\\'" term)) | |
| 552 (setq term (substring term 0 hyphend)) | |
| 553 (setq term nil)))))) | |
| 554 | |
| 555 (defun load-user-init-file (init-file-user) | |
| 556 ;; This function actually reads the init files. | |
| 557 (if init-file-user | |
| 558 (progn | |
| 559 (setq user-init-file | |
| 560 (cond | |
| 561 ((eq system-type 'ms-dos) | |
| 562 (concat "~" init-file-user "/_emacs")) | |
| 563 ((eq system-type 'vax-vms) | |
| 564 "sys$login:.emacs") | |
| 565 (t | |
| 566 (concat "~" init-file-user "/.emacs")))) | |
| 567 (load user-init-file t t t) | |
| 568 (or inhibit-default-init | |
| 569 (let ((inhibit-startup-message nil)) | |
| 570 ;; Users are supposed to be told their rights. | |
| 571 ;; (Plus how to get help and how to undo.) | |
| 572 ;; Don't you dare turn this off for anyone | |
| 573 ;; except yourself. | |
| 574 (load "default" t t)))))) | |
| 575 | |
| 576 ;;; Load user's init file and default ones. | |
| 577 (defun load-init-file () | |
| 578 (run-hooks 'before-init-hook) | |
| 579 | |
| 580 ;; Run the site-start library if it exists. The point of this file is | |
| 581 ;; that it is run before .emacs. There is no point in doing this after | |
| 582 ;; .emacs; that is useless. | |
| 583 (if site-start-file | |
| 584 (load site-start-file t t)) | |
| 585 | |
| 586 ;; Sites should not disable this. Only individuals should disable | |
| 587 ;; the startup message. | |
| 588 (setq inhibit-startup-message nil) | |
| 589 | |
| 590 (let (debug-on-error-from-init-file | |
| 591 debug-on-error-should-be-set | |
| 592 (debug-on-error-initial | |
| 593 (if (eq init-file-debug t) 'startup init-file-debug))) | |
| 594 (let ((debug-on-error debug-on-error-initial)) | |
| 595 (if init-file-debug | |
| 596 ;; Do this without a condition-case if the user wants to debug. | |
| 597 (load-user-init-file init-file-user) | |
| 598 (condition-case error | |
| 599 (progn | |
| 600 (load-user-init-file init-file-user) | |
| 601 (setq init-file-had-error nil)) | |
| 602 (error | |
| 603 (message "Error in init file: ") | |
| 604 (display-error error nil) | |
| 605 (setq init-file-had-error t)))) | |
| 606 ;; If we can tell that the init file altered debug-on-error, | |
| 607 ;; arrange to preserve the value that it set up. | |
| 608 (or (eq debug-on-error debug-on-error-initial) | |
| 609 (setq debug-on-error-should-be-set t | |
| 610 debug-on-error-from-init-file debug-on-error))) | |
| 611 (if debug-on-error-should-be-set | |
| 612 (setq debug-on-error debug-on-error-from-init-file))) | |
| 613 | |
| 614 (setq init-file-loaded t) | |
| 615 | |
| 616 ;; Do this here in case the init file sets mail-host-address. | |
| 617 (or user-mail-address | |
| 618 (setq user-mail-address (concat (user-login-name) "@" | |
| 619 (or mail-host-address | |
| 620 (system-name))))) | |
| 621 | |
| 622 (run-hooks 'after-init-hook) | |
| 623 nil) | |
| 624 | |
| 625 (defun load-options-file (filename) | |
| 626 "Load the file of saved options (from the Options menu) called FILENAME. | |
| 627 Currently this does nothing but call `load', but it might be redefined | |
| 628 in the future to support automatically converting older options files to | |
| 629 a new format, when variables have changed, etc." | |
| 630 (load filename)) | |
| 631 | |
| 632 (defun command-line-1 () | |
| 633 (if (null command-line-args-left) | |
| 634 (cond ((and (not inhibit-startup-message) (not (noninteractive)) | |
| 635 ;; Don't clobber a non-scratch buffer if init file | |
| 636 ;; has selected it. | |
| 637 (string= (buffer-name) "*scratch*") | |
| 638 (not (input-pending-p))) | |
| 639 | |
| 640 ;; If there are no switches to process, run the term-setup-hook | |
| 641 ;; before displaying the copyright notice; there may be some need | |
| 642 ;; to do it before doing any output. If we're not going to | |
| 643 ;; display a copyright notice (because other options are present) | |
| 644 ;; then this is run after those options are processed. | |
| 645 (run-hooks 'term-setup-hook) | |
| 646 ;; Don't let the hook be run twice. | |
| 647 (setq term-setup-hook nil) | |
| 648 | |
| 649 (let ((timeout nil)) | |
| 650 (unwind-protect | |
| 651 ;; Guts of with-timeout | |
| 652 (catch 'timeout | |
| 653 (setq timeout (add-timeout startup-message-timeout | |
| 654 #'(lambda (ignore) | |
| 655 (condition-case nil | |
| 656 (throw 'timeout t) | |
| 657 (error nil))) | |
| 658 nil)) | |
| 659 (startup-splash-frame) | |
| 660 (or nil ;; (pos-visible-in-window-p (point-min)) | |
| 661 (goto-char (point-min))) | |
| 662 (sit-for 0) | |
| 663 (setq unread-command-event (next-command-event))) | |
| 664 (if timeout (disable-timeout timeout)) | |
| 665 (save-excursion | |
| 666 ;; In case the XEmacs server has already selected | |
| 667 ;; another buffer, erase the one our message is in. | |
| 668 (progn | |
| 669 (set-buffer (get-buffer "*scratch*")) | |
| 670 (erase-buffer) | |
| 671 (set-buffer-modified-p nil))))))) | |
| 672 (let ((dir command-line-default-directory) | |
| 673 (file-count 0) | |
| 674 first-file-buffer | |
| 675 (line nil)) | |
| 676 (while command-line-args-left | |
| 677 (let ((argi (car command-line-args-left)) | |
| 678 tem) | |
| 679 (setq command-line-args-left (cdr command-line-args-left)) | |
| 680 (or (cond (line | |
| 681 nil) | |
| 682 ((setq tem (or (assoc argi command-switch-alist) | |
| 683 (and (string-match "\\`--" argi) | |
| 684 (assoc (substring argi 1) | |
| 685 command-switch-alist)))) | |
| 686 (funcall (cdr tem) argi) | |
| 687 t) | |
| 688 ((string-match "\\`\\+[0-9]+\\'" argi) | |
| 689 (setq line (string-to-int argi)) | |
| 690 t) | |
| 691 ((or (equal argi "-") (equal argi "--")) | |
| 692 ;; "- file" means don't treat "file" as a switch | |
| 693 ;; ("+0 file" has the same effect; "-" added | |
| 694 ;; for unixoidiality). | |
| 695 ;; This is worthless; the `unixoid' way is "./file". -jwz | |
| 696 (setq line 0)) | |
| 697 (t | |
| 698 nil)) | |
| 699 (progn | |
| 700 (setq file-count (1+ file-count)) | |
| 701 (setq argi (expand-file-name argi dir)) | |
| 702 (if (= file-count 1) | |
| 703 (setq first-file-buffer (progn (find-file argi) | |
| 704 (current-buffer))) | |
| 705 (if noninteractive | |
| 706 (find-file argi) | |
| 707 (find-file-other-window argi))) | |
| 708 (or (null line) | |
| 709 (zerop line) | |
| 710 (goto-line line)) | |
| 711 (setq line 0))))) | |
| 712 ;; If 3 or more files visited, and not all visible, | |
| 713 ;; show user what they all are. | |
| 714 (if (and (not noninteractive) | |
| 715 (> file-count 2)) | |
| 716 (or (get-buffer-window first-file-buffer) | |
| 717 (progn (other-window 1) | |
| 718 (buffer-menu nil))))))) | |
| 719 | |
| 720 (defvar startup-presentation-hack-keymap | |
| 721 (let ((map (make-sparse-keymap))) | |
| 722 (set-keymap-name map 'startup-presentation-hack-keymap) | |
| 723 (define-key map '[button1] 'startup-presentation-hack) | |
| 724 (define-key map '[button2] 'startup-presentation-hack) | |
| 725 map) | |
| 726 "Putting yesterday in the future tomorrow.") | |
| 727 | |
| 728 (defun startup-presentation-hack () | |
| 729 (interactive) | |
| 730 (let ((e last-command-event)) | |
| 731 (and (button-press-event-p e) | |
| 732 (setq e (extent-at (event-point e) | |
| 733 (event-buffer e) | |
| 734 'startup-presentation-hack)) | |
| 735 (setq e (extent-property e 'startup-presentation-hack)) | |
| 736 (if (consp e) | |
| 737 (apply (car e) (cdr e)) | |
| 738 (progn | |
| 739 (while (keymapp (indirect-function e)) | |
| 740 (let ((map e) | |
| 741 (overriding-local-map (indirect-function e))) | |
| 742 (setq e (read-key-sequence | |
| 743 (let ((p (keymap-prompt map t))) | |
| 744 (cond ((symbolp map) | |
| 745 (if p | |
| 746 (format "%s %s " map p) | |
| 747 (format "%s " map p))) | |
| 748 (p) | |
| 749 (t | |
| 750 (prin1-to-string map)))))) | |
| 751 (if (and (button-release-event-p (elt e 0)) | |
| 752 (null (key-binding e))) | |
| 753 (setq e map) ; try again | |
| 754 (setq e (key-binding e))))) | |
| 755 (call-interactively e)))))) | |
| 756 | |
| 757 (defun startup-presentation-hack-help (e) | |
| 758 (setq e (extent-property e 'startup-presentation-hack)) | |
| 759 (if (consp e) | |
| 760 (format "Evaluate %S" e) | |
| 761 (symbol-name e))) | |
| 762 | |
| 763 (defun splash-frame-present-hack (e v) | |
| 764 ; (set-extent-property e 'mouse-face 'highlight) | |
| 765 ; (set-extent-property e 'keymap | |
| 766 ; startup-presentation-hack-keymap) | |
| 767 ; (set-extent-property e 'startup-presentation-hack v) | |
| 768 ; (set-extent-property e 'help-echo | |
| 769 ; 'startup-presentation-hack-help)) | |
| 770 ) | |
| 771 | |
| 772 (defun splash-frame-present (l) | |
| 773 (cond ((stringp l) | |
| 774 (insert l)) | |
| 775 ((eq (car-safe l) 'face) | |
| 776 ;; (face name string) | |
| 777 (let ((p (point))) | |
| 778 (splash-frame-present (elt l 2)) | |
| 779 (if (fboundp 'set-extent-face) | |
| 780 (set-extent-face (make-extent p (point)) | |
| 781 (elt l 1))))) | |
| 782 ((eq (car-safe l) 'key) | |
| 783 (let* ((c (elt l 1)) | |
| 784 (p (point)) | |
| 785 (k (where-is-internal c nil t))) | |
| 786 (insert (if k (key-description k) | |
| 787 (format "M-x %s" c))) | |
| 788 (if (fboundp 'set-extent-face) | |
| 789 (let ((e (make-extent p (point)))) | |
| 790 (set-extent-face e 'bold) | |
| 791 (splash-frame-present-hack e c))))) | |
| 792 ((eq (car-safe l) 'funcall) | |
| 793 ;; (funcall (fun . args) string) | |
| 794 (let ((p (point))) | |
| 795 (splash-frame-present (elt l 2)) | |
| 796 (if (fboundp 'set-extent-face) | |
| 797 (splash-frame-present-hack (make-extent p (point)) | |
| 798 (elt l 1))))) | |
| 799 ((consp l) | |
| 800 (mapcar 'splash-frame-present l)) | |
| 801 (t | |
| 802 (error "WTF!?")))) | |
| 803 | |
| 804 (defun startup-center-spaces (glyph) | |
| 805 ;; Return the number of spaces to insert in order to center | |
| 806 ;; the given glyph (may be a string or a pixmap). | |
| 807 ;; Assume spaces are as wide as avg-pixwidth. | |
| 808 ;; Won't be quite right for proportional fonts, but it's the best we can do. | |
| 809 ;; Maybe the new redisplay will export something a glyph-width function. | |
| 810 ;;; #### Yes, there is a glyph-width function but it isn't quite what | |
| 811 ;;; #### this was expecting. Or is it? | |
| 812 ;; (An alternate way to get avg-pixwidth would be to use x-font-properties | |
| 813 ;; and calculate RESOLUTION_X * AVERAGE_WIDTH / 722.7, but it's no better.) | |
| 814 | |
| 815 ;; This function is used in about.el too. | |
| 816 (let* ((avg-pixwidth (round (/ (frame-pixel-width) (frame-width)))) | |
| 817 (fill-area-width (* avg-pixwidth (- fill-column left-margin))) | |
| 818 (glyph-pixwidth (cond ((stringp glyph) | |
| 819 (* avg-pixwidth (length glyph))) | |
| 820 ;; #### the pixmap option should be removed | |
| 821 ;;((pixmapp glyph) | |
| 822 ;; (pixmap-width glyph)) | |
| 823 ((glyphp glyph) | |
| 824 (glyph-width glyph)) | |
| 825 (t | |
| 826 (error "startup-center-spaces: bad arg"))))) | |
| 827 (+ left-margin | |
| 828 (round (/ (/ (- fill-area-width glyph-pixwidth) 2) avg-pixwidth))))) | |
| 829 | |
| 830 (defun startup-splash-frame () | |
| 831 (let ((p (point))) | |
| 832 (if (eq 'x (console-type (selected-console))) (insert "\n")) | |
| 833 (indent-to (startup-center-spaces xemacs-logo)) | |
| 834 (set-extent-begin-glyph (make-extent (point) (point)) xemacs-logo) | |
| 835 (if (eq 'x (console-type (selected-console))) | |
| 836 (insert "\n\n") | |
| 837 (insert "\n")) | |
| 838 (splash-frame-present-hack (make-extent p (point)) 'about-xemacs)) | |
| 839 | |
| 840 (insert "\n" (emacs-version) "\n") | |
| 841 (let ((after-change-functions nil) ; no font-lock, thank you | |
| 842 (l `((face bold-italic | |
| 843 "Copyright (C) 1985-1996 Free Software Foundation, Inc. | |
| 844 Copyright (C) 1990-1994 Lucid, Inc. | |
| 845 Copyright (C) 1993-1996 Sun Microsystems, Inc. All Rights Reserved. | |
| 846 Copyright (C) 1994-1996 Board of Trustees, University of Illinois | |
| 847 Copyright (C) 1995-1996 Ben Wing.") | |
| 848 ,@(if (featurep 'sparcworks) '( | |
| 849 "\n\nSunSoft provides support for the SPARCworks/XEmacs EOS integration package | |
| 850 only. All other XEmacs packages are provided to you \"AS IS\".")) | |
| 851 "\n\nType " (key describe-no-warranty) " to refer to the GPL " | |
| 852 "Version 2, dated June 1991, for full details.\n" | |
| 853 "You may give out copies of XEmacs; type " | |
| 854 (key describe-copying) " to see the conditions.\n" | |
| 855 "Type " (key describe-distribution) | |
| 856 " for information on getting the latest version." | |
| 857 | |
| 858 "\n\nType " (key help-command) " for help; " | |
| 859 (key advertised-undo) | |
| 860 " to undo changes. (`C-' means use the CTRL key.)\n" | |
| 861 "To get out of XEmacs, type " (key save-buffers-kill-emacs) ".\n" | |
| 862 "Type " (key help-with-tutorial) | |
| 863 " for a tutorial on using XEmacs.\n" | |
| 864 "Type " (key info) " to enter Info, " | |
| 865 "which you can use to read documentation.\n\n" | |
| 866 (face (bold red) | |
| 867 ( | |
| 868 "For tips and answers to frequently asked questions, see the XEmacs FAQ.\n" | |
| 869 "(It's on the Help menu, or type " | |
| 870 (key xemacs-local-faq) " [a capital F!].)"))))) | |
| 871 (while l | |
| 872 (splash-frame-present (car l)) | |
| 873 (setq l (cdr l)))) | |
| 874 ; (let ((present-file | |
| 875 ; #'(lambda (f) | |
| 876 ; (splash-frame-present | |
| 877 ; (list 'funcall | |
| 878 ; (list 'find-file-other-window | |
| 879 ; (expand-file-name f data-directory)) | |
| 880 ; f))))) | |
| 881 ; (insert "For customization examples, see the files ") | |
| 882 ; (funcall present-file "sample.emacs") | |
| 883 ; (insert " and ") | |
| 884 ; (funcall present-file "sample.Xdefaults") | |
| 885 ; (insert (format "\nin the directory %s." data-directory))) | |
| 886 (set-buffer-modified-p nil)) | |
| 887 | |
| 888 ;;;; Computing the default load-path, etc. | |
| 889 ;;; | |
| 890 ;;; This stuff is a complete mess and isn't nearly as general as it | |
| 891 ;;; thinks it is. It should be rethunk. In particular, too much logic | |
| 892 ;;; is duplicated between the code that looks around for the various | |
| 893 ;;; directories, and the code which suggests where to create the various | |
| 894 ;;; directories once it decides they are missing. | |
| 895 | |
| 896 ;;; The source directory has this layout: | |
| 897 ;;; | |
| 898 ;;; BUILD_ROOT/src/xemacs* argv[0] | |
| 899 ;;; BUILD_ROOT/xemacs* argv[0], possibly | |
| 900 ;;; BUILD_ROOT/lisp/ | |
| 901 ;;; BUILD_ROOT/etc/ data-directory | |
| 902 ;;; BUILD_ROOT/info/ | |
| 903 ;;; BUILD_ROOT/lib-src/ exec-directory, doc-directory | |
| 904 ;;; BUILD_ROOT/lock/ | |
| 905 ;;; | |
| 906 ;;; The default tree created by "make install" has this layout: | |
| 907 ;;; | |
| 908 ;;; PREFIX/bin/xemacs* argv[0] | |
| 909 ;;; PREFIX/lib/xemacs-VERSION/lisp/ | |
| 910 ;;; PREFIX/lib/xemacs-VERSION/etc/ data-directory | |
| 911 ;;; PREFIX/lib/xemacs-VERSION/info/ | |
| 912 ;;; PREFIX/lib/xemacs-VERSION/CONFIGURATION/ exec-directory, doc-directory | |
| 913 ;;; PREFIX/lib/xemacs/lock/ | |
| 914 ;;; PREFIX/lib/xemacs/site-lisp/ | |
| 915 ;;; | |
| 916 ;;; The binary packages we ship have that layout, except that argv[0] has | |
| 917 ;;; been moved one level deeper under the bin directory: | |
| 918 ;;; | |
| 919 ;;; PREFIX/bin/CONFIGURATION/xemacs* | |
| 920 ;;; | |
| 921 ;;; The following code has to deal with at least the above three situations, | |
| 922 ;;; and it should be possible for it to deal with more. Though perhaps that | |
| 923 ;;; does cover it all? The trick is, when something is missing, realizing | |
| 924 ;;; which of those three layouts is mostly in place, so that we can suggest | |
| 925 ;;; the right directories in the error message. | |
| 926 | |
| 927 | |
| 928 ;; extremely low-tech debugging, since this happens so early in startup. | |
| 929 ;(or (fboundp 'orig-file-directory-p) | |
| 930 ; (fset 'orig-file-directory-p (symbol-function 'file-directory-p))) | |
| 931 ;(defun file-directory-p (path) | |
| 932 ; (send-string-to-terminal (format "PROBING %S" path)) | |
| 933 ; (let ((v (orig-file-directory-p path))) | |
| 934 ; (send-string-to-terminal (format " -> %S\n" v)) | |
| 935 ; v)) | |
| 936 | |
| 937 (defun startup-make-version-dir () | |
| 938 (let ((version (and (string-match "\\`[^0-9]*\\([0-9]+\\.[0-9]+\\)" | |
| 939 emacs-version) | |
| 940 (substring emacs-version | |
| 941 (match-beginning 1) (match-end 1))))) | |
| 942 (if (string-match "(beta *\\([0-9]+\\))" emacs-version) | |
| 943 (setq version (concat version "-b" | |
| 944 (substring emacs-version (match-beginning 1) | |
| 945 (match-end 1))))) | |
| 946 (if (string-match "(alpha *\\([0-9]+\\))" emacs-version) | |
| 947 (setq version (concat version "-a" | |
| 948 (substring emacs-version (match-beginning 1) | |
| 949 (match-end 1))))) | |
| 950 (concat "lib/xemacs-" version))) | |
| 951 | |
| 952 (defun find-emacs-root-internal-1 (path lisp-p) | |
| 953 (let ((dir (file-name-directory path))) | |
| 954 (or | |
| 955 ;; | |
| 956 ;; If this directory is a plausible root of the XEmacs tree, return it. | |
| 957 ;; | |
| 958 (and (or (not lisp-p) | |
| 959 (file-directory-p (expand-file-name "lisp/prim" dir))) | |
| 960 (or (file-directory-p (expand-file-name "lib-src" dir)) | |
| 961 (file-directory-p (expand-file-name system-configuration dir))) | |
| 962 dir) | |
| 963 ;; | |
| 964 ;; If the parent of this directory is a plausible root, use it. | |
| 965 ;; (But don't do so recursively!) | |
| 966 ;; | |
| 967 (and (or (not lisp-p) | |
| 968 (file-directory-p (expand-file-name "../lisp/prim" dir))) | |
| 969 (or (file-directory-p (expand-file-name | |
| 970 (format "../%s" system-configuration) | |
| 971 dir)) | |
| 972 (file-directory-p (expand-file-name "../lib-src" dir))) | |
| 973 (expand-file-name "../" dir)) | |
| 974 | |
| 975 ;; | |
| 976 ;; (--run-in-place) Same thing, but from one directory level deeper. | |
| 977 ;; | |
| 978 (and (or (not lisp-p) | |
| 979 (file-directory-p (expand-file-name "../../lisp/prim" dir))) | |
| 980 (or (file-directory-p (expand-file-name | |
| 981 (format "../%s" system-configuration) | |
| 982 dir)) | |
| 983 (file-directory-p | |
| 984 (expand-file-name | |
| 985 (format "../../lib-src/%s" system-configuration) dir))) | |
| 986 (expand-file-name "../.." dir)) | |
| 987 | |
| 988 ;; If ../lib/xemacs-<version> exists check it. | |
| 989 ;; This is of the form "xemacs-19.10/" or "xemacs-19.10-b7/". | |
| 990 ;; | |
| 991 (let ((ver-dir (concat "../" (startup-make-version-dir)))) | |
| 992 (and (or (not lisp-p) | |
| 993 (file-directory-p (expand-file-name | |
| 994 (format "%s/lisp/prim" ver-dir) | |
| 995 dir))) | |
| 996 (or (file-directory-p (expand-file-name | |
| 997 (format "%s/%s" ver-dir | |
| 998 system-configuration) | |
| 999 dir)) | |
| 1000 (file-directory-p (expand-file-name | |
| 1001 (format "%s/lib-src" ver-dir) | |
| 1002 dir))) | |
| 1003 (expand-file-name (file-name-as-directory ver-dir) dir))) | |
| 1004 ;; | |
| 1005 ;; Same thing, but one higher: ../../lib/xemacs-<version>. | |
| 1006 ;; | |
| 1007 (let ((ver-dir (concat "../../" (startup-make-version-dir)))) | |
| 1008 (and (or (not lisp-p) | |
| 1009 (file-directory-p (expand-file-name | |
| 1010 (format "%s/lisp/prim" ver-dir) | |
| 1011 dir))) | |
| 1012 (or (file-directory-p (expand-file-name | |
| 1013 (format "%s/%s" ver-dir | |
| 1014 system-configuration) | |
| 1015 dir)) | |
| 1016 (file-directory-p (expand-file-name | |
| 1017 (format "%s/lib-src" ver-dir) | |
| 1018 dir))) | |
| 1019 (expand-file-name (file-name-as-directory ver-dir) dir))) | |
| 1020 ;; | |
| 1021 ;; If that doesn't work, and the XEmacs executable is a symlink, then | |
| 1022 ;; chase the link and try again there. | |
| 1023 ;; | |
| 1024 (and (setq path (file-symlink-p path)) | |
| 1025 (find-emacs-root-internal-1 (expand-file-name path dir) lisp-p)) | |
| 1026 ;; | |
| 1027 ;; Otherwise, this directory just doesn't cut it. | |
| 1028 ;; Some bozos think they can use the 18.59 lisp directory with 19.*. | |
| 1029 ;; This is because they're not using their brains. But it might be | |
| 1030 ;; nice to notice that that is happening and point them in the | |
| 1031 ;; general direction of a clue. | |
| 1032 ;; | |
| 1033 nil))) | |
| 1034 | |
| 1035 (defun find-emacs-root-internal (path) | |
| 1036 ;; (send-string-to-terminal (format "FINDING ROOT FOR %S\n" path)) | |
| 1037 ;; first look for lisp/prim and lib-src; then just look for lib-src. | |
| 1038 ;; XEmacs can run (kind of) if the lisp directory is omitted, which | |
| 1039 ;; some people might want to do for space reasons. | |
| 1040 (or (find-emacs-root-internal-1 path t) | |
| 1041 (find-emacs-root-internal-1 path nil) | |
| 1042 ;; If we don't succeed we are going to crash and burn for sure. | |
| 1043 ;; Try some paths relative to prefix-directory if it isn't nil. | |
| 1044 ;; This is definitely necessary in cases such as when we're used | |
| 1045 ;; as a login shell since we can't determine the invocation | |
| 1046 ;; directory in that case. | |
| 1047 (find-emacs-root-internal-1 | |
| 1048 (format "%s/bin/%s" prefix-directory invocation-name) t) | |
| 1049 (find-emacs-root-internal-1 | |
| 1050 (format "%s/bin/%s" prefix-directory invocation-name) nil) | |
| 1051 (find-emacs-root-internal-1 | |
| 1052 (format "%s/lib/%s" prefix-directory invocation-name) t) | |
| 1053 (find-emacs-root-internal-1 | |
| 1054 (format "%s/lib/%s" prefix-directory invocation-name) nil) | |
| 1055 )) | |
| 1056 | |
| 1057 (defun set-default-load-path () | |
| 1058 ;; XEmacs -- Steven Baur says invocation directory is nil if you | |
| 1059 ;; try to use XEmacs as a login shell. | |
| 1060 (or invocation-directory (setq invocation-directory default-directory)) | |
| 1061 (setq invocation-directory | |
| 1062 ;; don't let /tmp_mnt/... get into the load-path or exec-path. | |
| 1063 (abbreviate-file-name invocation-directory)) | |
| 1064 | |
| 1065 ;; #### FSFmacs recognizes environment vars EMACSLOCKDIR, etc. | |
| 1066 (let* ((root (find-emacs-root-internal (concat invocation-directory | |
| 1067 invocation-name))) | |
| 1068 (lisp (and root | |
| 1069 (let ((f (expand-file-name "lisp" root))) | |
| 1070 (and (file-directory-p f) f)))) | |
| 1071 (site-lisp (and root | |
| 1072 (or | |
| 1073 (let ((f (expand-file-name "xemacs/site-lisp" root))) | |
| 1074 (and (file-directory-p f) f)) | |
| 1075 (let ((f (expand-file-name "../xemacs/site-lisp" | |
| 1076 root))) | |
| 1077 (and (file-directory-p f) f)) | |
| 1078 ;; the next two are for --run-in-place | |
| 1079 (let ((f (expand-file-name "site-lisp" root))) | |
| 1080 (and (file-directory-p f) f)) | |
| 1081 (let ((f (expand-file-name "lisp/site-lisp" root))) | |
| 1082 (and (file-directory-p f) f)) | |
| 1083 ))) | |
| 1084 (lib-src (and root | |
| 1085 (or | |
| 1086 (let ((f (expand-file-name | |
| 1087 (concat "lib-src/" system-configuration) | |
| 1088 root))) | |
| 1089 (and (file-directory-p f) f)) | |
| 1090 (let ((f (expand-file-name "lib-src" root))) | |
| 1091 (and (file-directory-p f) f)) | |
| 1092 (let ((f (expand-file-name system-configuration root))) | |
| 1093 (and (file-directory-p f) f))))) | |
| 1094 (etc (and root | |
| 1095 (let ((f (expand-file-name "etc" root))) | |
| 1096 (and (file-directory-p f) f)))) | |
| 1097 (info (and root | |
| 1098 (let ((f (expand-file-name "info" root))) | |
| 1099 (and (file-directory-p f) (file-name-as-directory f))))) | |
| 1100 (lock (and root | |
| 1101 (boundp 'lock-directory) | |
| 1102 (if (and lock-directory (file-directory-p lock-directory)) | |
| 1103 (file-name-as-directory lock-directory) | |
| 1104 (or | |
| 1105 (let ((f (expand-file-name "xemacs/lock" root))) | |
| 1106 (and (file-directory-p f) | |
| 1107 (file-name-as-directory f))) | |
| 1108 (let ((f (expand-file-name "../xemacs/lock" root))) | |
| 1109 (and (file-directory-p f) | |
| 1110 (file-name-as-directory f))) | |
| 1111 (let ((f (expand-file-name "lock" root))) | |
| 1112 (and (file-directory-p f) | |
| 1113 (file-name-as-directory f))) | |
| 1114 ;; if none of them exist, make the "guess" be | |
| 1115 ;; the one that set-default-load-path-warning | |
| 1116 ;; will suggest. | |
| 1117 (file-name-as-directory | |
| 1118 (expand-file-name "../xemacs/lock" root)) | |
| 1119 ))))) | |
| 1120 ;; add site-lisp dir to load-path | |
| 1121 (if site-lisp | |
| 1122 (progn | |
| 1123 ;; If the site-lisp dir isn't on the load-path, add it to the end. | |
| 1124 (or (member site-lisp load-path) | |
| 1125 (setq load-path (append load-path (list site-lisp)))) | |
| 1126 ;; Also add any direct subdirectories of the site-lisp directory | |
| 1127 ;; to the load-path. But don't add dirs whose names begin | |
| 1128 ;; with dot or hyphen. | |
| 1129 (let ((files (directory-files site-lisp nil "^[^-.]" nil 'dirs-only)) | |
| 1130 file) | |
| 1131 (while files | |
| 1132 (setq file (car files)) | |
| 1133 (if (and (not (member file '("RCS" "CVS" "SCCS"))) | |
| 1134 (setq file (expand-file-name file site-lisp)) | |
| 1135 (not (member file load-path))) | |
| 1136 (setq load-path | |
| 1137 (nconc load-path | |
| 1138 (list (file-name-as-directory file))))) | |
| 1139 (setq files (cdr files)))) | |
| 1140 )) | |
| 1141 ;; add lisp dir to load-path | |
| 1142 (if lisp | |
| 1143 (progn | |
| 1144 ;; If the lisp dir isn't on the load-path, add it to the end. | |
| 1145 (or (member lisp load-path) | |
| 1146 (setq load-path (append load-path (list lisp)))) | |
| 1147 ;; Also add any direct subdirectories of the lisp directory | |
| 1148 ;; to the load-path. But don't add dirs whose names begin | |
| 1149 ;; with dot or hyphen. | |
| 1150 (let ((files (directory-files lisp nil "^[^-.]" nil 'dirs-only)) | |
| 1151 file) | |
| 1152 (while files | |
| 1153 (setq file (car files)) | |
| 1154 (if (and (not (member file '("RCS" "CVS" "SCCS"))) | |
| 1155 (setq file (expand-file-name file lisp)) | |
| 1156 (not (member file load-path))) | |
| 1157 (setq load-path | |
| 1158 (nconc load-path | |
| 1159 (list (file-name-as-directory file))))) | |
| 1160 (setq files (cdr files)))) | |
| 1161 )) | |
| 1162 | |
| 1163 ;; If running from the build directory, always prefer the exec-directory | |
| 1164 ;; that is here over the one that came from paths.h. | |
| 1165 (if (or (and (null exec-directory) lib-src) | |
| 1166 (and (equal lib-src (expand-file-name "lib-src" root)) | |
| 1167 (not (equal exec-directory lib-src)))) | |
| 1168 (setq exec-directory (file-name-as-directory lib-src))) | |
| 1169 (if (or (and (null doc-directory) lib-src) | |
| 1170 (and (equal lib-src (expand-file-name "lib-src" root)) | |
| 1171 (not (equal doc-directory lib-src)))) | |
| 1172 (setq doc-directory (file-name-as-directory lib-src))) | |
| 1173 | |
| 1174 (if exec-directory | |
| 1175 (or (member exec-directory exec-path) | |
| 1176 (setq exec-path (append exec-path (list exec-directory))))) | |
| 1177 (if (or (and (null data-directory) etc) | |
| 1178 (and (equal etc (expand-file-name "etc" root)) | |
| 1179 (not (equal data-directory etc)))) | |
| 1180 (setq data-directory (file-name-as-directory etc))) | |
| 1181 | |
| 1182 | |
| 1183 | |
| 1184 ;; If `configure' specified an info dir, use it. | |
| 1185 (or (boundp 'Info-default-directory-list) | |
| 1186 (setq Info-default-directory-list nil)) | |
| 1187 (cond (configure-info-directory | |
| 1188 (setq configure-info-directory (file-name-as-directory | |
| 1189 configure-info-directory)) | |
| 1190 (or (member configure-info-directory Info-default-directory-list) | |
| 1191 (setq Info-default-directory-list | |
| 1192 (append Info-default-directory-list | |
| 1193 (list configure-info-directory)))))) | |
| 1194 ;; If we've guessed the info dir, use that (too). | |
| 1195 (if (and info (not (member info Info-default-directory-list))) | |
| 1196 (setq Info-default-directory-list | |
| 1197 (append Info-default-directory-list (list info)))) | |
| 1198 | |
| 1199 ;; Default the lock dir to being a sibling of the data-directory. | |
| 1200 ;; If superlock isn't set, or is set to a file in a nonexistent | |
| 1201 ;; directory, derive it from the lock dir. | |
| 1202 (if (boundp 'lock-directory) | |
| 1203 (progn | |
| 1204 (setq lock-directory lock) | |
| 1205 (cond ((null lock-directory) | |
| 1206 (setq superlock-file nil)) | |
| 1207 ((or (null superlock-file) | |
| 1208 (not (file-directory-p | |
| 1209 (file-name-directory superlock-file)))) | |
| 1210 (setq superlock-file | |
| 1211 (expand-file-name "!!!SuperLock!!!" | |
| 1212 lock-directory)))))) | |
| 1213 | |
| 1214 (set-default-load-path-warning))) | |
| 1215 | |
| 1216 | |
| 1217 (defun set-default-load-path-warning () | |
| 1218 (let ((lock (if (boundp 'lock-directory) lock-directory 't)) | |
| 1219 warnings message guess) | |
| 1220 (if (and (stringp lock) (not (file-directory-p lock))) | |
| 1221 (setq lock nil)) | |
| 1222 (cond | |
| 1223 ((not (and exec-directory data-directory doc-directory load-path lock)) | |
| 1224 (save-excursion | |
| 1225 (set-buffer (get-buffer-create " *warning-tmp*")) | |
| 1226 (erase-buffer) | |
| 1227 (buffer-disable-undo (current-buffer)) | |
| 1228 (if (null lock) | |
| 1229 (setq warnings (cons "lock-directory" warnings))) | |
| 1230 (if (null exec-directory) | |
| 1231 (setq warnings (cons "exec-directory" warnings))) | |
| 1232 (if (null data-directory) | |
| 1233 (setq warnings (cons "data-directory" warnings))) | |
| 1234 (if (null doc-directory) | |
| 1235 (setq warnings (cons "doc-directory" warnings))) | |
| 1236 (if (null load-path) | |
| 1237 (setq warnings (cons "load-path" warnings))) | |
| 1238 (cond ((cdr (cdr warnings)) | |
| 1239 (setq message (apply 'format "%s, %s, and %s" warnings))) | |
| 1240 ((cdr warnings) | |
| 1241 (setq message (apply 'format "%s and %s" warnings))) | |
| 1242 (t (setq message (format "variable %s" (car warnings))))) | |
| 1243 (insert "couldn't find an obvious default for " message | |
| 1244 ", and there were no defaults specified in paths.h when " | |
| 1245 "XEmacs was built. Perhaps some directories don't exist, " | |
| 1246 "or the XEmacs executable, " (concat invocation-directory | |
| 1247 invocation-name) | |
| 1248 " is in a strange place?") | |
| 1249 (setq guess (or exec-directory | |
| 1250 data-directory | |
| 1251 doc-directory | |
| 1252 (car load-path) | |
| 1253 (and (string-match "/[^/]+\\'" invocation-directory) | |
| 1254 (substring invocation-directory 0 | |
| 1255 (match-beginning 0))))) | |
| 1256 (if (and guess | |
| 1257 (or | |
| 1258 ;; parent of a terminal bin/<configuration> pair (hack hack). | |
| 1259 (string-match (concat "/bin/" | |
| 1260 (regexp-quote system-configuration) | |
| 1261 "/?\\'") | |
| 1262 guess) | |
| 1263 ;; parent of terminal src, lib-src, etc, or lisp dir. | |
| 1264 (string-match | |
| 1265 "/\\(bin\\|src\\|lib-src\\|etc\\|lisp\\)[^/]*/?\\'" | |
| 1266 guess))) | |
| 1267 (setq guess (substring guess 0 (match-beginning 0)))) | |
| 1268 | |
| 1269 ;; If neither the exec nor lisp dirs are around, then "guess" that | |
| 1270 ;; the new configure-style lib dir should be used. Otherwise, if | |
| 1271 ;; only one of them appears to be missing, or it's just lock, | |
| 1272 ;; then guess it to be a sibling of whatever already exists. | |
| 1273 (if (and (null exec-directory) (null load-path)) | |
| 1274 (setq guess (expand-file-name (startup-make-version-dir) guess))) | |
| 1275 | |
| 1276 (if (or (null exec-directory) (null load-path)) | |
| 1277 (insert | |
| 1278 "\n\nWithout both exec-directory and load-path, XEmacs will " | |
| 1279 "be very broken. ")) | |
| 1280 (if (and (null exec-directory) guess) | |
| 1281 (insert | |
| 1282 "Consider making a symbolic link from " | |
| 1283 (expand-file-name system-configuration guess) | |
| 1284 " to wherever the appropriate XEmacs exec-directory " | |
| 1285 "directory is")) | |
| 1286 (if (and (null data-directory) guess) | |
| 1287 (insert | |
| 1288 (if exec-directory | |
| 1289 "\n\nConsider making a symbolic link " ", and ") | |
| 1290 "from " | |
| 1291 (expand-file-name "etc" (if load-path | |
| 1292 (file-name-directory | |
| 1293 (directory-file-name | |
| 1294 (car load-path))) | |
| 1295 guess)) | |
| 1296 " to wherever the appropriate XEmacs data-directory is")) | |
| 1297 (if (and (null load-path) guess) | |
| 1298 (insert | |
| 1299 (if (and exec-directory data-directory) | |
| 1300 "Consider making a symbolic link " | |
| 1301 ", and ") | |
| 1302 "from " | |
| 1303 (expand-file-name "lisp" guess) | |
| 1304 " to wherever the appropriate XEmacs lisp library is")) | |
| 1305 (insert ".") | |
| 1306 | |
| 1307 (if (null lock) | |
| 1308 (progn | |
| 1309 (insert | |
| 1310 "\n\nWithout lock-directory set, file locking won't work. ") | |
| 1311 (if guess | |
| 1312 (insert | |
| 1313 "Consider creating " | |
| 1314 (expand-file-name "../xemacs/lock" | |
| 1315 (or (find-emacs-root-internal | |
| 1316 (concat invocation-directory | |
| 1317 invocation-name)) | |
| 1318 guess)) | |
| 1319 " as a directory or symbolic link for use as the lock " | |
| 1320 "directory. (This directory must be globally writable.)" | |
| 1321 )))) | |
| 1322 | |
| 1323 (if (fboundp 'fill-region) | |
| 1324 ;; Might not be bound in the cold load environment... | |
| 1325 (let ((fill-column 76)) | |
| 1326 (fill-region (point-min) (point-max)))) | |
| 1327 (goto-char (point-min)) | |
| 1328 (princ "\nWARNING:\n" 'external-debugging-output) | |
| 1329 (princ (buffer-string) 'external-debugging-output) | |
| 1330 (erase-buffer) | |
| 1331 t))))) | |
| 1332 | |
| 1333 | |
| 1334 ;;; startup.el ends here |