Google
 

Trailing-Edge - PDP-10 Archives - tops20v41_execsrcmod - exec/exec4.mac
There are 47 other files named exec4.mac in the archive. Click here to see a list.
; UPD ID= 94, FARK:<5-WORKING-SOURCES.EXEC>EXEC4.MAC.2,   9-Sep-82 10:08:20 by TSANG
;EDIT - 904 ALLOW 40 ENTRIES IN EACH USER GROUPS.
; UPD ID= 120, SNARK:<5.EXEC>EXECIN.MAC.21,  28-Dec-81 11:14:01 by CHALL
;TCO 5.1644 - UPDATE COPYRIGHT NOTICE
; UPD ID= 35, SNARK:<5.EXEC>EXEC4.MAC.3,  14-Aug-81 19:12:47 by CHALL
;TCO 5.1454 CHANGE NAME FROM XDEF TO EXECDE
;<HELLIWELL.EXEC.5>EXEC4.MAC.1, 14-May-81 13:08:54, EDIT BY HELLIWELL
; UPD ID= 591, SNARK:<5.EXEC>EXEC4.MAC.5,   3-Jun-80 09:33:13 by OSMAN
;<5.EXEC>EXEC4.MAC.4,  2-Jun-80 16:41:52, EDIT BY OSMAN
;tco 5.1057 - Allow ENABLE, DISABLE, and PUSH under BUILD
;<5.EXEC>EXEC4.MAC.3,  8-May-80 14:03:45, EDIT BY OSMAN
;Remove R.L.5 and R.GE.5 macro calls and contents
; UPD ID= 424, SNARK:<4.1.EXEC>EXEC4.MAC.6,   9-Apr-80 14:02:16 by OSMAN
;tco 4.1.1141 - Fix ACCOUNT handling
; UPD ID= 413, SNARK:<4.1.EXEC>EXEC4.MAC.5,   4-Apr-80 17:42:29 by LYONS
;ADD CODE FOR ARPANET ACCESS AND DECNET ACCESS
; UPD ID= 200, SNARK:<4.1.EXEC>EXEC4.MAC.4,  10-Jan-80 14:44:43 by OSMAN
;tco 4.1.1064 - Ask for password after BUILD subcommands if needed.
; UPD ID= 194, SNARK:<4.1.EXEC>EXEC4.MAC.3,   8-Jan-80 14:28:44 by OSMAN
; UPD ID= 191, SNARK:<4.1.EXEC>EXEC4.MAC.2,   8-Jan-80 14:06:56 by OSMAN
;tco 4.1.1060 - Warn about non-accessed directories under INFO DIR
;<4.EXEC>EXEC4.MAC.49, 14-Sep-79 16:06:41, Edit by LCAMPBELL
; Account for DTIVX skip returning
;<4.EXEC>EXEC4.MAC.48, 12-Sep-79 10:36:05, EDIT BY OSMAN
;Use LERROR at NODIR instead of ERSTR
;<4.EXEC>EXEC4.MAC.44, 13-Jul-79 15:46:33, EDIT BY OSMAN
;TCO 4.2327 - PREVENT ?EXEC FREE SPACE EXHAUSTED - INFO DIR PS:[*]
;<4.EXEC>EXEC4.MAC.43, 21-Jun-79 13:36:15, EDIT BY OSMAN
;REMOVE EXTRANEOUS REF TO RLJFNS
;<4.EXEC>EXEC4.MAC.42,  7-Jun-79 14:15:20, EDIT BY EKLUND
;tco 4.2277 - add repeat-login-messages subcommand to build (again!)
;<4.EXEC>EXEC4.MAC.41,  6-Jun-79 10:40:14, EDIT BY HELLIWELL
;CHANGE WHLUO & OPRUO TO WHLU & OPRU IN "PRESERVE" SUBCOMMAND (NOSHIP)
;<4.EXEC>EXEC4.MAC.39,  1-May-79 11:20:10, EDIT BY OSMAN
;CHANGE GTJFN TO CALL GTJFS SO THAT ^C CAN'T LEAVE JFN AROUND
;<4.EXEC>EXEC4.MAC.38, 12-Mar-79 17:51:10, EDIT BY KONEN
;UPDATE COPYRIGHT FOR RELEASE 4
;<4.EXEC>EXEC4.MAC.37, 28-Feb-79 11:05:02, EDIT BY OSMAN
;REMOVE REFS TO CTYPE (USE ETYPE INSTEAD)
;<4.EXEC>EXEC4.MAC.36,  7-Feb-79 13:51:39, EDIT BY OSMAN
;FIX PRINTOUT (GET RID OF _)
;<4.EXEC>EXEC4.MAC.34, 23-Jan-79 10:36:21, EDIT BY OSMAN
;CLEAR F1 ("NOT") BEFORE EACH "BUILD" SUBCOMMAND
;<4.EXEC>EXEC4.MAC.30, 18-Jan-79 18:08:55, EDIT BY OSMAN
;CHANGE THOSE SEMIS TO XARC
;<4.EXEC>EXEC4.MAC.27, 22-Dec-78 09:38:02, EDIT BY OSMAN
;put semicolons in front of all offline-exp/online-exp/archive-online stuff
;because we're not doing that stuff for r4
;<4.EXEC>EXEC4.MAC.26,  9-Nov-78 14:44:12, EDIT BY OSMAN
;TCO 4.2086 - FIX GRPCHK
;GET RID OF REFS TO UGBUF ETC.  (MAKE THEM LOCAL REFS)
;<4.EXEC>EXEC4.MAC.17, 27-Sep-78 14:00:47, EDIT BY OSMAN
;CHANGE "B5" REFS TO 1B5 (VIA SYMBOL "NOTF")
;<4.EXEC>EXEC4.MAC.13, 15-Sep-78 23:21:51, EDIT BY OSMAN
;REMOVE ALL REFS TO CSBUFP
;<4.EXEC>EXEC4.MAC.12, 14-Sep-78 14:10:08, EDIT BY OSMAN
;ONLY SEARCH XDEF, TTITLE DOES REST
;<4.EXEC>EXEC4.MAC.11, 13-Aug-78 14:00:27, Edit by HELLIWELL
;MAKE PRESERVE SUBCOMMAND CALL PRVCK
;<4.EXEC>EXEC4.MAC.10, 29-Jul-78 14:49:17, Edit by HELLIWELL
;ALWAYS CONVERT DIRECTORY NAME TO CONONICAL FORM AT CRET1
;<4.EXEC>EXEC4.MAC.7, 17-Jul-78 10:55:52, EDIT BY OSMAN
;GET RID OF GTBUF (USE LOCAL BLOCK IN PLACES WHERE ITS REFERENCED)
;<4.EXEC;MAKE DFBUF BE LOCAL
;<4.EXEC>EXEC4.MAC.4, 11-Jul-78 16:39:41, EDIT BY OSMAN
;MAKE ^EPRINT AND ^ECREATE USE LOCAL STORAGE
;<4.EXEC>EXEC4.MAC.3,  9-Jun-78 18:05:29, EDIT BY OSMAN
;CHANGE CALLS TO FIELD TO FLDSKP
;<4.EXEC>EXEC4.MAC.2,  6-Jan-78 12:18:11, EDIT BY HELLIWELL
;<4.EXEC>EXEC4.MAC.1,  6-Jan-78 12:08:14, EDIT BY HELLIWELL
;ADD "PRESERVE (SUPERIOR QUOTAS)" SUBCOMMAND TO CREATE/BUILD
;TOPS20 'EXECUTIVE' COMMAND LANGUAGE

;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;
;COPYRIGHT (C) 1980,1981,1982 BY DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.

	SEARCH EXECDE
	TTITLE EXEC4

;THIS FILE CONTAINS THE PRIVILEGED COMMANDS '^EPRINT' AND '^ECREATE'

;^E PRINT (NAME) <DIRECTORY NAME> [VERBOSE]
;"VERBOSE" MAY ONLY BE ENTERED AS A SUBCOMMAND.  4/21/77 EO

;PRINTS ALL OF THE CHARACTERISTICS ASSOCIATED WITH A DIRECTORY:
; PASSWORD, PRIVILEGES, MODE, SPECIAL RESOURCE INFO, DIRECTORY NUMBER,
;     DEFAULT FILE PROT, DIREC PROT, FILE RETENTION SPECS,
;     DIRECTORY & USER GROUPS.
;ADD'L KEYWORD "VERBOSE" OR SUBCOMMAND "VERBOSE" CAUSES ALL TO
;BE PRINTED, OTHERWISE ONLY NON-DEFAULT FIELDS.

EPRINT::TRVAR <<EPBLK,GTDLN>,EPFLG,EPDIR,EPWLS>
	SETZM EPBLK		;NO BLOCK TO RELEASE YET
	NOISE <DIRECTORY NAME>
	TLZ Z,F1		;ALLOW CURRENT DIR AS DEFAULT
	CALL CURNMS		;INPUT DIRECTORY NAME, GET # AND BITS IN A
	 ERROR <No such directory>
	MOVEM A,EPFLG		;SAVE THE FLAGS FROM RCDIR
	MOVEM B,EPWLS		;SAVE THE POINTER TO THE STRING
	MOVEM C,EPDIR		;SAVE THE DIR #
	TLZ Z,F3!F4		;INITIALIZE FLAGS
	CALL SPRTR		;ANALYZE & CHECK TERMINATOR
	 SUBCOM $PRINT		;READ SUBCOMMANDS
EPR1:	MOVEI A,EPBLK
	SKIPE EPBLK		;IS THERE A PREVIOUS BLOCK?
	CALL RELDIR		;YES, RELEASE FREE SPACE USED
	MOVE A,EPDIR		;GET THE DIR NUMBER
	TLNE Z,F4		;NAME-ONLY?
	JRST EPR3		;YES, DONT DO THE GETDIR
	MOVEI C,EPBLK		;BLOCK INTO WHICH TO READ THE INFO
	CALL GETDIR		;DO THE GTDIR JSYS
	 JRST [	MOVE A,EPDIR	;GET DIRECTORY NUMBER THAT FAILED
		ETYPE <%%%%? - %1R%%_>	;SAY WHY THE FAILURE
		JRST EPR2]	;DO REST IN SET
	MOVEI A,EPBLK		;GET ADDRESS OF BLOCK
	CALL GRPCHK		;CHECK FOR GROUP OVERFLOWS
EPR3:	MOVE A,EPDIR		;GET THE DIR NUMBER FOR DIRPNT
	MOVEI B,EPBLK		;GET BLOCK ADDRESS
	CALL DIRPNT
EPR2:	MOVE A,EPDIR		;NOW STEP TO THE NEXT DIR (IF ANY)
	MOVE B,EPWLS		;GET POINTER TO ORIGINAL STRING
	MOVE C,EPFLG		;GET FLAGS
	TXNE C,RC%WLD		;ANY WILD CARD CHARACTERS IN STRING?
	CALL STPDIR		;YES, GO STEP THE DIR NUMBER
	 JRST UNMDIR		;NO MORE DIRS, UNMAP DIR PAGES
	MOVEM A,EPDIR		;SAVE THE NEW DIR NUMBER
	JRST EPR1		;LOOP BACK FOR THE OTHER DIRS
;DIRPNT
;PRINT DIRECTORY DESCRIPTION FROM GTDIR-FORMAT BLOCK THAT Q1 POINTS TO.
;OMITS DEFAULT VALUES UNLESS BIT F3 IN LH Z IS ON.
;PRINTS THE DIR NAME ONLY IF F4 IN LH Z IS ON.
;FOR "PRINT" COMMAND AND FOR "LIST" SUBCOMMAND OF "CREATE".
;ACCEPTS IN A/	DIR NUMBER OR POINTER TO DIR NAME STRING
;ACCEPTS IN B/ ADDRESS OF CRDIR-FORMAT BLOCK CONTAINING INFO

DIRPNT:	SAVEAC <P1>		;GET A PERMANENT AC TO USE FOR ADDRESS
	STKVAR <DACTPR,<DFBUF,GTDLN>>
	MOVE C,.CDDAC(B)	;GET ACCOUNT POINTER
	MOVEM C,DACTPR		;REMEMBER POINTER TO ACCOUNT
	MOVE P1,B		;SAVE ADDRESS OF BLOCK
	SKIPE A			;NAME IS NOT IN BLOCK FOR "PRINT".
	ETYPE < Name %1R%%_>
	TLNE Z,F4		;PRINT NAME ONLY?
	RET			;YES, EXIT
	TYPE < Password >
	SKIPN A,.CDPSW(P1)
	JRST [	TYPE <- not available>
		JRST PR2]
	MOVE B,A		;SEE IF THERE IS A PASSWORD
	ILDB B,B		;GET FIRST CHARACTER OF STRING
	JUMPE B,[TYPE <- none set>
		JRST PR2]
	ETYPE <%1M>
PR2:	ETYPE<%_>
	SETZB A,C		;GET DEFAULT INFO
	MOVEI B,GTDLN		;SET UP LENGTH OF BUFFER
	MOVEM B,.CDLEN+DFBUF	;IN FIRST WORD OF BUFFER
	MOVEI B,DFBUF
	GTDIR
	 ERCAL JERRE
	MOVSI B,(<7B2>)		;CLEAR EXTRA BITS
	ANDCAM B,.CDFPT+DFBUF
	ANDCAM B,.CDDPT+DFBUF
	MOVE B,.CDLIQ(P1)	;LOGGED IN QUOTA
	ETYPE < Working disk storage page limit %2Q%%_>
	MOVE B,.CDLOQ(P1)	;LOGGED OUT QUOTA
	ETYPE < Permanent disk storage page limit %2Q%%_>

;PRIVILEGES

	MOVE B,.CDPRV(P1)
	TXNN B,SC%WHL
	CALL F3NOT
	TXZE B,SC%WHL
	ETYPE < WHEEL%_>
	TXNN B,SC%OPR
	CALL F3NOT
	TXZE B,SC%OPR
	ETYPE < OPERATOR%_>
	TXNN B,SC%CNF
	CALL F3NOT
	TXZE B,SC%CNF
	ETYPE < CONFIDENTIAL INFORMATION ACCESS%_>
	TXNN B,SC%MNT
	CALL F3NOT
	TXZE B,SC%MNT
	ETYPE < MAINTENANCE%_>
	TXNN B,SC%IPC
	CALL F3NOT
	TXZE B,SC%IPC
	ETYPE < IPCF%_>
	TXNN B,SC%ENQ
	CALL F3NOT
	TXZE B,SC%ENQ
	ETYPE < ENQ-DEQ%_>
	TXZE B,SC%NWZ		;ARPANET WIZARD?
	ETYPE < ARPANET-WIZARD%_>
	TXZE B,SC%NAS		;ABSOLUTE ARPANET SOCKETS?
	ETYPE < ABSOLUTE-ARPANET-SOCKETS%_>
	TXZE B,SC%DNA
	ETYPE < DECNET-ACCESS%_>
	TXZE B,SC%ANA
	ETYPE < ARPANET-ACCESS%_>
	JUMPE B,.+2		;NO MORE PRIVILEGES
	ETYPE < Other capabilities %2O%%_>
;DIRPNT
;MODE

	MOVE B,.CDMOD(P1)
	TXNN B,CD%DIR
	CALL F3NOT
	TXZE B,CD%DIR
	ETYPE < FILES-ONLY%_>
	TXZ B,CD%ANA		;IGNORE ALPHA NUMERIC BIT
	TXZE B,CD%RLM
	ETYPE < Repeat LOGIN messages%_>
XARC <
	TXZE B,CD%DAR		; Default archive online-expired?
	ETYPE < Archive online expired files%_>
   >
	JUMPE B,.+2		;TEST FOR ADDITIONAL MODE BITS
	ETYPE < Other mode bits %2O%%_>

	SKIPN B,.CDNUM(P1)
	JRST [	TLNE Z,F3
		ETYPE < No directory number%_>
				;0: NOT ASSIGNED YET ("CREATE" CASE)
		JRST .+2]
	ETYPE < Number of directory %2O%%_>
	MOVE B,.CDFPT(P1)
	TLZ B,(<7B2>)
	TLNN Z,F3
	CAME B,.CDFPT+DFBUF	;DON'T PRINT IF STANDARD
	ETYPE < Default file protection %2O%%_>
	MOVE B,DACTPR		;GET POINTER TO ACCOUNT STRING
	ILDB B,B		;GET FIRST CHARACTER
	SKIPN B			;IS THERE AN ACCOUNT DEFAULT?
	SKIPA B,[-1,,[ASCIZ /- none set/]]
	MOVE B,DACTPR		;YES, GET POINTER TO ACCOUNT STRING
	ETYPE < Account default for LOGIN %2m%%_>
	MOVE B,.CDDPT(P1)
	TLZ B,(<7B2>)
	TLNN Z,F3
	CAME B,.CDDPT+DFBUF
	ETYPE < Protection of directory %2O%%_>
;DIRPNT

	MOVE B,.CDRET(P1)		;DEFAULT # VERSIONS TO KEEP
	MOVE A,.CDRET+DFBUF		;DEFAULT VALUE
	TLNN Z,F3
	CAME B,A
	ETYPE < Generations to keep %2Q%%_>
	MOVE B,.CDSDQ(P1)		;NUMBER OF SUBDIRECTORIES
	MOVE A,.CDSDQ+DFBUF		;DEFAULT VALUE
	TLNN Z,F3
	CAME B,A
	ETYPE < Maximum subdirectories allowed %2Q%%_>
	SKIPN A,.CDLLD(P1)
	JRST [	TLNE Z,F3
		ETYPE < Never logged in%_>
				;CAN'T USE REG CASE CAUSE %D TYPES CURRENT
				;DATE FOR 0
		JRST .+2]
	ETYPE < Last LOGIN %1D %1E%%_>
	MOVE A,.CDUGP(P1)
	MOVEI B,[ASCIZ /User groups/]
	CALL GRPPNT
	MOVE A,.CDDGP(P1)
	MOVEI B,[ASCIZ /Directory groups/]
	CALL GRPPNT
	MOVE A,.CDCUG(P1)	;POINTER TO ALLOWABLE SUBDIRECTORY USER GROUPS
	MOVEI B,[ASCIZ /Subdirectory user groups allowed/]
	CALL GRPPNT
	MOVE A,.CDDNE+DFBUF
	MOVE B,.CDDNE(P1)
	MOVEI C,[ASCIZ / Online expiration default /]
XARC <
	CALL EXPPNT
   >
	MOVE A,.CDDFE+DFBUF
	MOVE B,.CDDFE(P1)
	MOVEI C,[ASCIZ / Offline expiration default /]
XARC <
	CALL EXPPNT
   >
	ETYPE<%_>
	RET

GRPPNT:	PUSH P,B
	JUMPE A,GRPPN0
	MOVN B,(A)		;GET COUNT
	AOJGE B,GRPPN0		;COUNT = 1 IS NO GROUPS
	HRL A,B
	PRINT " "
	POP P,B
	UTYPE (B)
	PRINT " "
	AOSA A			;NOW WE HAVE AN AOBJN POINTER
GRPPN1:	TYPE <, >
	MOVE B,(A)
	ETYPE <%2Q>
	AOBJN A,GRPPN1
	ETYPE<%_>
	RET

GRPPN0:	POP P,B
	TLNN Z,F3
	RET
	PRINT " "
	UTYPE (B)
	TYPE < - none set
>
	RET

;ROUTINE TO CHECK FOR LOST INFO DUE TO RESTRICTED SUBBLOCK LENGTHS.  PASS
;THIS ROUTINE ADDRESS OF GTDIR/CRDIR BLOCK IN A.

GRPCHK:	MOVE B,@.CDUGP(A)		;GET NUMBER OF WORDS RETURNED
;**;[904]	Modify next line		YKT 	8-SEP-82
	CAIL B,UGBUFL			;[904] CHECK FOR *POSSIBLE* OVERFLOW
	TYPE < User group buffer overflow
>
	MOVE B,@.CDDGP(A)		;SAME FOR OTHER GROUP BUFFERS
;**;[904]	Modify next line		YKT	8-SEP-82
	CAIL B,DGBUFL			;[904]
	TYPE < Directory group buffer overflow
>
	MOVE B,@.CDCUG(A)
;**;[904]	Modify next line		YKT	8-SEP-82
	CAIL B,SGBUFL			;[904]
	TYPE < Subdirectory user group buffer overflow
>
	RET

;SUBROUTINE TO TYPE " NOT" AND SKIP IF F3 ON

F3NOT:	TLNN Z,F3
	RET
	TYPE < not>
	RETSKP

EXPPNT:	TLNN Z,F3		;VERBOSE?
	CAME A,B		;SAME AS DEFAULT?
	CAIA			;EITHER VERBOSE OR NOT DEFAULT VALUE
	RET			;YES, DON'T PRINT IT
	UTYPE (C)		;WHAT IT IS
	TLNN B,-1		;INTERVAL OR DATE & TIME?
	JRST EXPPN1
	ETYPE <%2D
>				;PRINT DATE & TIME
	RET

EXPPN1:	CAIN B,1
	ETYPE <%2Q Day
>
	CAIE B,1
	ETYPE <%2Q Days
>
	RET

;"PRINT" SUBCOMMAND TABLE AND ROUTINES

$PRINT:	TABLE
	T FAST,ONEWRD,..FAST
	T NAME-ONLY,ONEWRD,..NAME
	T VERBOSE,ONEWRD,..VERB
	TEND

..FAST:	TLZA Z,F3
..VERB:	TLO Z,F3
	TLZ Z,F4		;GET WHOLE LISTING
	RET

..NAME:	TLO Z,F4		;NAME ONLY
	RET
;^E CREATE (NAME) <DIRECTORY NAME> (PASSWORD) --
;EITHER FIELD CAN BE TERMINATED WITH COMMA TO INITIATE SUBCOMMANDS.
;CAN CREATE NEW DIRECTORIES OR MODIFY INFO ASSOCIATED WITH OLD ONES.
;Q1 HOLDS FLAGS AND BLOCK POINTER WHICH WILL BE IN B FOR CRDIR.
;FLAGS IN LH Q1 ARE SET ONLY FOR FIELDS EXPLICITLY INPUT BY USER,
;  BUT ALL INFO IS IN BLOCK FOR "LIST" SUBCOMMAND.

.CREAT::NOISE <DIRECTORY NAME>
	TRVAR <CRPASS,<CSTING,FILWDS>,<CRBLK,GTDLN>,KREDIR>
	SETZM CRPASS		;NO PASSWORD YET
	MOVX Q1,CD%LEN		;ALWAYS ENABLE .CDLEN ENTRY
	MOVEI A,CRBLK		;ADDRESS OF BLOCK TO INITIALIZE
	CALL DIRINI		;INIT BUFFER FOR GTDIR
;CREATE
;INPUT NAME AND TYPE [OLD/NEW] AND GET CURRENT INFO FOR OLD.

	MOVEI B,[FLDDB. .CMDIR,CM%SDH,,<Old directory name being modified>,,[
		 FLDDB. .CMDIR,CM%PO+CM%SDH,,<New directory name being created>,,]]
	CALL FLDSKP		;READ DIRECTORY NAME
	 CMERRX
	MOVE A,.CMFNP(C)	;GET FUNCTION FLAGS TO DETERMINE IF DIRECTORY EXISTS OR NOT
	TLZ Z,F2		;ASSUME OLD NAME
	TXNN A,CM%PO		;PARSE-ONLY?
	JRST CRET1		;NO
	TLO Z,F2		;YES, NEW NAME
	CALL BUFFF		;GET STRING
	MOVEM A,KREDIR		;SAVE POINTER TO DIRECTORY NAME STRING
	DEXTX <>		;CLEAR GTJFN BLOCK
	HRROI A,[ASCIZ /FOO/]	;NAME IS ARBITRARY
	MOVEM A,CJFNBK+.GJNAM	;STORE NAME TO USE
	MOVE A,[.NULIO,,.NULIO]	;DON'T LET GTJFN READ ANY MORE INPUT
	MOVEM A,CJFNBK+.GJSRC	;STORE NON-JFN'S
	MOVX A,GJ%OFG		;WE WANT PARSE ONLY
	MOVEM A,CJFNBK+.GJGEN	;STORE FLAGS
	MOVEI A,CJFNBK		;POINT GTJFN AT ARG BLOCK
	MOVE B,KREDIR		;GET POINTER TO STRUCTURE AND DIRECTORY
	CALL GTJFS		;GET DEVICE NAME
	 CALL JERR		;SHOULDN'T EVER FAIL
	MOVE B,A		;PUT IN B FOR GETTING DEVICE NAME
	HRROI A,CSTING		;AREA INTO WHICH TO WRITE DEVICE NAME
	MOVX C,FLD(.JSAOF,JS%DEV) ;WE ONLY WANT DEVICE FIELD
	JFNS			;GET DEVICE NAME
	HRROI A,CSTING		;NOTE THAT WE COULDN'T JUST DO STDEV
				;BECAUSE IN COMMON CASE, USER WILL
				;TYPE "^ECREATE [FOO]", AND HENCE DEVICE
				;NAME WILL BE NULL.  UNFORTUNATELY,
				;STDEV DOESN'T HAVE A SPECIAL ERROR CODE
				;SAYING "DEVICE NAME WAS NOT SPECIFIED",
				;NOR DOES IT RETURN UPDATED STRING POINTER
				;IN AC1.  OTHERWISE THE GTJFN,JFNS WOULD
				;HAVE BEEN UNNECESSARY.  NOTE THAT LEAVING
				;OUT ALL THIS CODE IS BAD TOO, BECAUSE
				;USER MIGHT SAY "^ECREATE ABC:[FOO]"
				;WHERE ABC: IS NOT MOUNTED, AND EXEC WOULD
				;JUST WAIT FOR ALL THE SUBCOMMANDS, AND
				;THEN BOMB OUT, A VERY FRUSTRATING
				;SITUATION.
	MOVE C,A		;LEAVE POINTER IN 3 FOR ERROR MESSAGE
	STDEV 			;MAKE SURE STRUCTURE IS MOUNTED
	 ERCAL [ERROR <Structure %3m: not mounted>]
	SETZB A,C		;USE DIRECTORY 0
	MOVEI B,GTDLN		;SET UP LENGTH OF BUFFER
	MOVEM B,.CDLEN+CRBLK	;IN FIRST WORD OF BUFFER
	MOVEI B,CRBLK		;POINT TO BUFFER
	GTDIR			;GET DEFAULTS
	MOVEI A,CRBLK		;GET ADRESS OF ENTIRE CRDIR BLOCK
	MOVEI B,1		;MAKE EMPTY GROUP BUFFERS
	MOVEM B,@.CDUGP(A)
	MOVEM B,@.CDDGP(A)
	MOVEM B,@.CDCUG(A)
	TXO Q1,CD%LIQ!CD%LOQ!CD%FPT!CD%DPT!CD%RET
	JRST CRET1A

CRET1:	MOVEM B,KREDIR		;REMEMBER DIRECTORY NUMBER
	HRROI A,CSTING		;GET STRING STORAGE POINTER
	DIRST
	 ERCAL CJERRE
	HRROI A,CSTING		;GET TO BEGINNING OF STRING AGAIN
	CALL BUFFS		;SAVE STRING
	EXCH A,KREDIR		;RESTORE DIR # AND SAVE STR
				;GET CURRENT INFORMATION FOR OLD DIRECTORY
	MOVEI B,GTDLN		;SET UP LENGTH OF BUFFER
	MOVEM B,.CDLEN+CRBLK	;IN FIRST WORD OF BUFFER
	MOVEI B,CRBLK
	HRROI C,CSTING		;PASSWORD GOES HERE (POINTER STORED IN BUFFER BY GTDIR)
	MOVE D,.CDDAC(B)	;GET POINTER TO WHERE ACCOUNT WILL GO
	GTDIR
	  ERCAL CJERRE
	MOVEM D,.CDDAC(B)	;RESTORE ACCOUNT POINTER TO POINT AT BEGINNING
	HRROI A,CSTING		;POINT TO PASSWORD
	CALL BUFFS		;ISOLATE IT
	SKIPE .CDPSW+CRBLK	;NO POINTER STORED MEANS PASSWORD NOT AVAILABLE
	MOVEM A,.CDPSW+CRBLK	;STORE POINTER TO ISOLATED PASSWORD
	MOVEI A,CRBLK		;GET ADDRESS OF BLOCK
	CALL GRPCHK		;CHECK FOR GROUP OVERFLOW
CRET1A:
;CREATE
;INPUT PASSWORD.
;FOR OLD DIRECTORY, THIS PASSWORD REPLACES OLD ONE - IS THAT GOOD?

	NOISE <PASSWORD>
	WORDX <Password>
	 CMERRX
	CALL BUFFF
	LDB B,[350700,,ATMBUF]	;SEE IF ANY PASSWORD TYPED
	JUMPE B,CREAT3		;JUMP IF NONE
	MOVEM A,.CDPSW+CRBLK	;PASSWD STRING PTR TO PARAMETER BLOCK
	TXO Q1,CD%PSW		;TELL CRDIR TO SET PASSWORD
CREAT3:	COMMAX <Optional comma, then carriage return to go into subcommand mode>
	 JFCL			;NO COMMA REQUIRED
	CONFIRM			;GET LINE CONFIRMATION
	CALL NORO		;TYPE NEW OR OLD

;CHECK, CONFIRM, EXECUTE

	SETZM .CDLEN+CRBLK	;CLEAR CRDIR BITS
CRSUB:	SUBCOM $CREAT,[TLZ Z,F1
		       RET]	;GET SUBCOMMANDS, CLEAR "NOT" BEFORE EACH ONE
CRSUB1:	MOVE A,KREDIR		;GET POINTER TO NAME STRING
	MOVEI B,CRBLK
	HLL B,Q1		;XWD FLAGS, PARAMETER BLOCK ADDRESS
	MOVE C,CRPASS		;GET 0 OR POINTER TO PASSWORD
	CRDIR			;CREATE DIRECTORY !
	 ERJMP NODIR		;FAILED, LET USER FIX SUBCOMMANDS AND TRY AGAIN
	CALLRET UNMDIR

;GET TO HERE IF CRDIR FAILED.  TELL USER, LET HIM FIX SUBCOMMANDS AND
;TRY AGAIN.

NODIR:	CALL DGETER		;SEE WHY IT FAILED
	CAIN A,ACESX3		;PASSWORD REQUIRED?
	JRST CRSUB2		;GET PASSWORD AND TRY AGAIN
	CAIN A,CNDIX1		;WRONG PASSWORD?
	JRST [	LERROR <%?%%_>	;YES, TELL HIM
		JRST CRSUB2]	;GET  ANOTHER PASSWORD AND TRY AGAIN
	LERROR <%?.%_Please fix incorrect subcommands.%_>
	JRST CRSUB		;GO BACK INTO SUBCOMMAND MODE

;GET TO HERE IF CRDIR FAILS DUE TO PASSWORD MISSING OR WRONG.  INPUT THE
;PASSWORD AND TRY CRDIR AGAIN.  THIS IS DONE RATHER THAN BOMBING OUT, TO TRY
;TO SAVE THE USER FROM HAVING TO DO ANOTHER BUILD WITH ALL THE PARAMETERS.

CRSUB2:	CALL PASLIN		;YES, GET ONE
	MOVEM A,CRPASS		;REMEMBER IT
	JRST CRSUB1		;GO TRY AGAIN
;TYPE "[NEW]" OR "[OLD]" DEPENDING ON WHETHER DIRECTORY IS NEW OR OLD

NORO:	TLNE Z,F2
	TYPE <[New]
>
	TLNN Z,F2
	TYPE <[Old]
>
	RET
;CREATE
;SUBCOMMAND DISPATCH TABLE
;FLAG B5 INDICATES "NOT" MAY PRECEDE THE SUBCOMMAND.

NOTF==1B5

$CREAT:	TABLE
	T ABORT,ONEWRD
	T ABSOLUTE-ARPANET-SOCKETS,NOTF,..AAS
	T ACCOUNT-DEFAULT,,.AD
   XARC <
	T ARCHIVE-ONLINE-EXPIRED-FILES,NOTF,..ARCH
   >
	T ARPANET-ACCESS,NOTF,..ANA
	T ARPANET-WIZARD,NOTF,..ANW
	T CONFIDENTIAL,NOTF
	T DECNET-ACCESS,NOTF,..DNA
	T DEFAULT-FILE-PROTECTION,,..PFIL
	T DIRECTORY-GROUP,NOTF,..DIRE
	T DISABLE
	T ENABLE
	T ENQ-DEQ,NOTF,..ENQ
	T FILES-ONLY,NOTF,.FILES
	T GENERATIONS,,..GENR
	T IPCF,NOTF
	T KILL,NOTF
	T LIST,,..LIST
	T MAINTENANCE,NOTF
	T MAXIMUM-SUBDIRECTORIES,,.MAXIM
	T NOT
	T NUMBER
   XARC <
	T OFFLINE-EXPIRATION-DEFAULT,,.OFFLI
	T ONLINE-EXPIRATION-DEFAULT,,.ONLIN
   >
	T OPERATOR,NOTF
	T PASSWORD
	T PERMANENT,,..LOQ
	T PRESERVE,,...PRE
	T PROTECTION,,...PRO
	T PUSH,,...PUS
	T REPEAT-LOGIN-MESSAGES,NOTF,..RLM
	T SUBDIRECTORY-USER-GROUP,,.SUSER
	T USER-GROUP,NOTF,.USER
	T WHEEL,NOTF
	T WORKING,,..LIQ
	TEND
;CREATE
;"NOT" CAN PRECEDE THOSE SUBCOMMANDS WHICH HAVE B5 SET IN TABLE.
;DISPATCH IS TO SAME ROUTINE BUT WITH "F1" SET TO REVERSE EFFECT.

.NOT:	KEYWD $$CREA
	 0
	 JRST CERR
	MOVE P4,P3
	TLO Z,F1
	JRST (P3)

$$CREA:	TABLE
	T ABSOLUTE-ARPANET-SOCKETS,NOTF,..AAS
   XARC <
	T ARCHIVE-ONLINE-EXPIRED-FILES,NOTF,..ARCH
   >
	T ARPANET-ACCESS,NOTF,..ANA
	T ARPANET-WIZARD,NOTF,..ANW
	T CONFIDENTIAL,NOTF
	T DECNET-ACCESS,NOTF,..DNA
	T DIRECTORY-GROUP,NOTF,..DIRE
	T ENQ-DEQ,NOTF,..ENQ
	T FILES-ONLY,NOTF,.FILES
	T IPCF,NOTF
	T KILL,NOTF
	T MAINTENANCE,NOTF
	T OPERATOR,NOTF
	T REPEAT-LOGIN-MESSAGES,NOTF,..RLM
	T SUBDIRECTORY-USER-GROUP,,.SUSER
	T USER-GROUP,NOTF,.USER
	T WHEEL,NOTF
	TEND

;ROUTINES FOR THE INDIVIDUAL SUBCOMMANDS

;PASSWORD
;CURRENTLY REDUNDANT EXCEPT THAT IT ALLOWS TYPIN IN A FORMAT MORE LIKE
; WHAT "PRINT" PUTS OUT AND ALLOWS GIVING A NULL STRING (USEFUL?).

.PASSW:	WORDX <1 to 39 alphanumeric characters or hyphens>
	 CMERRX
	CONFIRM
	CALL BUFFF
	MOVEM A,.CDPSW+CRBLK
	TXO Q1,CD%PSW
	RET
;"CREATE" SUBCOMMANDS

;LOGGED-IN (STORAGE LIMIT) <DECIMAL>

..LIQ:	CALL ..DISK
	MOVEM B,.CDLIQ+CRBLK
	TXO Q1,CD%LIQ
	RET

;LOGGED-OUT (STORAGE LIMIT) <DECIMAL>

..LOQ:	CALL ..DISK
	MOVEM B,.CDLOQ+CRBLK
	TXO Q1,CD%LOQ
	RET

..DISK:	NOISE <DISK STORAGE PAGE LIMIT>
	DECX <Decimal number of pages>
	 CMERRX
	CONFIRM
	CAML B,[^D1000000]	;LESS THAN A MILLION?
	HRLZI B,377777		;NO - GIVE INFINITE QUOTA
	RET

;SUBCOMMANDS FOR SPECIFIC PRIVILEGES AND MODES.
;F1 ON AT ENTRY IF PRECEDED BY "NOT".

;AC USE: A: MASK INDICATING BITS TO SET (F1 OFF), OR CLEAR (F1 ON).

..AAS:	SKIPA A,[SC%NAS]	;ABSOLUTE ARPANET SOCKETS
..ANW:	MOVEI A,SC%NWZ		;ARPANET WIZARD
	JRST CPRIV

..ANA:	SKIPA A,[SC%ANA]
..DNA:	MOVEI A,SC%DNA
	JRST CPRIV

..ENQ:	MOVEI A,SC%ENQ
	JRST CPRIV

.IPCF:	SKIPA A,[SC%IPC]
.MAINT:	MOVEI A,SC%MNT
	JRST CPRIV

.WHEEL:	SKIPA A,[SC%WHL]
.OPERA:	MOVEI A,SC%OPR
	JRST CPRIV

.CONFI:	NOISE <INFORMATION ACCESS CAPABILITY>
	MOVEI A,1B20
	JRST CPRIV1
CPRIV:	NOISE <CAPABILITY>
CPRIV1:	CONFIRM
	IORM A,.CDPRV+CRBLK	;SET BITS IN QUESTION
	TLNE Z,F1		;BUT IF SUBCOMMAND PRECEDED BY "NOT",
	ANDCAM A,.CDPRV+CRBLK	;CLEAR THE BITS.
	TXO Q1,CD%PRV
	RET

..RLM:	MOVX A,CD%RLM		;CHANGE REPEAT LOGIN MESSAGE BIT
	JRST CCMODE

..ARCH:	SKIPA A,[CD%DAR]
.FILES:	MOVX A,CD%DIR
;	JRST CCMODE		;(FALL INTO CCMODE)

CCMODE:	CONFIRM
	IORM A,.CDMOD+CRBLK	;SET BIT
	TLNE Z,F1		;PRECEDED BY "NOT"?
	ANDCAM A,.CDMOD+CRBLK	;YES, CLEAR BIT.
	TXO Q1,CD%MOD
	RET
;"CREATE" SUBCOMMANDS

;NUMBER <OCTAL>. SPECIFIES DIRECTORY NUMBER

.NUMBE:	NOISE <OF DIRECTORY>
	OCTX <Octal directory number>
	 CMERRX
	TLNN Z,F2
	JRST [	CAME B,.CDNUM+CRBLK
		ERROR <You can't change the number of an old directory>
		JRST NUMBE1]

;CHECK THAT THE NUMBER ISN'T IN USE BY TRYING TO CONVERT IT TO STRING.

	HRROI A,CSTING
	DIRST
	 CAIA			;NOT IN USE
	ERROR <Number already in use>
NUMBE1:	CONFIRM
	MOVEM B,.CDNUM+CRBLK
	SKIPE B
	TXO Q1,CD%NUM
	RET

.OFFLI:	NOISE <IS>
	DTIVX <Expiration date>
	 CMERRX
	CONFIRM
	MOVEM B,.CDDFE+CRBLK	;SAVE OFFLINE FLAG
	MOVX B,CD%FED		;CHANGE OFFLINE FLAG
	IORM B,.CDLEN+CRBLK
	TXO Q1,CD%LEN		;INDICATE LENGTH & OFF/ON EXP TO BE CONSIDERED
	RET

.ONLIN:	NOISE <IS>
	DTIVX <Expiration date>
	 CMERRX
	CONFIRM
	MOVEM B,.CDDNE+CRBLK	;SAVE ONLINE FLAG
	MOVX B,CD%NED		;CHANGE ONLINE FLAG
	IORM B,.CDLEN+CRBLK
	TXO Q1,CD%LEN		;INDICATE LENGTH & OFF/ON EXP TO BE CONSIDERED
	RET
;"CREATE" SUBCOMMANDS

;PROTECTION (OF DIRECTORY) <OCTAL>. LATER ALSO ALLOW NAMED PROT?

...PRO:	NOISE <OF DIRECTORY>
	OCTX <6-digit octal number>
	 CMERRX
	CONFIRM
	TLNE B,777777		;ALLOW TALT+TSPC+TEOL
	ERROR <6-digit value only>
	TLO B,500000
	MOVEM B,.CDDPT+CRBLK
	TXO Q1,CD%DPT
	RET

;PRESERVE (SUPERIOR QUOTAS)

...PRE:	NOISE <SUPERIOR QUOTAS>
	MOVX B,WHLU+OPRU
	CALL PRVCK		;MUST HAVE PRIVS FOR THIS FCN
	 ERROR <WHEEL or OPERATOR capability required>
	CONFIRM
	MOVX B,CD%NSQ		;NO SUBTRACT QUOTAS BIT
	IORM B,.CDLEN+CRBLK	;ASSUME ON
	TLNE Z,F1		;"NOT" ?
	ANDCAM B,.CDLEN+CRBLK	;YES
	RET

;ACCOUNT-DEFAULT

.AD:	NOISE <FOR LOGIN>
	LINEX <Default account for users logging into this directory>
	 CMERRX
	CONFIRM
	CALL BUFFF
	MOVEM A,.CDDAC+CRBLK	;REMEMBER NEW ACCOUNT
	TXO Q1,CD%DAC		;SAY TO SET STRING
	RET

..PFIL:	NOISE <NUMBER>
	OCTX <6-digit octal number>
	 CMERRX
	CONFIRM
	TLNE B,777777		;ALLOW TALT+TSPC+TEOL
	ERROR <6-digit value only>
	TLO B,500000
	MOVEM B,.CDFPT+CRBLK
	TXO Q1,CD%FPT
	RET

..GENR:	NOISE <TO KEEP>
	DECX <Decimal number of generations to retain per file>
	 CMERRX
	MOVE A,B		;LEAVE NUMBER IN A
	CONFIRM
	DMOVE B,[EXP 0,FB%RET]	;GET MASK FOR RETENTION COUNT FIELD
GENR1:	JUMPE C,GENR2		;IT'S RIGHT-JUSTIFIED WHEN C CONTAINS 0
	LSHC B,1		;DO A SHIFT
	JRST GENR1
GENR2:	JFFO B,.+1		;GET NUMBER OF BITS TO LEFT OF RIGHT-JUSTIFIED FIELD
	CAIL A,0
	CAMLE A,B		;MAKE SURE NUMBER IS IN RANGE
	ERROR <Must be 0-%2Q>
	MOVEM A,.CDRET+CRBLK	;STORE NEW GNERATION RET COUNT DEFAULT
	TXO Q1,CD%RET
	RET
;"CREATE" SUBCOMMANDS

;SUBDIRECTORY

;SUBDIRECTORY MAXIMUM

.MAXIM:	NOISE <ALLOWED>
	DECX <Decimal number of subdirectories allowed under this directory>
	 CMERRX			;INVALID NUMBER OF SUBDIRECTORIES
	CONFIRM
	MOVEM B,.CDSDQ+CRBLK	;REMEMBER NUMBER SPECIFIED
	TXO Q1,CD%SDQ		;REMEMBER TO SET THIS PARAMETER
	RET

;[NOT] SUBDIRECTORY USER

.SUSER:	NOISE <ALLOWED>
	MOVE A,.CDCUG+CRBLK	;ADDRESS OF SUBDIRECTORY USER GROUPS ALLOWED BUFFER
	HRLI A,SGBUFL		;SPECIFY LENGTH
	TXO Q1,CD%CUG
	CALLRET .GROUP		;CALL GROUP AND RETURN

;[NOT] USER (GROUP) <DECIMAL GROUP NUMBER 1-2**18>
;F1 ON IF PRECEDED BY "NOT"

.USER:	NOISE <NUMBER>
	MOVE A,.CDUGP+CRBLK	;USER GROUP BUFFER ADDRESS
	HRLI A,UGBUFL		;SPECIFY LENGTH OF BLOCK
	TXO Q1,CD%UGP		;SET USER GROUP FLAG
	CALLRET .GROUP		;CALL GROUP AND RETURN

;[NOT] DIRECTORY (GROUP) <DECIMAL GROUP NUMBER 1-2**18>

..DIRE:	NOISE <NUMBER>
	MOVE A,.CDDGP+CRBLK	;GET ADDRESS OF DIRECTORY GROUP BUFFER
	HRLI A,DGBUFL		;SPECIFY LENGTH
	TXO Q1,CD%DGP		;SET DIRECTORY GROUP FLAG; FALL INTO .GROUP
;	CALLRET .GROUP		;(FALL INTO .GROUP)

;SUBROUTINE TO ADD OR DELETE GROUP NUMBER FROM BUFFER IN A

.GROUP:	PUSH P,A		;SAVE BUFFER POINTER
	DECX <Decimal group number>
	 CMERRX
	CONFIRM
	MOVE A,B
	JUMPLE A,GRPER1		;OUT OF RANGE
	CAILE A,777777		;MUST FIT IN HALFWORD
GRPER1:	ERROR <Group numbers must be between 1 and 262143.>
	POP P,B			;GET BUFFER POINTER BACK
	MOVN C,(B)
	AOJGE C,GRPNX1		;JUMP IF EMPTY GROUP
	HRLZ C,C
	HRRI C,1(B)		;MAKE AOBJN PTR
GRPFN1:	CAMN A,(C)
	JRST GRPFN2
	AOBJN C,GRPFN1
GRPNX1:	TLNE Z,F1
	JRST [	ETYPE <%%No group to remove%_>
		RET]
	HLRZ C,B
	CAMG C,(B)		;BUFFER FULL YET?
	ERROR <Can't add new group; buffer full>
	AOS C,(B)		;COUNT ANOTHER ENTRY
	ADDI C,-1(B)		;POINT TO NEW ENTRY
	MOVEM A,(C)
	RET

GRPFN2:	TLNN Z,F1
	JRST [	ETYPE <%%Group already exists%_>
		RET]
	HRRI A,(C)		;DESTINATION
	HRLI A,1(C)		;SOURCE
	SOS C,(B)
	ADDI C,-1(B)		;LAST WORD TO STORE
	BLT A,(C)
	SETZM 1(C)		;CLEAR LAST WORD FOR CLEANLINESS
	RET
;"CREATE" SUBCOMMANDS

;KILL (THIS DIRECTORY)

.KILL:	NOISE <THIS DIRECTORY>
	CONFIRM
	TLNN Z,F1
	CALL FCONF		;FORCED CONFIRMATION IF KILL
	TXO Q1,CD%DEL
	TLNE Z,F1
	TXZ Q1,CD%DEL		;"NOT KILL" REVERSES EFFECT.
	RET

;ABORT: ABORT THIS CREATE. REDUNDANT FOR ^C.

.ABORT:	MOVEI A,RERET
	MOVEM A,CERET
	CALL UNMDIR
	JRST CMDIN4		;GO GET NEXT EXEC COMMAND

;LIST. PRINTS WHAT "PRINT" WILL PRINT IF THIS "CREATE" IS COMPLETED.
;"LIST VERBOSE" PRINTS AS "PRINT" WITH VERBOSE SUBCOMMAND

..LIST:	KEYWD $.LIST
	T FAST,,0		;DEFAULT IS "FAST"
	 JRST CERR
	TLZ Z,F3!F4
	CONFIRM
	TRNE P3,F4
	TLO Z,F4
	TRNE P3,F3
	TLO Z,F3
	MOVE A,KREDIR		;GET POINTER TO STRING FOR DIRPNT
	MOVEI B,CRBLK		;GET BLOCK ADDRESS
	TXNN Q1,CD%DEL
	JRST DIRPNT		;GO ACT LIKE "PRINT" COMMAND
	TYPE < Killed
>
	RET

;PUSH ALLOWS THE BUILDER TO PUSH OUT OF THE BUILD COMMAND, WHICH IS USEFUL
;IF ANOTHER BUILD COMMAND IS REQUIRED SUCCESSFULLY TO COMPLETE THE CURRENT
;ONE, OR IF ANOTHER COMMAND IS NECESSARY.

...PUS:	CALL .PUSH		;DO THE PUSH
	MOVE A,KREDIR		;GET POINTER TO DIRECTORY
	ETYPE <[Continuing BUILD of directory %1R]%_>
	RET

$.LIST:	TABLE
	T FAST,,0
	T NAME-ONLY,,F4
	T VERBOSE,,F3
	TEND

	END