DataMuseum.dk

top - download

    Length: 9459 (0x24f3)
    Types: TextFile
    Names: »login.scm.42«

└─⟦a0efdde77⟧ Bits:30001252 EUUGD11 Tape, 1987 Spring Conference Helsinki
    └─ ⟦this⟧ »EUUGD11/gnu-31mar87/scheme/scm/login.scm.42« 

TextFile

;;; -*-Scheme-*-
;;;
;;;	Copyright (c) 1984 Massachusetts Institute of Technology
;;;
;;;	This material was developed by the Scheme project at the
;;;	Massachusetts Institute of Technology, Department of
;;;	Electrical Engineering and Computer Science.  Permission to
;;;	copy this software, to redistribute it, and to use it for any
;;;	purpose is granted, subject to the following restrictions and
;;;	understandings.
;;;
;;;	1. Any copy made of this software must include this copyright
;;;	notice in full.
;;;
;;;	2. Users of this software agree to make their best efforts (a)
;;;	to return to the MIT Scheme project any improvements or
;;;	extensions that they make, so that these may be included in
;;;	future releases; and (b) to inform MIT of noteworthy uses of
;;;	this software.
;;;
;;;	3.  All materials developed as a consequence of the use of
;;;	this software shall duly acknowledge such use, in accordance
;;;	with the usual standards of acknowledging credit in academic
;;;	research.
;;;
;;;	4. MIT has made no warrantee or representation that the
;;;	operation of this software will be error-free, and MIT is
;;;	under no obligation to provide any services, by way of
;;;	maintenance, update, or otherwise.
;;;
;;;	5.  In conjunction with products arising from the use of this
;;;	material, there shall be no use of the name of the
;;;	Massachusetts Institute of Technology nor of any adaptation
;;;	thereof in any advertising, promotional, or sales literature
;;;	without prior written consent from MIT in each case.
;;;

;;;; Login/logout utilities

(declare (usual-integrations))
\f


(define scheme-login-package
  (make-package scheme-login-package 
		((login-loop #!FALSE)
		 (Message-Of-The-Day-File-Name)
		 (Name-List-File-Name)
		 (Picture-Directory)
		 (Prefix-File-Name)
		 (Band-File-Name)
		 (user-name))

(define (login-read)
  (with-parser-table login-parser-table read))

(define login-parser-table
  (copy-parser-table (current-parser-table)))

(let ((alphabetic-entry (parser-table-entry login-parser-table #/A)))
  (set-parser-table-entry! login-parser-table #/` alphabetic-entry)
  (set-parser-table-entry! login-parser-table #/, alphabetic-entry)
  (set-parser-table-entry! login-parser-table #/| alphabetic-entry)
  (set-parser-table-entry! login-parser-table #/; alphabetic-entry)
  (set-parser-table-entry! login-parser-table #/. alphabetic-entry)
  (set-parser-table-entry! login-parser-table #/# alphabetic-entry))

(define (bb)
  (if (file-exists? Message-Of-The-Day-File-Name)
      (with-open-input-stream Message-Of-The-Day-File-Name
	(lambda (file)
	  (let loop ((string (read file file)))
	    (if (eq? file string)
		(newline)
		(sequence (princ string)
			  (newline)
			  (loop (read file file)))))))))

(define (greet)
  (tyo 12)
  (bb)
  (princ
"Please load your disk into a drive and close the drive door.")
  (newline)
  (princ
"Type your disk's name ending in ':', and then press the EXECUTE key.")
  (newline)
  (princ 
"If you don't want to use a disk, type NAMELESS and then the EXECUTE key.")
  (newline)
  (princ "Disk Name --> "))

(define (find-picture)
  (if (file-exists? (string-append picture-directory "NORMAL"))
      (let ((names (enumerate-file-names 
		    (string-append picture-directory "="))))
	(let loop ((choices '())
		   (stream   names))
	  (if (empty-stream? stream)
	      (let ((n (length choices)))
		(cond ((zero? n) #!false)
		      ((= 1 n) (string-append picture-directory
					      (car choices)))
		      (else (string-append picture-directory
					   (list-ref choices (random n))))))
	      (loop (cons (head stream) choices)
		    (tail stream)))))
      '()))

;;; Start-login-loop should be

;(define (start-login-loop)
;  (without-interrupts
;   (named-lambda (loop)
;     (greet)
;     (let ((val (login-read)))
;       (if (conjunction (pair? val) (eq? (car val) 'login))
;	   (login (cdr val))
;	   (loop))))))
;

;;; But because of interrupt I/O lossage (to be fixed) it becomes

(define (login-loop-external-interrupt-handler char ie)
  (set-interrupt-enables! ie)
  (login-loop 'TIO-VIVO))

(define (start-login-loop)
  (real-login-loop (set-interrupt-enables! INTERRUPT-MASK-GC-OK)))

(define (real-login-loop ie)
  (define (start-loop)
    (enable-language-features)
    (if (file-exists? name-list-file-name)
	(load name-list-file-name system-global-environment))
    (disable-language-features)
    (if (eq? 'FINISH-LOGIN
	     (catch
	       (lambda (repeat)
		 (fluid-let ((login-loop repeat))
		   (set-interrupt-enables! INTERRUPT-MASK-ALL)
		   (let loop ()
		     ((access set-alpha-raster-state! graphics-package
			      ())
		      #!false)
		     (greet)
		     (let ((picture-file-name (find-picture)))
		       (if picture-file-name
			   (sequence
			    ((access load-picture graphics-package ())
			     picture-file-name)
			    (tyi) (tyo 8) (tyo #\SP) (tyo 8) 
						       ; BSpace SPace BSpace
			    (clear-graphics))))
		     ((access set-alpha-raster-state!
			      graphics-package ()) #!true)
		     (let ((a (login-read)))
		       (newline)
		       (if (symbol? a)
			   (login (symbol-print-name a))
			   (loop))))))))
	'done
	(start-loop)))
  (with-external-interrupts-handler login-loop-external-interrupt-handler
				    start-loop)
  (init-graphics)
  (set-interrupt-enables! ie)
  (goto-nmode))                                        ;go to the editor.

(define (login id)
  (if (string-equal? id "NAMELESS")
      (sequence (set! user-name id)
		(if (file-exists? prefix-file-name)
		    (set-prefix!  prefix-file-name)))
      (crunch
       (verify-disk
	(if (string? id)
	    (canonicalize-filename id)
	    (login-loop 'BAD-ARGUMENTS)))))
  (login-loop 'FINISH-LOGIN))

(define (logout)
  (disk-restore band-file-name)
;  (let ((ie (set-interrupt-enables! 1)))
;    (setup-user-global-environment)
;    (goto-environment user-initial-environment)
;    (disable-language-features)
;    (real-login-loop ie))
  )

(define (goto-nmode)
  (if (file-exists? editor-zap-filename)   ;Delete the file that initiated
      (delete-file editor-zap-filename))   ;the login-loop.
  (edit))

(define NO-DISK-ERROR 34)
(define LEFT-DRIVE 4)
(define RIGHT-DRIVE 3)
(define EXECUTE-KEY 254)

(define (verify-disk id)
  (let ((left-name (get-unit-name LEFT-DRIVE)))
    (if (conjunction (string? left-name)
		     (string-equal? left-name id))
	(create-job id)
	(let ((right-name (get-unit-name RIGHT-DRIVE)))
	  (cond ((conjunction (string? right-name)
			      (string-equal? right-name id))
		 (create-job id))
		((disjunction (string? right-name)
			      (string? left-name))
		 (different-id-warn left-name right-name id))
		((conjunction (eq? left-name NO-DISK-ERROR)
			      (eq? right-name NO-DISK-ERROR))
		 (no-disk-warning id))
		((not (eq? left-name NO-DISK-ERROR))
		 (prepare-to-initialize id LEFT-DRIVE))
		(else (prepare-to-initialize id RIGHT-DRIVE)))))))
		
(define (no-disk-warning id)
  (newline)
  (princ "There is no initialized disk in either drive, and the system can")
  (newline)
  (princ "not detect which drive your disk is in.  Type LEFT or RIGHT to")
  (newline)
  (princ "choose a drive to initialize, or anything else to abort.  Be")
  (newline)
  (princ "sure to end your entry by pressing the EXECUTE key.")
  (newline)
  (princ "-> ")
  (let ((answer (read)))
    (cond ((eq? answer 'left) (initialize! id LEFT-DRIVE))
	  ((eq? answer 'right) (initialize! id RIGHT-DRIVE))
	  (else (login-loop 'NO-DISK)))))

(define (different-id-warn left-name right-name id)
  (let ((default-name left-name))
    (newline)
    (princ "The disk you want, ")
    (princ id)
    (princ ", isn't in either drive.")
    (newline)
    (if (string? left-name)
	(sequence
	 (princ "The disk in the left drive is named ")
	 (princ left-name)
	 (princ ".")
	 (newline))
	(set! default-name right-name))
    (if (string? right-name)
	(sequence
	 (princ "The disk in the right drive is named ")
	 (princ right-name)
	 (princ ".")
	 (newline)))
    (princ "Hit EXECUTE to login using the name ")
    (princ default-name)
    (princ ", or any other key to abort login.")
    (newline)
    (if (= (tyi) EXECUTE-KEY) 
	(create-job default-name)
	(login-loop 'ID-WARN))))
		
(define (create-job name)
  (set! user-name name)
  (set-prefix! name)
  (wait-for 3)
  name)

(define (prepare-to-initialize id Which-Drive)
  (newline)
  (princ "Neither drive has an initialized disk.")
  (newline)
  (princ "To initialize the ")
  (princ (if (= Which-Drive LEFT-DRIVE)
	     "left"
	     "right"))
  (princ " drive using the name you gave, press EXECUTE.")
  (newline)
  (princ "Any other key will abort the initialization.")
  (newline)
  (let ((g (tyi)))
    (if (= g EXECUTE-KEY)
	(initialize! id Which-Drive)
	(sequence (newline)
		  (princ "Disk initialization aborted.")
		  (wait-for 3)
		  (login-loop 'INITIALIZATION-ABORTED)))))
		
(define (initialize! name Which-Drive)
  (let ((return-code (initialize-floppy 
		      (if (= Which-Drive LEFT-DRIVE)
			  'left 'right) name)))
    (cond ((eq? return-code 'bad-name)
	   (wait-for 3)
	   (login-loop 'BAD-INITIALIZATION-NAME))
	  ((eq? return-code 'aborted)
	   (login-loop 'ABORTED))
	  ((eq? return-code 'failed)
	   (login-loop 'INITIALIZATION-FAILED))
	  (else
	   (newline)
	   (princ "Your disk has been initialized.")
	   (newline)
	   (create-job name)))))

;;; end SCHEME-LOGIN-PACKAGE.
))

;;Exports.

(define logout 
  (access logout scheme-login-package))