; ; ; WRTKEY ; ; WRTKEY - WRITES A UNIQUE DATABASE KEY ; ; ROUTINE NAME: WRTKEY ; ; PURPOSE: This procedure writes a unique key in a database ; file at the currently active level. Several ac- ; tions can be selected for a non-unique key (see ; the MODE parameter). ; ; CALLABLE: From FORTRAN ; CALL WRTKEY(ROOT,KEY[,DATA][,MODE][,ERR]) ; or ; ERR=WRTKEY(ROOT,KEY[,DATA][,MODE][,ERR]) ; ; PARAMETERS: ; ROOT The database root block and I/O buffers ; KEY A string to use for the scan section of the new ; key. This new key can have wild card characters ; (\) in it, but the result depend on the MODE of ; the write. If you attempt to write backslashes ; into a new key, they will be turned into blanks. ; The key is assumed to be the same length as the ; scan size for keys at this level, if the key is ; terminated prematurely by a NUL, it is assummed to ; be padded with backslashes. ; VALS The data section of the new key. if the VALS sec- ; tion of a new key is ommitted, you the key will be ; created with unpredictable data in the data sec- ; tion. ; MODE The action to take when the key is not unique. ; The different modes supported are: ; MODE=0 Error return if key is not unique. ; MODE=1 Delete old data under existing key and re- ; turn success. ; MODE=2 "Fndkey" mode. The already existing key is ; activated as if it was found by fndkey. ; MODE=3 Modify key parameter if it is not unique. ; The key is modified by doing a successor fuction ; on the first few bytes of the key. ; ERR Error return parameter. Possible errors are: ; ERR=-100 Bad ROOT block. ; ERR= -99 You do not have write access. ; ERR= 0 Key was not unique (MODE=0). ; ERR= +n Successfull return. ; ; ROUTINES USED: B$ACTIVATE B$ALOCATE B$DELETEDATA B$GETNEXT ; B$IOERROR, READVB and WRITEVB macros. ; ; EXAMPLE: ; CALL WRTKEY(ROOT,'NEW KEY',,0,ERR) ; CALL WRTKEY(ROOT,KEY,DATA,,2) ; IF (WRTKEY(ROOT,KEY,DATA) .LE. 0) GOTO 999 ; ; AUTHOR: Mike Higgins ; ; SOURCE LANGUAGE: MACRO11 with SUPERMAC ; ; OBJECT MODULE NAME: WRTKEY ; ; LIBRARY: [60,100]DATABASE ; ; MAINTENANCE: See Mike Higgins ; ; ;REGESTER ASSIGNMENTS ROOT=R4 BUF=R3 LEVEL=R2 TEM=R1 TEM2=R0 ; PARAMETERS RT=2 KEY=4 VAL=6 MODE=10 ERR=12 .MCALL SUPER SUPER PROCEDURE WRTKEY ;(ROOT,KEY[,VALS][,MODE][,ERR]) LET ROOT := RT(R5) ;GET POINTER TO ROOT BLOCK IF DB.BLT(ROOT) NE #"RT ;IS THIS A ROOT BLOCK? FORET #ER.NRB,ERR ;NO! WHAT ARE YOU PROGRAMMERS RETURN ;TRYING TO PUSH ON ME???!!! END IF #FL.WRT OFF.IN RT.FLG(ROOT) ;DO YOU HAVE WRITE PERMISSION? FORET #-99.,ERR ;NO?! WELL, I'M CERTANLY NOT RETURN ;GOING TO DO ANY MORE WORK HERE! END LET LEVEL := RT.PCL(ROOT) ;GET THE LEVEL TABLE SP PUSH #0,#0 ;ALOCATE TWO SCRATCH VALUES ON SYS STACK ACTIVE: SCALL B$ACTIVATE ;RESET TO BEGENING OF LEVEL ON.ERROR ;IF NO BLOCKS, GO ALOCATE A NEW ONE JUMPTO ALOCNEW END REPEAT: ;LOOP FOR ALL KEYS IF (BUF) EQ #0 ;IS THIS KEY IN USE? LET (SP) := LV.PCB(LEVEL) ;NO, REMEMBER IT'S BLOCK NUMBER LET 2(SP) := BUF ;AND IT'S ADDRESS ELSE ;YES,COMPARE IT AGENST THE PARAMETER KEY LET TEM2 := LV.SCN(LEVEL) ;GET LENTH OF A KEY IF RESULT IS GT ;MAKE SURE THERE IS A SCAN SECTION LET TEM := KEY(R5) ;GET ADDRESS OF PARAMETER PUSH BUF ;SAVE POINTER AWAY THRU TEM2 ;LOOP FOR ALL BYTES IN KEY IFB (TEM) EQ #0 THEN GOTO DUPLIC ;PREMATURE NUL IFB (TEM) NE #'\ ;CHECK FOR WILD CARD CHARACTER IFB (BUF)+ NE (TEM)+ THEN GOTO INCR ;ARE THEY EQUAL? ELSE TSTB (BUF)+ ;SKIP THE WILD CARD AND IT'S MATCH TSTB (TEM)+ END END DUPLIC: POP BUF ;RESTORE POINTER TO BEGENING OF KEY END LET TEM := #0 ;THE KEY IS NOT UNIQUE!!! CHECK THE MODE IF (R5) GE #MODE/2 ;MODE DEFALTS TO ZERO IF IF MODE(R5) NE #-1 ;IT IS NOT INCLUDED LET TEM := @MODE(R5) ;TERE IS A MODE PARAMETER END END IF TEM EQ #0 ;MODE ZERO, RETURN ERROR LET SP := SP + #4 ;CLEAN UP STACK FORET #0,ERR RETURN END IF TEM EQ #1 ;MODE 1, DELETE OLD DATA UNDER KEY LET LV.PCE(LEVEL) := BUF ;UPDATE ROOT TO NEW KEY PUSH R5 ;SAVE R5 LET R5 := #FAKARG ;POINT R5 AT A ZERO FOR B$DELETEDATA SCALL B$DELETEDATA ;DELETE ALL OFSPRING POP R5 ;RESTORE R5 ;SKIP TO THE DATA SEECTION OF THE KEY LET BUF := LV.PCE(LEVEL) + LV.SCN(LEVEL) JUMPTO XFRVAL ;AND GO GET THE VALS ARGUMENT END IF TEM EQ #2 ;MODE 2, APPEND DATA LET SP := SP + #4 ;CLEAN UP STACK FORET RT.LEV(ROOT),ERR ;RETURN SUCCESS LET LV.PCE(LEVEL) := BUF ;UPDATE LEVEL TABLE RETURN END ;IF THE MODE IS NOT 0, 1 OR 2, ;MODE 3 IS ASSUMED ;MODE 3, MODIFY KEY AND TRY AGAIN LET TEM := KEY(R5) ;GET ADDRESS OF KEY MODKEY: LET (TEM) :B= . + #1 ;INCRIMENT FIRST BYTE OF KEY IFB (TEM) LE #'Z THEN GOTO ACTIVE ;IF NO CARRY, GO TRY THIS KEY LET (TEM)+ :B= #'A ;IF CARRY, RESET THIS BYTE AND GO TO NEXT GOTO MODKEY INCR: ;TRANSFER ADDRESS WHEN KEYS DID NOT MATCH POP BUF ;CLEANUP REGISTERS BEFORE GOING OUT OF IF BLOCK END LET BUF := . + LV.LEN(LEVEL) ;INCRIMENT TO NEXT KEY ;IS THE NEXT KEY IN THIS BLOCK? IF BUF LE RT.LLA(ROOT) THEN JUMPTO REPEAT SCALL B$GETNEXT ;NO,, GET NEXT BLOCK ON.NOERROR ;IS THERE ANOTHER BLOCK? GOTO REPEAT ;YES, HAVE AT IT END ; ;CONTROL PASSES HERE ONLY WHEN THE ;KEY PARAMETER DID NOT MATCH ANY OF ;THE KEYS AT THIS LEVEL LET TEM := (SP) ;BY JOVE! THIS KEY IS REALLY UNIQUE!!! LET BUF := 2(SP) ;WERE THERE ANY SPARE SLOTS TO PUT IT IN? IF RESULT IS NE IF TEM NE LV.PCB(LEVEL) ;YES! READ THAT BLOCK INTO CORE IF IT IS NOT IF #FL.MOD SET.IN LV.FLG(LEVEL) ;WRITE OUT ANYBODY WHO IS IN CORE WRITEVB LV.PCB(LEVEL),RT.BUF(ROOT) ;NOW TO MAKE ROOM END READVB TEM,RT.BUF(ROOT) ;READ IN THE NEAREST BLOCK WITH SPARE LET LV.PCB(LEVEL) := TEM ;POINT THE LEVEL TABLE AT IT END ELSE ;RATS! NO SPARE SLOTS, I'LL HAVE TO MAKE SOME ALOCNEW: SCALL B$ALOCATE ;ALOCATE A BLOCK LET LV.FLG(LEVEL) := . SET.BY #FL.ACT ;ACTIVATE THIS LEVEL IF IT IS N END ;INSERT THE KEY LET LV.PCE(LEVEL) := BUF ;REMEMBER CURRENTLY ACTIVE KEY LET TEM2 := LV.SCN(LEVEL) ;GET LENTH OF A KEY IF RESULT IS GT ;MAKE SURE KEYS HERE HAVE SCAN SECTIONS LET TEM := KEY(R5) ;GET ADDRESS OF NEW KEY THRU TEM2 ;LOOP FOR ALL BYTES IFB (TEM) EQ #0 ;IF PARAM KEY IS TERMINATED LET (BUF)+ :B= #40 ;BY A NULL, SPACE FILL THE REST ELSE IFB (TEM) EQ #'\ ;IF THE KEY HAS BACKSLASHES IN IT, LET (BUF)+ :B= #40 ;REPLACE THEM WITH SPACES TSTB (TEM)+ ELSE LET (BUF)+ :B= (TEM)+ ;XFER IT ACCROSS END END END END ;TRANSFER THE VALS PARAMETER TO THE ;DATA SECTION OF A KEY XFRVAL: IF (R5) GE #VAL/2 ;IS THERE A VALS ARGUMENT? LET TEM := VAL(R5) ;THEN GET IT'S ADDRESS IF TEM NE #-1 ;IS IT NOT A NULL ARG? LET TEM2 := LV.LEN(LEVEL) - LV.SCN(LEVEL) ;COMPUTE LENTH OF VAL SECT IF RT.LEV(ROOT) LT RT.NLV(ROOT) ;LENGTH IS DIFFERENT ON BOTTOM LEVEL LET TEM2 := TEM2 - #4 ;ALL OTHER LEVELS ARE 4 BYTES SMALLER END IF TEM2 GT #0 ;DOES THIS KEY HAVE A DATA SECTION? THRU TEM2 ;YES, LOOP FOR ALL BYTES LET (BUF)+ :B= (TEM)+ ;XFER THEM ACCROSS END END END END LET LV.FLG(LEVEL) := . SET.BY #FL.MOD ;MARK THE BLOCK AS MODIFIED IF RT.LEV(ROOT) LT RT.NLV(ROOT) ;IF THERE IS ANOTHER LEVEL, LET TEM := LV.PCE(LEVEL) + LV.LEN(LEVEL) ;COMPUTE THE LAST LET -(TEM) := #0 ;ADDRESS IN THIS KEY AND ZERO IT LET -(TEM) := RT.AGE(ROOT) ;ALSO DATE THE KEY END LET SP := SP + #4 ;CLEAN UP THE STACK FORET RT.LEV(ROOT),ERR ;RETURN SUCCESS ENDPROCEDURE WRTKEY FAKARG: .WORD 0 .END