(FILECREATED "10-Feb-86 19:31:57" {DSK}<LISPFILES2>IMPROVEDDCOMS>KEYMAKER.;2
 6355   

      previous date: " 1-Feb-86 13:32:34" {GOEDEL}</usr2/xerox/q/>KEYMAKER)


(* Copyright (c) 1985, 1986 by Quintus Computer Systems. All rights reserved.)

(PRETTYCOMPRINT KEYMAKERCOMS)

(RPAQQ KEYMAKERCOMS
 ((SCCS)
		       (* Stuff necessary to make entries in the codes file.)
		       (FILES SECURE)
		       (INITVARS QUINTUS.INTERFACE.DIRECTORY)
		       (GLOBALVARS QUINTUS.INTERFACE.DIRECTORY)
		       (FNS KEYMAKER QP.SECURITY.KEY)))
(* %%G%  %%W% )



(* Stuff necessary to make entries in the codes file.)


(FILESLOAD SECURE)

(RPAQ? QUINTUS.INTERFACE.DIRECTORY
 NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS QUINTUS.INTERFACE.DIRECTORY)
)
(DEFINEQ

(KEYMAKER

  (LAMBDA NIL                                                (* pds: " 1-Dec-85 15:54")


          (* * Interactive shell for determining what Xerox Quintus Prolog users should put into their codes file to enable a

	  particular D-machine to run Prolog. Also writes out an audit trail listing what machines were granted licenses 

	  when.)



    (if
 (
NULL
 QUINTUS.INTERFACE.DIRECTORY)
	then
 (PRINTOUT T T 
"You must set the variable QUINTUS.INTERFACE.DIRECTORY to point to the directory holding the CODESGRANTED file before running KEYMAKER."
			 T T)
      else
 (PRINTOUT T "Welcome to KEYMAKER." T 
	      "Enter information about sites being granted licenses to run Xerox Quintus Prolog."
		       T "Terminate by entering a empty line for SITE." T T)
	     (bind
 (FL ← (
OPENFILE
 (
PACKFILENAME
 (
QUOTE
 BODY)
						       QUINTUS.INTERFACE.DIRECTORY
						       (
QUOTE
 NAME)
						       (
QUOTE
 KEYSGRANTED))
				       (
QUOTE
 APPEND)))
		     SITE SER1 SER2 SER3 EXPDATE ENTEREDDATE COMMENTS KEY
		eachtime
 (
SETQ
 SITE (
TTYIN
 "Name of site: " NIL 
      "The name of the site being licensed to run Xerox Quintus Prolog.  Enter one line of text."
						 (
QUOTE
 (STRING NORAISE))
						 NIL NIL SITE))
		until
 (
NULL
 SITE) as
 NUM from
 0
		do
 (eachtime
 (
SETQ
 SER1 (
CAR
 (
TTYIN
 "First word of NS host number: " NIL 
"The first number following NSHOSTNUMBER in the value of \MY.NSHOSTNUMBER on the machine being licensed."
							      NIL NIL NIL (
AND
 SER1 (
MKSTRING

										   SER1)))))
			until
 (
AND
 (
FIXP
 SER1)
				       (
ILEQ
 0 SER1)
				       (
ILEQ
 SER1 65535))
			do
 (PRINTOUT T "must be a number between 0 and 65535." T))
		     (eachtime
 (
SETQ
 SER2 (
CAR
 (
TTYIN
 "Second word of NS host number: " NIL 
"The second number following NSHOSTNUMBER in the value of \MY.NSHOSTNUMBER on the machine being licensed."
							      NIL NIL NIL (
AND
 SER2 (
MKSTRING

										   SER2)))))
			until
 (
AND
 (
FIXP
 SER2)
				       (
ILEQ
 0 SER2)
				       (
ILEQ
 SER2 65535))
			do
 (PRINTOUT T "must be a number between 0 and 65535." T))
		     (eachtime
 (
SETQ
 SER3 (
CAR
 (
TTYIN
 "Third word of NS host number: " NIL 
"The third (and last) number following NSHOSTNUMBER in the value of \MY.NSHOSTNUMBER on the machine being licensed."
							      NIL NIL NIL (
AND
 SER3 (
MKSTRING

										   SER3)))))
			until
 (
AND
 (
FIXP
 SER3)
				       (
ILEQ
 0 SER3)
				       (
ILEQ
 SER3 65535))
			do
 (PRINTOUT T "must be a number between 0 and 65535." T))
		     (eachtime
 (
SETQ
 EXPDATE (if
 (
STREQUAL

							 "NEVER"
							 (
U-CASE
 (
SETQ
 ENTEREDDATE
								     (
TTYIN
 
								   "Expiration date (or NEVER): "
									      NIL 
"The date of the last day the licensed site is to be able to run Xerox Quintus Prolog before having to renew their license.  Must be a date of the form dd-mmm-yy, or the word %"NEVER%" for holders of a perpetual license."
									      (
QUOTE
 (STRING 
											  NORAISE))
									      NIL NIL ENTEREDDATE))))
						     then
 (
QUOTE
 NEVER)
						   else
 (
CONCAT
 ENTEREDDATE " 00:00:00")))
			until
 (
OR
 (
EQ
 EXPDATE (
QUOTE
 NEVER))
				      (
IDATE
 EXPDATE))
			do
 (PRINTOUT T "Enter date as dd-mmm-yy or NEVER" T))
		     (
SETQ
 COMMENTS (
TTYIN
 "Comments: " NIL 
"Any comments about this node, site license or anything you might feel like saying.  You need not put anything here."
					       (
QUOTE
 (STRING NORAISE))
					       NIL NIL COMMENTS))
		     (
SETQ
 KEY (QP.SECURITY.KEY
 (
LOGOR
 (
LLSH
 SER2 16)
							     SER3)
						    EXPDATE NIL))
		     (PRINTOUT T T)
		     (if
 (
ASKUSER
 NIL NIL "Is this entry as you wish? "
				      (
QUOTE
 ((y "es" RETURN T)
						 (n "o" RETURN NIL)))
				      NIL NIL (
QUOTE
 (CONFIRMFLG T)))
			 then
 (PRINTOUT FL "(" .P2 (
DATE
)
					  , .I6 SER1 .I6 SER2 .I6 SER3 .FR2 -21 EXPDATE , .I8.16.T
					  (
CAR
 KEY)
					  , .I8.16.T (
CADR
 KEY)
					  , .I8.16.T (
CADDR
 KEY)
					  , .P2 SITE , .P2 COMMENTS ")" T)
				(PRINTOUT T T "Code:" T .I8.16.T (
CAR
 KEY)
					  , .I8.16.T (
CADR
 KEY)
					  , .I8.16.T (
CADDR
 KEY)
					  T T T)
		       else
 (PRINTOUT T T T "Code not granted" T T T) 

          (* * Hack to keep count of granted codes correct.)



			      (add
 NUM -1))
		finally
 (
CLOSEF
 FL)
			  (
RETURN
 NUM)))))

(QP.SECURITY.KEY

  (LAMBDA (SERIALNUMBER EXPDATE OPTIONS)                     (* pds: " 1-Feb-86 00:10")


          (* * Return the security key for machine with SERIALNUMBER, which is the low order 32 bits of the NS host number 

	  from the \InterfacePage, expiring on EXPDATE. EXPDATE must be either a valid date-time string acceptable to IDATE, 

	  or the atom NEVER. OPTIONS is ignored, for now.)



    (
SETQ
 OPTIONS 0)
    (LET* ((1ST (QP.HASH.UNHASH SERIALNUMBER SERIALNUMBER))
	   (2ND (QP.HASH.UNHASH (
LOGOR
 (
LLSH
 (QP.DATE.INTEGER16 (if
 (
EQ
 EXPDATE (
QUOTE

										  NEVER))
									then
 " 1-DEC-85 00:00:00"
								      else
 EXPDATE))
						 16)
					 OPTIONS)
				SERIALNUMBER))
	   (3RD (QP.MAKE.VERIFICATION 1ST 2ND)))
          (
LIST
 (
FIXP-TO-BIGNUM
 1ST)
		  (
FIXP-TO-BIGNUM
 2ND)
		  (
FIXP-TO-BIGNUM
 3RD)))))
)
(PUTPROPS KEYMAKER COPYRIGHT ("Quintus Computer Systems" 1985 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (762 6264 (KEYMAKER 772 . 5367) (QP.SECURITY.KEY 5369 . 6262)))))
STOP