*DECK DB$WR2K 
USETEXT CDCSCTX 
USETEXT JLPCMTX 
      PROC DB$WR2K; 
      BEGIN 
 #
* *   DB$WR2K - WRITE AK WITH ZERO KEY           PAGE  1
* *   BOB MCALLESTER                             DATE  01/20/83 
* 
* DC  PURPOSE 
* 
*     SUPPLY THE SPECIAL LOGIC THAT IS REQUIRED TO WRITE AN ACTUAL KEY
*     RECORD ON WHICH CRM IS TO SUPPLY THE KEY VALUE. 
*     THIS IS DONE WHEN THE USER SUPPLIED KEY VALUE IS ZERO.
*     THIS HAS SPECIAL REQUIREMENTS.
*      -  THE BEFORE-IMAGE LOGGING MUST BE DEFERRED UNTIL AFTER THE 
*         RECORD HAS BEEN WRITTEN, BECAUSE THE KEY VALUE IS NOT KNOWN 
*         ANY EARLIER.
*      -  MUST NOT ALLOW CRM TO SELECT A KEY VALUE THAT IS CURRENTLY
*         LOCKED. 
*      -  MUST RETURN THE SELECTED KEY VALUE TO THE USER PROGRAM. 
* 
* DC  ENTRY CONDITIONS
* 
* D   PARAMETERS
* 
*     NONE
* 
* D   ASSUMPTIONS 
* 
*     THE FOLLOWING POINTERS ARE SET. 
*       RCB                 RUN-UNIT COMMAND BLOCK
*       RSB                 RUN-UNIT STATUS BLOCK 
*       TQT                 TASK QUEUE TABLE
* 
* DC  EXIT CONDITIONS 
* 
*     THE AK RECORD HAS BEEN WRITTEN. 
*     THE ASSIGNED KEY HAS BEEN RETURNED TO THE CALLING USER. 
* 
* DC  CALLING ROUTINES
* 
*     DB$WR2$                WRITE CONTROL SYMBIONT 
* 
* DC  CALLED ROUTINES 
# 
      XREF PROC DB$ERR;      # ERROR MESSAGE PROCESSOR                 #
      XREF PROC DB$FLOP;     # RECORD A FLOW POINT                     #
      XREF PROC DB$FSET;     # SELECT AND SET A FIT                    #
      XREF PROC DB$FSIO;     # SET UP AN INTERNAL FIT                  #
      XREF PROC DB$JLH;      # SET UP A JOURNAL LOG RECORD HEADER      #
      XREF PROC DB$JLO;      # OUTPUT A JOURNAL LOG RECORD             #
      XREF PROC DB$LKRU;     # RELEASE ALL LOCKS FOR USER              #
      XREF PROC DB$LOK;      # REQUEST A RECORD LOCK                   #
      XREF PROC DB$MBA;      # ALLOCATE A MEMORY BLOCK                 #
      XREF PROC DB$MBF;      # FREE A MEMORY BLOCK                     #
      XREF PROC DB$MBS;      # SET MEMORY BLOCK POINTERS               #
      XREF PROC DB$MFO7;                # TERMINATE AREA USERS         #
      XREF PROC DB$NRR;      # SET UCP NO RERUN BIT                    #
      XREF PROC DB$PUSH;     # SEND A VARIABLE TO THE PUSH-DOWN STACK  #
      XREF PROC DB$SCHD;     # INTERRUPT THE CURRENT TASK              #
      XREF PROC DB$SFCL;     # SYSTEM CTL PT FUNCTION CALL             #
      XREF PROC DB$UNDU;     # UNDO A PENDING TRANSACTION              #
      XREF PROC DLTE;        # DELETE A CRM RECORD                     #
      XREF PROC PUT;         # WRITE A CRM RECORD                      #
  
      XREF ARRAY DB$RA0;
        BEGIN 
*CALL ALTDCLS 
        END 
# 
* DC  NON-LOCAL VARIABLES MODIFIED
* 
*     RCB                    REQUEST PACKET KEY VALUE FIELD RCPPAKY2. 
* 
*     COMMON BLOCK "DB$JLCM" VARIABLES DEFINED IN JLPCMTX.
*       P<PRIMKEY>
*       PARLEN
*       TRLRLEN 
*       P<JLREC>
*         JLHDWDA[0]
* 
*     P<UFT> IS SET BY DB$FSIO. 
* 
*     CDCSCOMMN 
*       LOKSTATUS 
# 
      XREF ITEM DB$MFPA I;              # MEMORY OVERFLOW PROC ADDRESS #
# 
* DC  DESCRIPTION 
* 
*     THE RECORD IS WRITTEN TO THE FILE.
*     THE CRM ASSIGNED KEY IS RETRIEVED FROM THE RECORD IMAGE 
*     AND SAVED FOR FURTHER PROCESSING. 
* 
*     A RECORD LOCK IS REQUESTED USING THE KEY ASSIGNED BY CRM. 
*     WHILE THE RECORD LOCK IS NOT GRANTED, EACH RECORD IS
*     LEFT ON THE FILE AND ANOTHER WRITE IS DONE TO GET 
*     A NEW KEY VALUE ASSIGNED. 
*     THE UNACCEPTABLE KEY VALUES ARE KEPT IN A KEY LIST. 
* 
*     WHEN AN ACCEPTABLE KEY IS ASSIGNED, IT IS SAVED IN THE
*     USERS REQUEST PACKET. 
*     THEN ALL OF THE RECORDS THAT WERE WRITTEN WITH UNACCEPTABLE 
*     KEY VALUES ARE DELETED. 
* 
*     IF BEFORE-IMAGE LOGGING IS REQUIRED, THE ACCEPTABLE KEY 
*     VALUE IS USED IN A BEFORE-IMAGE LOG RECORD. 
* 
*     THE KEY VALUE IS ALSO RETURNED TO THE USER CONTROL POINT
*     VIA AN SFCALL.
 #
  
  
# 
*     LOCAL VARIABLES 
# 
  
  
      BASED ARRAY FIT;;      # DUMMY FOR CALLING CRM                   #
  
      BASED ARRAY KEYLIST;
        BEGIN 
        ITEM KEYWORD  I(00,00,60);  # CONTAINS AN UNACCEPTABLE KEY     #
        END 
  
      BASED ARRAY REC;       # TO ADDRESS THE WSA                      #
        BEGIN 
        ITEM RECW  I(00,00,60); 
        END 
  
      ITEM SAVEMFPA I;       # SAVE MEMORY OVERFLOW PROCEDURE ADDRESS  #
      ITEM XX I;             # INDUCTION VARIABLE                      #
      ITEM ZERO I = 0;       # ZERO KEY VALUE                          #
  
  
  
  
  
#     B E G I N   D B $ W R 2 K   E X E C T U T A B L E   C O D E      #
  
  
      CONTROL IFGR DFFLOP,0;
        DB$FLOP("WR2K");     # RECORD A FLOW POINT                     #
      CONTROL ENDIF;
  
#     IF THE AREA IS LOCKED, WAIT FOR THE AREA LOCK TO BE CLEARED.     #
#       NOTE THAT THERE IS NO DEADLOCK DETECTION ATTEMPTED HERE.       #
  
      XX = OFALT[0];
      FOR XX=XX WHILE XX NQ 0 
      DO
        BEGIN 
        IF ALLOCK[XX] 
          AND ALOWNER[XX] 
          AND ALTQT[XX] NQ LOC(TQT) 
        THEN                 # THERE IS AN AREA LOCK, WAIT.            #
          BEGIN 
          IF TQIMRTN[0]      # IF IMMEDIATE RETURN IS SET              #
          THEN
            BEGIN 
            IF TQARTX[0] NQ 0 
            THEN             # IN TRANSACTION MODE                     #
              BEGIN          # BACK OUT THE TRANSACTION                #
              DB$UNDU;
              END 
            DB$LKRU(TRUE);   # RELEASE ALL LOCKS FOR THIS RUN-UNIT     #
            DB$ERR(55); 
  
            END 
          DB$PUSH(10);       # WAIT 10 SCHEDULER CYCLES                #
          DB$SCHD(LOC(STATCOMP),DFWAITCOUNT); 
  
          CONTROL IFGR DFFLOP,0;
            DB$FLOP("WR2K-S1"); 
          CONTROL ENDIF;
  
          P<OFT> = RSAROFIT[0]; 
          XX = OFALT[0];
          END 
        ELSE
          BEGIN 
          XX = 0; 
          END 
        END 
  
#     ISSUE THE CRM PUT REQUEST                                        #
  
      DB$NRR; 
      UFFITRL[0] = FPFITRL[0];
      SAVEMFPA = DB$MFPA; 
      DB$MFPA = LOC(DB$MFO7); 
      P<FIT> = LOC(UFFIT[0]); 
      PUT(FIT,DB$RA0);
      DB$MFPA = SAVEMFPA; 
  
#     REQUEST A RECORD LOCK ON THE RECORD.                             #
#     MAKE THE REQUEST WITHOUT QUEUEING.                               #
  
      P<REC> = UFFITWSA[0]; 
      DB$LOK(LOC(RECW[UFFITRKW[0]]),UFFITRKP[0],FALSE); 
      P<KEYLIST> = 0; 
  
#     IF THE RECORD LOCK WAS NOT AVAILABLE, ISSUE ANOTHER PUT          #
#     TO GET ANOTHER KEY VALUE ASSIGNED.                               #
#     REPEAT THIS PROCESS UNTIL AN ACCEPTABLE KEY IS ASSIGNED          #
  
#     NOTE -                                                           #
#       WHEN THE LOCK IS NOT ASSIGNED IT IS BECAUSE ANOTHER            #
#       USER IS WITHIN A TRANSACTION SEQUENCE AND HAS DELETED          #
#       A RECORD THAT HAD THAT ACTUAL KEY.                             #
#       THE KEY VALUE MAY NOT BE ASSIGNED UNTIL THAT OTHER             #
#       TRANSACTION HAS BEEN COMMITTED.                                #
  
      FOR XX = XX WHILE NOT LOKSTATUS 
      DO
        BEGIN 
        DB$FSET;               # SELECT AND SET A FIT                  #
        DB$MBA(1,P<KEYLIST>);  # ALLOCATE A KEY VALUE BUFFER           #
        C<0,UFFITKL[0]>KEYWORD[0] = 
                        C<UFFITRKP[0],UFFITKL[0]>RECW[UFFITRKW[0]]; 
        C<UFFITRKP[0],UFFITKL[0]>RECW[UFFITRKW[0]] =
                             C<0,UFFITKL[0]>ZERO; 
        UFFITRL[0] = FPFITRL[0];
        P<FIT> = LOC(UFFIT[0]); 
        SAVEMFPA = DB$MFPA; 
        DB$MFPA = LOC(DB$MFO7); 
        PUT(FIT,DB$RA0);
        DB$MFPA = SAVEMFPA; 
        DB$LOK(LOC(RECW[UFFITRKW[0]]),UFFITRKP[0],FALSE); 
  
        CONTROL IFGR DFFLOP,0;
          DB$FLOP("WR2K-ER");  # RECORD A FLOW POINT                   #
        CONTROL ENDIF;
  
        END 
      FPFITRL[0] = UFFITRL[0];
  
#     SAVE THE ACCEPTABLE KEY VALUE IN THE REQUEST PACKET.             #
  
      C<0,UFFITKL[0]>RCPPAKY2[0] =
                        C<UFFITRKP[0],UFFITKL[0]>RECW[UFFITRKW[0]]; 
  
#     DELETE ANY RECORDS THAT HAVE BEEN WRITTEN WITH UNACCEPTABLE      #
#     KEY VALUES.                                                      #
  
      FOR XX = XX WHILE LOC(KEYLIST) NQ 0 
      DO
        BEGIN 
        DB$FSIO;             # USE AN INTERNAL FIT                     #
        UFFITKA[0] = LOC(KEYWORD[0]); 
        SAVEMFPA = DB$MFPA; 
        DB$MFPA = LOC(DB$MFO7); 
        P<FIT> = LOC(UFFIT[0]); 
        DLTE(FIT,DB$RA0); 
        DB$MFPA = SAVEMFPA; 
        DB$MBF(P<KEYLIST>);  # FREE THE KEY LIST ENTRY                 #
        P<KEYLIST> = 0; 
        DB$MBS;              # GET ANOTHER ENTRY IF PRESENT            #
        END 
  
#     DO BEFORE-IMAGE LOGGING                                          #
  
      IF RSARLGBR[0]
        OR TQARTX[0] NQ 0 
      THEN
        BEGIN 
        PARLEN = DFHDRSZ + UFFITKL[0];
        DB$JLH; 
        P<PRIMKEY> = UFFITKA[0];
        IF RSARLGBR[0]
        THEN
          JLHDWDA[0] = DFJLWDABW; 
        ELSE
          JLHDWDA[0] = DFJLWDATW; 
        TRLRLEN = 0;
        DB$JLO; 
        END 
  
#     RETURN THE KEY VALUE TO THE USER.                                #
  
      DB$SFCL(DFSFWRIT,1,RCPFITKA[0], FPFITWSA[0] + FPFITRKW[0]); 
  
      END 
      TERM
