; -*- Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Base:8 -*-

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(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-1989 Texas Instruments Incorporated. All rights reserved.
;	** (c) Copyright 1980 Massachusetts Institute of Technology **

; LISP Machine Package for Logging In and Out.		DLW 11/13/77 

;; List of forms to be evaluated on logout
;; to undo the things done at login.
;; The various LOGIN-MUMBLE functions push undo forms on this list.

(DEFVAR LOGOUT-LIST NIL "List of forms to evaluate on logout, to undo effects of init file.")

;History so we can tell who has had their little paws into a saved band.
;List of elements (user host cadr time)
(DEFVAR LOGIN-HISTORY NIL
  "Each element is (user-name host-object-logged-into local-pretty-host-name date-as-string)")

(DEFUN PRINT-LOGIN-HISTORY (&OPTIONAL (STREAM *STANDARD-OUTPUT*) (HISTORY LOGIN-HISTORY))
  "Print out information on who has used this machine onto STREAM."
  (FORMAT STREAM "~&Who~15TLogin host~30TPhysical lisp machine~60TDate  and  time ")
  (FORMAT STREAM "~&---~15T----------~30T---------------------~60T----------------")
  (DOLIST (ENTRY HISTORY)
    ;;"~%~A at ~A~@[~28T~A~]~@[~46T~\TIME\~]
    (FORMAT STREAM "~&~A~15T~A~30T~A~60T~A"
	    (FIRST ENTRY) ;;who
	    (SECOND ENTRY);;login host
	    (THIRD ENTRY) ;;machine
	    (OR (FOURTH ENTRY) "     unknown"))) ;;time
  (VALUES))

(proclaim '(special *Adaptive-training-on-at-login?*))

;;; rjf 10/6/87  - turn adaptive training on if okay yop do so
(DEFUN LOGIN (USER-NAME &OPTIONAL (HOST associated-machine) INHIBIT-INIT-FILE-P)
  "Log in, specifying user name and host.
This identifies you, for the sake of other users running FINGER.
You cannot access files until you have logged in.
You can log in on any host that files can be read from, including
the local file system if one is loaded."
  ;; Do this so LOGIN init list has the correct enviroment.
  (DECLARE (SPECIAL USER-ID HOST ))
  (LET ((WIN-P NIL)
	(LOAD-INIT-FILE-P (NOT INHIBIT-INIT-FILE-P)))
    (declare (special LOAD-INIT-FILE-P))
    (UNWIND-PROTECT
      (PROGN
	(LOGOUT)
	(AND (EQ HOST T)			;For compatibility
	     (SETQ HOST ASSOCIATED-MACHINE LOAD-INIT-FILE-P NIL))
	(SETQ USER-ID (STRING-TRIM '(#\SP) (STRING USER-NAME)))
	(SETQ HOST (FS:GET-PATHNAME-HOST HOST))
	(SETQ FS:USER-LOGIN-MACHINE HOST)
	(INITIALIZATIONS 'LOGIN-INITIALIZATION-LIST)
	(RESET-INITIALIZATIONS 'LOGOUT-INITIALIZATION-LIST)
	(PUSH (LIST USER-ID HOST
		    (AND (BOUNDP 'LOCAL-PRETTY-HOST-NAME) LOCAL-PRETTY-HOST-NAME)
		    (AND (FBOUNDP 'TIME:PRINT-CURRENT-TIME) (TIME:PRINT-CURRENT-TIME NIL)))
	      LOGIN-HISTORY)
	;; This is an attempt to prevent losers from losing and writing on the LISPM directory
	(FS:SET-DEFAULT-PATHNAME (FS:USER-HOMEDIR) FS:*DEFAULT-PATHNAME-DEFAULTS*)
	(FS:SET-DEFAULT-PATHNAME (FS:USER-HOMEDIR) FS:LOAD-PATHNAME-DEFAULTS)
	(SETQ WIN-P T)

	(WHEN LOAD-INIT-FILE-P
	  (LOAD (FS:INIT-FILE-PATHNAME "LOGIN" HOST T) :if-does-not-exist nil)
	  (WHEN *ADAPTIVE-TRAINING-ON-AT-LOGIN?*
	    (TRAINING-ON))) )

      (IF (NOT WIN-P)
	  ;; If user aborts during login, particularly if he types Abort when
	  ;; being asked for his password, log him out so he can try again.  But
	  ;; if he aborts about of loading the init file, leave him logged in.
	  (LOGOUT))))
  T)

;;; LOG1 is an alternate form of LOGIN, which has two additional features.
;;; The proper form is:
;;; (LOG1 user ':keyword1 argument1 ':keyword2 argument2...)
;;; There are two predefined keywords, HOST and INIT. HOST sets the
;;; associated machine, INIT is a boolean which loads the user's init-file
;;; when true. All other keywords are placed into SI:USER-INIT-OPTIONS,
;;; along with their arguments. This allows users to have their own login
;;; options which their init-file processes.

(DEFVAR USER-INIT-OPTIONS NIL
  "While executing the init file, this holds the options given to LOG1.")

;; 02/08/89 clm - fixed to call LOGIN with the appropriate value for
;; INHIBIT-INIT-FILE-P (SPR 9080).
(DEFUN LOG1 (USER-NAME &REST USER-INIT-OPTIONS
	     &KEY &OPTIONAL (HOST ASSOCIATED-MACHINE) (INIT T)
	     &ALLOW-OTHER-KEYS)
  "Log in, specifying user name and other options.
This identifies you, for the sake of other users running FINGER.
You cannot access files until you have logged in.
You can log in on any host that files can be read from, including
the local file system if one is loaded.
The options :HOST and :INIT say what host to log in on
and whether to run your init file.  Other options may be found
in the variable USER-INIT-OPTIONS by your init file, which can
use them to decide what to do."
  (LOGIN USER-NAME HOST (not INIT)))

(DEFUN LOGOUT ()
  "Log out.  Undoes certain things done by logging in, or by your init file.
It is not usually useful to log out, since cold-booting the machine
is usually preferable."
  (MAPC 'GLOBAL:EVAL LOGOUT-LIST)
  (INITIALIZATIONS 'LOGOUT-INITIALIZATION-LIST)
  (RESET-INITIALIZATIONS 'LOGIN-INITIALIZATION-LIST)
  ;; Do this last so that the initializations won't ask you to login.
  (SETQ USER-ID ""
	FS:USER-HOMEDIRS ()
	FS:USER-PERSONAL-NAME ""
	FS:USER-PERSONAL-NAME-FIRST-NAME-FIRST ""
	FS:USER-GROUP-AFFILIATION #\-
	FS:USER-LOGIN-MACHINE ASSOCIATED-MACHINE)
  (SETQ LOGOUT-LIST ())
  T)   

(DEFMACRO LOGIN-FORMS (&BODY FORMS)
  "Execute FORMS, arranging to undo them at logout."
  `(UNDOABLE-FORMS-1 'LOGOUT-LIST ',FORMS "at logout"))

(DEFUN UNDOABLE-FORMS-1 (UNDO-LIST-NAME FORMS &OPTIONAL (COMPLAINT-STRING ""))
  (DOLIST (FORM FORMS)
    (LET ((U (UNDOABLE-EVAL FORM)))
      (IF (EQ U T)
	  (FORMAT T "~&[A ~S form is supposed to be undone ~A~% but this is not implemented.
The form's effects will be permanent.]~%"
		  (CAR FORM)
		  COMPLAINT-STRING)
	(AND U (PUSH U (SYMBOL-VALUE UNDO-LIST-NAME)))))))

(DEFUN UNDOABLE-EVAL (FORM)
  (IF (ATOM FORM)
      (PROGN (*EVAL FORM) NIL)
    (LET ((UNDOER (GET (CAR FORM) ':UNDO-FUNCTION))
	  TEM)
      (IF (AND (NOT UNDOER)
	       (NEQ FORM (SETQ TEM (MACROEXPAND-1 FORM))))
	  (UNDOABLE-EVAL TEM)
	(PROG1 (IF UNDOER (FUNCALL UNDOER FORM) T)
	       (*EVAL FORM))))))  

(DEFUN (:PROPERTY SETQ :UNDO-FUNCTION) (FORM &AUX RESULTS)
  (DO ((L (CDR FORM) (CDDR L)))
      ((NULL L)
       NIL)
    (COND
      ((BOUNDP (CAR L)) (PUSH `(SETQ ,(CAR L) ',(SYMBOL-VALUE (CAR L))) RESULTS))
      (T (PUSH `(MAKUNBOUND ',(CAR L)) RESULTS))))
  `(PROGN
     . ,RESULTS)) 

(DEFPROP DEFF UNDO-DEFINITION :UNDO-FUNCTION)
(DEFPROP MACRO UNDO-DEFINITION :UNDO-FUNCTION)
(DEFPROP DEFUN UNDO-DEFINITION :UNDO-FUNCTION)
(DEFPROP DEFSUBST UNDO-DEFINITION :UNDO-FUNCTION)

(DEFUN UNDO-DEFINITION (FORM)
  (LET ((FUNCTION-NAME (CADR FORM)))
    (IF (FDEFINEDP FUNCTION-NAME)
	`(FDEFINE ',FUNCTION-NAME ',(FDEFINITION FUNCTION-NAME))
      `(FUNDEFINE ',FUNCTION-NAME))))

(DEFUN (:PROPERTY ADVISE :UNDO-FUNCTION) (FORM)
  `(UNADVISE ,(SECOND FORM) ,(THIRD FORM) ,(FOURTH FORM))) 

(DEFUN LOGIN-EVAL (FORM)	;Value returned by such a form is how to undo it
  "Arrange to undo the effects of FORM when (LOGOUT) is done.
The value produced by FORM is assumed to be another form which will undo it.
That value is pushed on LOGOUT-LIST so the effects of FORM will be
undone when you call LOGOUT."
  (PUSH FORM LOGOUT-LIST))

(DEFUN LOGIN-SETQ (&QUOTE &REST L);Undoing SETQ
  "Like SETQ, but the changes are undone by logging out."
  (DO ((L L (CDDR L)))
      ((NULL L)
       NIL)
    (COND
      ((BOUNDP (CAR L)) (PUSH `(SETQ ,(CAR L) ',(SYMBOL-VALUE (CAR L))) LOGOUT-LIST))
      (T (PUSH `(MAKUNBOUND ',(CAR L)) LOGOUT-LIST)))
    (SET (CAR L)(*EVAL (CADR L)))))

;Undoable FDEFINE.
(DEFUN LOGIN-FDEFINE (FUNCTION-NAME DEFINITION)  ;Undoing FDEFINE
  "Like FDEFINE, but the changes are undone by logging out."
  (PUSH (IF (FDEFINEDP FUNCTION-NAME)
	    `(FDEFINE ',FUNCTION-NAME ',(FDEFINITION FUNCTION-NAME))
	  `(FUNDEFINE ',FUNCTION-NAME))
	LOGOUT-LIST)
  (FDEFINE FUNCTION-NAME DEFINITION))

(DEFMACRO SETQ-GLOBALLY (&REST VARIABLES-AND-FORMS)
  "Like SETQ but sets the global bindings of the variables, not the current bindings.
It works by doing the SETQ in another process."
  (CONS 'PROGN (LOOP FOR (VAR FORM) ON VARIABLES-AND-FORMS BY 'CDDR
		     COLLECT `(SET-GLOBALLY ',VAR ,FORM))))

(DEFUN PROCESS-RUN-FUNCTION-WAIT (NAME FUNCTION &REST ARGS)
  (PROCESS-WAIT (IF (CONSP NAME) (CAR NAME) NAME)
		#'(LAMBDA (PROCESS) (NOT (SEND PROCESS ':RUNNABLE-P)))
		(APPLY 'PROCESS-RUN-FUNCTION NAME FUNCTION ARGS)))

(DEFUN (:PROPERTY SETQ-GLOBALLY :UNDO-FUNCTION) (FORM &AUX RESULTS)
  (DO ((L (CDR FORM) (CDDR L)))
      ((NULL L)
       NIL)
    (COND
      ((BOUNDP-GLOBALLY (CAR L))
       (PUSH `(SET-GLOBALLY ',(CAR L) ',(SYMEVAL-GLOBALLY (CAR L))) RESULTS))
      (T (PUSH `(MAKUNBOUND-GLOBALLY ',(CAR L)) RESULTS))))
  `(PROGN
     . ,RESULTS)) 

(DEFUN BOUNDP-GLOBALLY (SYMBOL)
  "T if the global binding of SYMBOL is not unbound.
This is the binding that is in effect outside of rebindings made in this stack group;
the binding seen in any other stack group that does not rebind SYMBOL."
  (MULTIPLE-VALUE-BIND (NIL NIL LOCATION)
      (SYMEVAL-IN-STACK-GROUP SYMBOL CURRENT-STACK-GROUP 0)
    (LOCATION-BOUNDP LOCATION)))

(DEFUN MAKUNBOUND-GLOBALLY (SYMBOL)
  "Make the global binding of SYMBOL be unbound.
This is the binding that is in effect outside of rebindings made in this stack group;
the binding seen in any other stack group that does not rebind SYMBOL."
  (MULTIPLE-VALUE-BIND (NIL NIL LOCATION)
      (SYMEVAL-IN-STACK-GROUP SYMBOL CURRENT-STACK-GROUP 0)
    (LOCATION-MAKUNBOUND LOCATION SYMBOL))
  SYMBOL)

(DEFUN SET-GLOBALLY (SYMBOL VALUE)
  "Set the global binding of SYMBOL to VALUE.
This is the binding that is in effect outside of rebindings made in this stack group;
the value seen in any other stack group that does not rebind SYMBOL."
  (EH:SET-IN-STACK-GROUP SYMBOL CURRENT-STACK-GROUP VALUE 0))

(DEFUN SYMEVAL-GLOBALLY (SYMBOL)
  "Return the global binding of SYMBOL.
This is the value that is in effect outside of rebindings made in this stack group;
the value seen in any other stack group that does not rebind SYMBOL."
  (VALUES (SYMEVAL-IN-STACK-GROUP SYMBOL CURRENT-STACK-GROUP 0)))

;; Support for WITH-SYS-HOST-ACCESSIBLE macro.

;; Make sure we can access files from the sys host.
;; If not logged in, log in.
;; If logged in, make sure we know something to log in our file server on on that host.
;; Also make sure we know the password for the sys login on that host.
;; Returns a form to evaluate to undo what we did.
(DEFUN MAYBE-SYS-LOGIN (&AUX (HOST (FUNCALL (FS:GET-PATHNAME-HOST "SYS") :HOST))
  (UNAME (GET-SITE-OPTION :SYS-LOGIN-NAME)) PWD)
  "Make sure it is possible to read system files, by logging in if necessary.
The site configuration file specifies the user-name and password to use,
as well as what the system file host is."
  (UNLESS (ASSOC `(,UNAME ,(FUNCALL HOST :NAME)) FS:USER-HOST-PASSWORD-ALIST :TEST #'EQUAL)
    (SETQ PWD `((,UNAME ,(FUNCALL HOST :NAME)) ,(GET-SITE-OPTION :SYS-LOGIN-PASSWORD)))
    (PUSH PWD FS:USER-HOST-PASSWORD-ALIST))
  (COND
    ((MEMBER USER-ID '(NIL "") :TEST #'EQUAL) (LOGIN UNAME HOST T)
     `(PROGN
	(LOGOUT)
	(SETQ FS:USER-HOST-PASSWORD-ALIST (DELQ ',PWD FS:USER-HOST-PASSWORD-ALIST))))
    ((NULL (ASSOC HOST FS:USER-UNAMES :TEST #'EQ))
     (PUSH (CONS HOST (GET-SITE-OPTION :SYS-LOGIN-NAME)) FS:USER-UNAMES)
     `(PROGN
	(FLUSH-UNAME ',HOST)
	(SETQ FS:USER-HOST-PASSWORD-ALIST (DELQ ',PWD FS:USER-HOST-PASSWORD-ALIST))))
    (T `(SETQ FS:USER-HOST-PASSWORD-ALIST (DELQ ',PWD FS:USER-HOST-PASSWORD-ALIST))))) 

(DEFUN FLUSH-UNAME (HOST)
  (SETQ FS:USER-UNAMES
	(DELETE (ASSOC HOST FS:USER-UNAMES :TEST #'EQ) (THE LIST FS:USER-UNAMES) :TEST #'EQ)))