;;; -*- Mode: Zetalisp; Package: SYSTEM-INTERNALS; Base: 8 -*-

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (C) 1985, Texas Instruments Incorporated. All rights reserved.
;;;
;;;


;;; This is version meant to be called by user.
(Defun Shutdown (&key (type :USER) (ask t))
  "Use this function to shut down the system in an orderly fashion.  It does general
cleanup work, such as calling LOGOUT, before halting the processor.
  The ASK keyword controls whether you will be asked if you REALLY want to shut down
the system.  ASK defaults to T.  Note that the shutdown will proceed after 60 seconds
if the question is not answered.
  You can use C-M-Abort to break out of this function before the last status message
appears.  However, the state of the system will be unknown.  The network and file
system will probably be gone.
  The TYPE keyword controls the shutdown message that will be sent to any active servers
and written to the who-line documentation window.  The message used is picked up
from the SI:SHUTDOWN-REASON-STRING property of the symbol used as TYPE.  You may take
advantage of this feature to send your own customized message to the who line when
calling Shutdown.  The default package for the TYPE symbol is SI. "
  
  (let ((go-ahead (if ask
		      (with-timeout ((* 60. 60.) t)	;T after 60 seconds
			(Y-OR-N-P "~&Do you really want to shut down the system?~
                                   ~%(Automatic yes after 60 seconds.)"))
		      t)))
    (when go-ahead 
      (if (eq type :USER)			;If :USER type, send generic message based on userid.
	  (if (and (boundp 'user-id)(stringp user-id)(not (string-equal user-id "")))
	      (System-Shutdown :type type :reason-string
			       (format nil "Shutdown by user: ~A" user-id))
	      (System-Shutdown :type type :reason-string "Shutdown by local user"))
	  (System-Shutdown :type type)))))


;;; Tune to play.
(DefVar *swan-song*
	  '((1 1 1 1 -1 4 3 3 1 1 0 1)	
	    (7 6 2 6  1 5 2 5 2 5 2 15)))

;;; This is the version that can be called from system functions.  
(Defun System-Shutdown (&key (type :SYSTEM) reason-string
			(stream terminal-io) (return nil))
  "This function is meant to be called only from system-level code to shut down the system
in an orderly fashion.  It does general cleanup work, such as calling LOGOUT, before halting
the processor.  DO NOT use this function if you just want the machine to drop dead because
you have encountered an unrecoverable error.  In that case, use si:%crash instead, and be
sure to provide a crash code.
  If the keyword RETURN is non-nil, this function WILL return (that is, it will shut
down all activity but not call si%crash).  If you use this option PLEASE look at the
code to make sure it does all the quieting you want done.  Do not expect the network
or the file system to be around when the function returns.  If the RETURN keyword is NIL
(the default) the function will end by calling si:%crash with a code of 0, indicating
a normal shutdown.
  If the optional STREAM keyword is non-nil (it defaults to terminal-io) some status
messages will be displayed to stream STREAM as the system shuts down.
  The TYPE keyword controls the shutdown message that will be sent to any active servers
and written to the who-line documentation window.  The message used is picked up
from the SI:SHUTDOWN-REASON-STRING property of the symbol used as TYPE.  You may take
advantage of this feature to send your own customized message to the who line when
calling Shutdown.  The default package for the TYPE symbol is SI.  Optionally, you may
provide a REASON-STRING that will be used as the message text."
  
  (if (null reason-string)
      (Let ((prop-reason (get type 'shutdown-reason-string)))
	(Setq reason-string
	      (if (not (null prop-reason))
		  prop-reason
		  (format nil "Shutdown for ~A" type)))))
  
  ;; Do miscellaneous cleanup.
  (if stream
      (format stream
	      "~%Notifying network servers"))
  (setq chaos:chaos-servers-enabled nil)	;Allow no new servers.
  (notify-all-servers reason-string)		;Notify any friends we have left we're going down.
  (if stream
      (format stream
	      "~%Processing logout"))
  (logout)					;Undo user inits and get username off screen.
  (if stream
      (format stream
	      "~%Shutting down file system"))
  (fs:lmfs-close-all-files)			;Close any open streams our local file system
						; is serving.  Not done by file sys dismount,
						; but may be redundant considering what comes next.
  (fs:close-all-files)				;Close any open file streams we've left open.
  (chaos:reset)					;Blow off any network connections
						; that are left.  Stand alone after this.
  (fs:dismount-file-system)			;Help keep file system nice.
  
  
  ;; Tell user going down now.
  (if stream
      (format stream
	      "~%So long...."))
;;;  (if (fboundp 'tv:play-song)			;Last chance to C-M-Abort out....
;;;      (if (boundp '*swan-song*)			;User can change this if he can figure out how!
;;;	  (let ((tv:beeps*zowie *swan-song*))	; Please bind over *swan-song* instead of setq'ing
;;;	    (tv:play-song 'zowie 256. 14000.))))	;so original isn't lost.
  (%open-mouse-cursor)				;Hide the mouse

  (without-interrupts				;Don't allow who-line updates etc.
    (*CATCH 'TV:PAGE-OVERFLOW			;Dont let documentation window overflow
      (PROGN					; stop shutdown
	;; Make mouse doc window empty.
	(send TV:Who-Line-Documentation-Window :Clear-Screen)
	(send TV:Who-Line-Documentation-Window :Line-Out reason-string)
	;; Display message about restarting.
	(send TV:Who-Line-Documentation-Window :Line-Out
	      "To restart:  Hold both control keys and both meta keys and press RUBOUT, M, or ABORT")
	))
    
    ;; Next two forms update the runstate
    (setq tv:who-line-run-state "Shutdown")
    (tv:who-line-update t)
    
    ;; "Turn down the contrast"  Makes all the black areas into gray, leaves white alone.
    (let* ((screen-array (tv:sheet-screen-array tv:main-screen))
	   (width (tv:sheet-width tv:main-screen))
	   (height (tv:sheet-height tv:main-screen)))
      (bitblt tv:alu-andca width height tv:50%-gray 0 0 screen-array 0 0))
    
    ;; If no return requested, really go down by calling %crash.
    ;; First arg of 0 is normal shutdown code;
    ;; last arg is PAWS-UP-P.  NIL means not to inverse the screen since we have
    ;; already done a bunch of stuff to indicate that the machine is not normal.
    (if (not return)
	(si:%halt)				;;;	(si:%crash 0 nil nil)
	)))


(Defun Notify-All-Servers (string)
  "Internal function used by si:system-shutdown to notify all active servers
that machine is going down.  Sends STRING to all active servers."
  (Let (Hosts)
    (Loop for server in (send TV:Who-Line-File-State-Sheet :Servers)	;Active servers
	  do (let ((host (TV:SERVER-DESC-HOST-NAME server)))
	       (unless (memq host Hosts)	;Don't send more than one message
		 (Push host hosts))))
    (Loop for shost in Hosts
	  do (Chaos:Notify shost string))))

;;;(Defun %Halt ()
;;;  "Obsolete function for halting system.  Use SI:SHUTDOWN instead."
;;;  (format terminal-io "~%Please use SI:SHUTDOWN."))