.title PSRSCS .ident /V05-002/ ; © 2000 P. Beaudoin ; This software is supplied as is and the usual warranty ; is implied - none. You may use, abuse, modify or ; or ignore this software as you see fit but are ; encouraged to give credit, as is good practice ; when stealing with permission ; ;++ ;1 PSRSCS ; Program to receive LAVC frames from Listen, process them and ; build the internal PSRSCS DB. ; ;2 Database ; Ethernet (SCS) address ; Cluster id ; SCS Node Name ;2 Modifications ; 1-001 Created by PB a long time ago ; 1-002 20-feb-1998 PB Added call to MAKE_NAME_FRAME to ; include CRC in name frame ;-- .LIBRARY /SYS$LIBRARY:LIB.MLB/ .LIBRARY /EMU5_LIB:EMU5.MLB/ EMUIPCDEF ; IPC buffers EMUSYSDEF EMUCTRLDEF EMUPSRDEF EMUCNTDEF EMURLTDEF EMUMSGDEF $LCKDEF .psect rw_data, noexe, rd, wrt, quad, pic, noshr THIS_PROCESS = SYS_PID_C_PSRSCS THIS_PROCESS_FLAG = SYS_FLG_C_PSRSCS ; Global Section areas ; ; returned addresses .ALIGN QUAD INADDR: .QUAD 0 EBUFFS_A: .QUAD 0 CONTROL_A: .QUAD 0 SCSDB_A: .QUAD 0 PSRTBL_A: .QUAD 0 COUNTERS_A: .QUAD 0 RLTCXT: .LONG 0 ; Relater context GBLSIZ: .LONG 0 RELDIS: .LONG 0 ; temp - move to section PSRTBLCNT: .LONG 0 ; Count of psr table entries PASS_COUNT: .LONG 0 ; COunt of buffs rec'ed 1 cycle BOXID: .LONG 0 NAMFRM: NF_PID: .LONG NF_KEY2: .LONG NF_NAM: .QUAD NF_DESC: .LONG .-NAMFRM .ADDRESS NAMFRM SCS_NF_LEN = 16 ; Locking ; Lock value block SCSDBLVB: SCSLVBSTA: .WORD 0 ; Status SCSLVBRES: .WORD 0 ; Reserved SCSLVBID: .LONG 0 ; Lock id SCSLVBSIZ: .LONG 0 ; Begining of LVB (Size of DB in pages) SCSLVBSPR: .BLKL 3 ; Unused 12 bytes ; $ENQ call frame SCSDBLOCK: .LONG 12 ; Arguments .LONG 0 ; EFN LKMODE: .LONG LCK$K_EXMODE ; Lock mode .ADDRESS SCSDBLVB ; Lock value block LKFLGS: .LONG ; Use value block LKNAM: .ADDRESS SCSDBLKNAM ; Resourse name .LONG 0 ; Parent id .LONG 0 ; AST .LONG 0 ; AST Param .LONG 0 ; BLAST .LONG 0 ; ACC Mode .LONG 0 ; RSDM_ID .LONG 0 ; Null ; Error Log ; The error system works as follows: ; The standard header contains the Routine name, the error number, the VMS ; error code, time and may be followed by a counted ascii string. There is ; a spare word in the header. All routines using this error system write in ; this format to a common file. ; ; The format is below: ; Error System Params ERRORMSG: .LONG ;Arg, opts MSGCDE: .LONG ; Error code PARCNT: .WORD ; Paramater count .WORD ; Opts .LONG ; Time .ADDRESS RTNNAM ; Our name MSGPARAMS: .BLKL 7 ; Up to 7 params RTNNAM: .ASCID /PSRSCS/ .ALIGN LONG SCSSECFAB: $FAB FAC = ,- ; Access FNM = SCSSECRAB: $RAB FAB = SCSSECFAB,- ; Record RAC = SEQ,- RBF = SCSSECREC,- ; UBF = SCSSECREC,- ; USZ = SCSSECREC_SIZE,- ; RSZ = SCSSECREC_SIZE ; SCSSECREC: .BLKB PSR_SCS_C_RECSIZ SCSSECREC_SIZE = .-SCSSECREC .ALIGN LONG EXIT_STATUS: .LONG 0 EXIT_BLOCK: .LONG 0 .ADDRESS PSRSCS_EXIT .LONG 1 .ADDRESS EXIT_STATUS EFLAGS1: .ASCID /EFLAGS1/ ; Event Flag Cluster (64-95) EFLAGS2: .ASCID /EFLAGS2/ ; Event Flag Cluster (96-127) SCSDBLKNAM: .ASCID /EMU_SCSDB/ ; DB Lock name SCSSECNAM: .ASCID /EMU_PSRSCS/ ; DB section name ;misc .align long HIORD: .BYTE ^XAA,^X00,^X04,^X00 FLAGS: .LONG 0 DEFRECCNT: .LONG 1000 ; DEF dbsize .psect prog_code, rd, nowrt, exe, pic, shr, quad .CALL_ENTRY MAX_ARGS=0, - HOME_ARGS=TRUE, - INPUT =, - PRESERVE=, - LABEL=PSRSCS ; Ensure death if control process dies CALLS #0, G^GET_CONTROL_LOCK ; BLBS R0,10$ MOVL #MSG_GENPSR_CTLLCK,MSGCDE ; General PSR error MOVL #1,PARCNT ; 2 params MOVAL MSGPARAMS,R1 ; Plist MOVL R0,(R1) ; VMS error PUSHAL ERRORMSG ; Log it CALLS #1,G^EMU_LOGGER RET 10$: ; ; Define LNM$TEMPORARY_MAILBOX = LNM$SYSTEM ; make all temporary things in the system logical name table CALLS #0, G^ASN_TEMPMBX_SYSTEM BLBS R0,20$ MOVL #MSG_GENPSR_ASSMBX,MSGCDE ; General PSR error MOVL #1,PARCNT ; 2 params MOVAL MSGPARAMS,R1 ; Plist MOVL R0,(R1) ; VMS error PUSHAL ERRORMSG ; Log it CALLS #1,G^EMU_LOGGER RET 20$: ; Create and Map to sections ; PUSHAL COUNTERS_A CALLS #1,G^MAP_COUNTERS BLBS R0,25$ MOVL #MSG_GENPSR_MAPCNT,MSGCDE ; General PSR error MOVL #1,PARCNT ; 2 params MOVAL MSGPARAMS,R1 ; Plist MOVL R0,(R1) ; VMS error PUSHAL ERRORMSG ; Log it CALLS #1,G^EMU_LOGGER RET 25$: PUSHAL EBUFFS_A ; Ebuffs section return addresses CALLS #1, G^MAP_EBUFFS ; Create and map ebuffs BLBS R0,30$ MOVL #MSG_GENPSR_MAPCNT,MSGCDE ; General PSR error MOVL #1,PARCNT ; 2 params MOVAL MSGPARAMS,R1 ; Plist MOVL R0,(R1) ; VMS error PUSHAL ERRORMSG ; Log it CALLS #1,G^EMU_LOGGER RET 30$: PUSHAL CONTROL_A ; Control section return addresses CALLS #1, G^MAP_CONTROL ; Create and map control section BLBS R0,40$ MOVL #MSG_GENPSR_MAPCTL,MSGCDE ; General PSR error MOVL #1,PARCNT ; 2 params MOVAL MSGPARAMS,R1 ; Plist MOVL R0,(R1) ; VMS error PUSHAL ERRORMSG ; Log it CALLS #1,G^EMU_LOGGER RET 40$: PUSHAL PSRTBLCNT ; Count of entries found PUSHAL PSRTBL_A ; PSR table start addr CALLS #2,G^MAP_PSRTBL BLBS R0,50$ MOVL #MSG_GENPSR_MAPPSRT,MSGCDE ; General PSR error MOVL #1,PARCNT ; 2 params MOVAL MSGPARAMS,R1 ; Plist MOVL R0,(R1) ; VMS error PUSHAL ERRORMSG ; Log it CALLS #1,G^EMU_LOGGER RET 50$: ; Lock and map our database CALLS #0,G^MAP_SCSDB BLBS R0,60$ MOVL #MSG_GENPSR_MAPDB,MSGCDE ; General PSR error MOVL #2,PARCNT ; 2 params MOVAL MSGPARAMS,R1 ; Plist MOVL R0,(R1)+ ; VMS error MOVAL SCSSECNAM,(R1) PUSHAL ERRORMSG ; Section name CALLS #1,G^EMU_LOGGER RET 60$: ; Declare exit handler $DCLEXH_S DESBLK=EXIT_BLOCK ; BLBS R0,65$ MOVL #MSG_GENPSR_NOHNDLR,MSGCDE ; General PSR error MOVL #1,PARCNT ; 2 params MOVAL MSGPARAMS,R1 ; Plist MOVL R0,(R1) ; VMS error PUSHAL ERRORMSG ; Log it CALLS #1,G^EMU_LOGGER RET 65$: ; ; Register constants ; R6 = Current buffer ; R8 = current datarec ; R9 = addr of que header ; R11 = counters MOVL EBUFFS_A,R9 ; que heads ; Common Event flag Cluster: ; $ASCEFC_S EFN = #64,- NAME = EFLAGS1 BLBC R0,70$ $ASCEFC_S EFN = #96,- NAME = EFLAGS2 BLBS R0,80$ 70$: MOVL #MSG_GENPSR_NOHNDLR,MSGCDE ; General PSR error MOVL #1,PARCNT ; 2 params MOVAL MSGPARAMS,R1 ; Plist MOVL R0,(R1) ; VMS error PUSHAL ERRORMSG ; Log it CALLS #1,G^EMU_LOGGER RET 80$: ; Locate our place in the PSR table to store counts MOVL PSRTBL_A,R6 ; MOVL PSRTBLCNT,R3 ; Count of entries 100$: CMPL #THIS_PROCESS_FLAG,PSR_TBL_L_PSRID(R6) BEQLU 110$ ADDL #PSR_TBL_C_SIZE,R6 ; Next entry SOBGTR R3,100$ ; Loop for all MOVL #SS$_ITEMNOTFOUND,R0 ; We could not find ourselves RET 110$: ; Find our area in counters section and init MOVL COUNTERS_A,R11 ; Start of counters ADDL #CNT_PSR_C_START,R11 ; Start of PSRs MULL3 #THIS_PROCESS,#CNT_PSR_C_ASIZE,R1 ; Offset ADDL R1,R11 ; Our space MOVC5 #0,#0,#0,#CNT_PSR_C_ASIZE,(R11) ; Clear MOVQ PSR_TBL_Q_DNAM(R6),CNT_PSR_Q_NAME(R11) ; Our name MOVL PSR_TBL_L_RELDIS(R6),RELDIS ; relater disable ; Send message to relater to enable us MOVL #100,R2 ; Try this many times 120$: CLRL RLTCXT PUSHL #THIS_PROCESS ; Identify sender PUSHL #RLT_FRM_C_MSGSTART ; Start us PUSHAL BOXID ; Dummy Boxid PUSHAL RLTCXT ; Context CALLS #4,G^CREATE_RELATER_FRAME BLBS R0,130$ SOBGTR R2,120$ ; Fatal error - log it and exit MOVL #MSG_GENPSR_SNDRLT,MSGCDE ; General PSR error MOVL #1,PARCNT ; 2 params MOVAL MSGPARAMS,R1 ; Plist MOVL R0,(R1) ; VMS error PUSHAL ERRORMSG ; Log it CALLS #1,G^EMU_LOGGER RET 130$: PUSHL RLTCXT ; Context CALLS #1,G^SEND_RELATER_FRAME 140$: WAIT: $wflor_s EFN=#96,- ; Wait for our flag set MASK=#THIS_PROCESS_FLAG $READEF_S EFN=#96,- ; Get EBUFF Flags STATE=FLAGS ; Current state READ: ; When our flag is set: ; 1. Clear our CEF ; 2. Attempt to remove a command buffer. If any received, process ; 3. Scan all ebuffs for any with our flag set. ; If any found, process the buffer and clear our flag. ; repeat 3. until no buffs are found for us ; Wait for our CEF ; Clear our CEF ADDL3 #96,#THIS_PROCESS,R1 PUSHL R1 CALLS #1,G^SYS$CLREF ; Here call process command buffer CLRL PASS_COUNT ; Clear cycle count MOVL EBUFFS_A,R6 ; Ethernet buffers ADDL #IPC_EBUF_C_BUFSTART,R6 ; Buffers MOVL #IPC_ETH_C_BUFNO,R7 ; Number of buffers MAIN: BBS #THIS_PROCESS,IPC_HDR_L_RFLAGS(R6),PROCESS ; Br if buffer is ours ADDL #IPC_ETH_C_BUFSIZE,R6 SOBGTR R7,MAIN TSTL PASS_COUNT ; Did we process any? BNEQU READ ; Cycle again BRW WAIT PROCESS: INCL CNT_PSR_L_PRCV(R11) ; Count 1 buff in PUSHL #1 ; Create if not found PUSHL #THIS_PROCESS ; This process is creator PUSHAL BOXID ; BOXID - always = 0 PUSHAL SCSDB_A ; Section ADDL3 #IPC_ETH_EA_SA,R6,-(SP) ; Addr of SCS addr PUSHL #PSR_SCS_EA_ADDR ; Offset to addr PUSHL #6 ; Push len CALLS #7,G^LOCATE_PSRREC BLBS R0,10$ MOVL #MSG_EMUSYS_LOCPSR,MSGCDE ; General PSR error MOVL #1,PARCNT ; 2 params MOVAL MSGPARAMS,R1 ; Plist MOVL R0,(R1) ; VMS error PUSHAL ERRORMSG ; Log it CALLS #1,G^EMU_LOGGER RET 10$: MOVL R1,R8 ; set rec addr CMPL R0,#SS$_CREATED ; If created ... BEQL NEW_ENTRY ; ... Do this BRW CHECK_ENTRY ; ... else just check NEW_ENTRY: ; New Entry - Store info and send alert ; SCS Specific Data MOVL R1,R8 ADDL3 R6,#IPC_ETH_1500_DATA,R3 ; Point to SCS frame SUBW3 #256,6(R3),PSR_SCS_W_CLUID(R8) ; Store cluster group code CVTBL 26(R3),R4 ; Get count of name str INCL R4 ; Include count MOVC5 R4,26(R3),#^A/ /,#8,PSR_SCS_AC_NAME(R8) ; Send Alert ; Send name to NAMER BRW DONE ; Final checks and exit CHECK_ENTRY: 20$: MOVQ EXE$GQ_SYSTIME,COM_HDR_Q_LSTHRD(R8) ; Heard this addr now INCL COM_HDR_L_ACNT(R8) ; Count this access ADDL3 R6,#IPC_ETH_1500_DATA,R3 ; Point to SCS frame SUBW3 #256,6(R3),R4 ; Store cluster group code CMPW R4,PSR_SCS_W_CLUID(R8) ; Cluster group code changed? BEQLU 30$ ; No - check next ; Send alert - cluster group no. changed SUBW3 #256,6(R3),PSR_SCS_W_CLUID(R8) ; Store cluster group code 30$: CVTBL 26(R3),R4 ; Get count CLRL R0 ; Loop control ADDL #26,R3 ; Point to incoming name ADDL3 #PSR_SCS_AC_NAME,R8,R2 ; Stored name 40$: CMPB (R3)[R0],(R2)[R0] BNEQU 50$ AOBLEQ R4,R0,40$ BRB 60$ ; Ok 50$: MOVC5 R4,(R3),#^A/ /,#8,PSR_SCS_AC_NAME(R8) ; Force modify name in namer BICL #SYS_FLG_C_NAMER,COM_HDR_L_PTYBITS(R8) 60$: DONE: ; Make sure we are in the Relater DB CLRL RLTCXT ; Start with new frame BBS #THIS_PROCESS,RELDIS,5$ BBS #THIS_PROCESS,COM_HDR_L_PTYBITS(R8),5$ ADDL3 #PSR_SCS_EA_ADDR,R8,-(SP) ; Our addr PUSHL #6 ; Len of our addr PUSHL #THIS_PROCESS ; Add our address PUSHL #THIS_PROCESS ; Identify sender PUSHL #RLT_FRM_C_MSGADD ; Add targets ADDL3 #COM_HDR_L_BOXID,R8,-(SP) ; Boxid PUSHAL RLTCXT ; Context CALLS #7,G^CREATE_RELATER_FRAME BLBS R0,5$ ; Br no err INCL CNT_PSR_L_NOIPC(R11) ; count err BRW 35$ ; Skip 5$: ; Check if decnet frame CMPL HIORD,PSR_SCS_EA_ADDR(R8) BNEQU 20$ ; Br if not decnet 10$: BBS #SYS_PID_C_PSRDN4,RELDIS,20$ BBS #SYS_PID_C_PSRDN4,COM_HDR_L_PTYBITS(R8),20$ ADDL3 #PSR_SCS_EA_ADDR,R8,R1 ; Get decnet addr ADDL #4,R1 ; Offset to decnet PUSHL R1 ; Addr of decnet PUSHL #2 ; Len of decnet addr PUSHL #SYS_PID_C_PSRDN4 ; Add decnet address PUSHL #THIS_PROCESS ; Identify sender PUSHL #RLT_FRM_C_MSGADD ; Add targets ADDL3 #COM_HDR_L_BOXID,R8,-(SP) ; Boxid PUSHAL RLTCXT ; Context CALLS #7,G^CREATE_RELATER_FRAME BLBS R0,20$ ; Br no err INCL CNT_PSR_L_NOIPC(R11) ; count err BRW 35$ ; skip to end ; As this frame came from Ethernet ... 20$: BBS #SYS_PID_C_PSRETH,RELDIS,30$ BBS #SYS_PID_C_PSRETH,COM_HDR_L_PTYBITS(R8),30$ ADDL3 #PSR_SCS_EA_ADDR,R8,-(SP) ; Our addr PUSHL #6 ; Len of Ethernet addr PUSHL #SYS_PID_C_PSRETH ; Add Ethernet address PUSHL #THIS_PROCESS ; Identify sender PUSHL #RLT_FRM_C_MSGADD ; Add targets ADDL3 #COM_HDR_L_BOXID,R8,-(SP) ; Boxid PUSHAL RLTCXT ; Context CALLS #7,G^CREATE_RELATER_FRAME BLBS R0,30$ ; Br no err INCL CNT_PSR_L_NOIPC(R11) ; count err BRW 35$ ; skip to end 30$: ; Check name is in DB BBS #SYS_PID_C_NAMER,RELDIS,200$ BBS #SYS_PID_C_NAMER,COM_HDR_L_PTYBITS(R8),200$ ; Name has not been sent - add to relater frame PUSHL R8 ; Current record CALLS #1,G^SCS_SEND_NAME ; Adds name frame to relater ; any error is corrected in rtn 35$: ; send relater frame. TSTL RLTCXT ; Any frame to send? BEQL 100$ ; Br if not PUSHL RLTCXT ; Context (Addr of buffer) CALLS #1,G^SEND_RELATER_FRAME CLRL RLTCXT ; Saftey - don't reuse BLBS R0,40$ ; br no err INCL CNT_PSR_L_ERROR(R11) ; count err MOVL #MSG_GENPSR_SNDRLT,MSGCDE ; General PSR error MOVL #1,PARCNT ; 2 params MOVAL MSGPARAMS,R1 ; Plist MOVL R0,(R1) ; VMS error PUSHAL ERRORMSG ; Log it CALLS #1,G^EMU_LOGGER BRW 100$ ; skip 40$: INCL CNT_PSR_L_PREL(R11) ; Count relater frame sent 100$: 200$: ; clear our bit in return ; reque this buff back to listen BICL #THIS_PROCESS_FLAG,IPC_HDR_L_RFLAGS(R6) INCL CNT_PSR_L_RET(R11) BRW MAIN ; ; Subroutines ERROR_CHK: .JSB_ENTRY INPUT=, - OUTPUT= BLBC R0,10$ RSB 10$: MOVL R0,R6 MOVL #MSG_GENPSR_SNDNAM,MSGCDE ; General PSR error MOVL #1,PARCNT ; 2 params MOVAL MSGPARAMS,R1 ; Plist MOVL R0,(R1) ; VMS error PUSHAL ERRORMSG ; Log it CALLS #1,G^EMU_LOGGER MOVL R6,R0 $EXIT_S RET .CALL_ENTRY MAX_ARGS=1, - HOME_ARGS=TRUE, - INPUT =, - PRESERVE=, - LABEL=SCS_SEND_NAME ;++ ;2 SCS_SEND_NAME ; Routine to extract the name, format it with keying info and add it ; to (possibly) existing relater frame ; Input ; .address of SCSDB Rec ; Output ; Namer frame is added to relater frame. A namer frame is formatted ; as follows: ; PID .long protocol id of sending process ; KEY2 .long key for multiple names - not used in SCS ; Name .ascii name ; The len is the len of the name +8 ; Return ; None ;-- MOVL 4(AP),R8 ADDL3 #PSR_SCS_AC_NAME,R8,R1 ; .ascic name MOVZBL (R1),R2 ; Get len BEQL 200$ ; Br if len = 0 CMPL #6,R2 ; Max name len? BLSSU 200$ ; Br if invalid INCL R1 ; Point to name MOVL #SCS_NF_LEN,NF_DESC PUSHAL NF_DESC ; Output PUSHL R1 ; Ascii name PUSHL R2 ; Len PUSHL #THIS_PROCESS ; This db PID CALLS #4,G^MAKE_NAMER_FRAME ; BLBC R0,200$ ; Skip on err PUSHAL NAMFRM ; Our addr ADDL3 #8,R2,-(SP) ; Len of our addr PUSHL #SYS_PID_C_NAMER ; Add name PUSHL #THIS_PROCESS ; Identify sender PUSHL #RLT_FRM_C_MSGADD ; Add targets ADDL3 #COM_HDR_L_BOXID,R8,-(SP) ; Boxid PUSHAL RLTCXT ; Context CALLS #7,G^CREATE_RELATER_FRAME BLBS R0,200$ ; Br no err INCL CNT_PSR_L_NOIPC(R11) ; count err 200$: RET .CALL_ENTRY MAX_ARGS=1, - HOME_ARGS=TRUE, - INPUT =, - PRESERVE=, - LABEL=MAP_SCSDB ;++ ;2 MAP_SCSDB ; Routine to create and initialise the SCS db. This is a standard routine ; that any DB creator execxutes on it's own DB: ; Acquire exclusive lock on this database. ; Fatal error if not granted. ; Open file - if file not opened used hardcoded defaults. ; Create section. Fatal error ir we did not CREATE. ; Initalise with either file contents or defaults ; Write section size (in pages) to LVB ; Convert lock to CW ; That's it! ;-- MOVL #LCK$K_EXMODE,LKMODE ; EXCLUSIVE $ENQW_G SCSDBLOCK ; Get DB lock in exclusive mode BLBS SCSLVBSTA,10$ ; Br if got it CMPW #SS$_VALNOTVALID,SCSLVBSTA ; Ignore LVB not valid error BEQLU 10$ MOVL #MSG_EMUSYS_LOCKDB,MSGCDE ; General PSR error MOVL #2,PARCNT ; 2 params MOVAL MSGPARAMS,R1 ; Plist MOVL LKNAM,(R1)+ MOVL R0,(R1) ; VMS error PUSHAL ERRORMSG ; Log it CALLS #1,G^EMU_LOGGER RET 10$: $OPEN FAB= SCSSECFAB ; Attempt to open BLBS R0,20$ ; Br if OK BRW 1000$ ; Use defaults 20$: $CONNECT RAB=SCSSECRAB BLBS R0,30$ BRW 280$ ; Abandon and use defaults 30$: $GET RAB=SCSSECRAB ; Get 1st rec BLBS R0,40$ BRW 280$ ; Abandon and use defaults 40$: ; Calc memory/file size, Get memory & Map section MOVAL SCSSECREC,R7 MULL3 COM_DBHDR_L_MAXENTRIES(R7),COM_DBHDR_L_RECSIZE(R7),GBLSIZ DIVL #512,GBLSIZ ; Pages INCL GBLSIZ ; Round up ; Get Memory 100$: CLRQ -(SP) ; p0 space, access mode PUSHAL INADDR ; returned address PUSHL GBLSIZ ; no. of pages CALLS #4, G^SYS$EXPREG ; Expand process space BSBW ERROR_CHK ; check ok ; MAP SECTION CLRQ -(SP) ; pfc, protection CLRL -(SP) ; virtual block number PUSHL GBLSIZ ; no. of pages CLRQ -(SP) ; channel, rel page no. CLRL -(SP) ; version id PUSHAL SCSSECNAM ; section name PUSHL # CLRL -(SP) ; access mode PUSHAL SCSDB_A ; returned address PUSHAL INADDR ; in address CALLS #12, G^SYS$CRMPSC ; create section BSBW ERROR_CHK CMPL #SS$_CREATED,R0 BEQL 200$ $CLOSE FAB=SCSSECFAB MOVL #SS$_INVEVENT,R0 ; We MUST create the section RET 200$: ; WE CREATED THE SECTION. LOAD IT WITH FILE CONTENTS ; Move the 1st rec to rec header ; 1st rec cannot exceed common header size... MOVAL SCSDB_A,R11 ; Start of section MOVL (R11),R7 ; MOVC3 #COM_HDR_C_SIZE,SCSSECREC,(R7) ; Init header ADDL3 COM_DBHDR_L_RECSIZE(R7),R7,R8 ; Location of 1st rec CLRL COM_DBHDR_L_ENTRIES(R7) ; No entries yet MOVL COM_DBHDR_L_RECSIZE(R7),R9 ; rec size 210$: MOVL R8,SCSSECRAB+RAB$L_UBF ; Write rec here MOVW R9,SCSSECRAB+RAB$W_RSZ ; Record size MOVW R9,SCSSECRAB+RAB$W_USZ ; Record size $GET RAB = SCSSECRAB ; Get a record BLBC R0,260$ ; BR IF error INCL COM_DBHDR_L_ENTRIES(R7) ; Count ADDL R9,R8 ; Next slot ADDL3 R9,R8,R10 ; Check if enough room CMPL R10,4(R11) ; OK? BLEQU 210$ ; OK BRW 280$ ; Undo 260$: CMPL R0,#RMS$_EOF ; Was error end of file BEQLU 270$ ; Yes - OK RET ; No - Die 270$: $CLOSE FAB=SCSSECFAB BRW 2000$ 280$: ; Undo and set to default $CLOSE FAB=SCSSECFAB CLRQ -(SP) PUSHL 4(AP) CALLS #3,G^SYS$DELTVA 1000$: ; File was not found, or otherwise unloadable ; Use defaults MULL3 #PSR_SCS_C_RECSIZ,DEFRECCNT,GBLSIZ DIVL #512,GBLSIZ ; Pages INCL GBLSIZ ; Round up ; Get Memory CLRQ -(SP) ; p0 space, access mode PUSHAL INADDR ; returned address PUSHL GBLSIZ ; no. of pages CALLS #4, G^SYS$EXPREG ; Expand process space BSBW ERROR_CHK ; check ok ; MAP SECTION CLRQ -(SP) ; pfc, protection CLRL -(SP) ; virtual block number PUSHL GBLSIZ ; no. of pages CLRQ -(SP) ; channel, rel page no. CLRL -(SP) ; version id PUSHAL SCSSECNAM ; section name PUSHL # CLRL -(SP) ; access mode PUSHAL SCSDB_A ; returned address PUSHAL INADDR ; in address CALLS #12, G^SYS$CRMPSC ; create section CMPL #SS$_CREATED,R0 BEQL 1100$ $CLOSE FAB=SCSSECFAB MOVL #SS$_INVEVENT,R0 ; We MUST create the section RET ; init header rec 1100$: MOVL SCSDB_A,R6 MOVL #PSR_SCS_C_RECSIZ,COM_DBHDR_L_RECSIZE(R6) ; write recsize MOVL #THIS_PROCESS,COM_DBHDR_L_FLAG(R6) ; Write flag MOVL DEFRECCNT,COM_DBHDR_L_MAXENTRIES(R6) 2000$: $ERASE FAB= SCSSECFAB ; Delete all versions BLBS R0,2000$ ; Br until no more SUBL3 SCSDB_A,SCSDB_A+4,R10 ; Size if section (bytes) DIVL3 #512,R10,SCSLVBSIZ ; Size (Pages) in LVB INCL SCSLVBSIZ ; Real number BISL #LCK$M_CONVERT,LKFLGS ; Set lock to convert MOVL #LCK$K_CWMODE,LKMODE ; COnvert to CW $ENQW_G SCSDBLOCK ; Convert DB lock MOVW SCSLVBSTA,R0 RET ; Return with any errors .CALL_ENTRY MAX_ARGS=0, - HOME_ARGS=TRUE, - INPUT =, - PRESERVE=, - LABEL=PSRSCS_EXIT ; Here at exit ; Disable ourselves MOVL PSRTBL_A,R6 ; MOVL PSRTBLCNT,R3 ; Count of entries 10$: CMPL #THIS_PROCESS_FLAG,PSR_TBL_L_PSRID(R6) BNEQU 15$ BICL #PSR_CFLG_M_DISAB,PSR_TBL_L_CFLGS(R6) ; Disable 15$: ADDL #PSR_TBL_C_SIZE,R6 ; Next entry SOBGTR R3,10$ ; Loop for all ; Get lock MOVL #LCK$K_EXMODE,LKMODE ; EXCLUSIVE BISL #LCK$M_CONVERT,LKFLGS ; Set lock to convert $ENQW_G SCSDBLOCK ; Get DB lock in exclusive mode BLBS SCSLVBSTA,20$ CMPW #SS$_VALNOTVALID,SCSLVBSTA ; Ignore LVB not valid error BEQLU 20$ MOVL #MSG_EMUSYS_LOCKDB,MSGCDE ; General PSR error MOVL #2,PARCNT ; 2 params MOVAL MSGPARAMS,R1 ; Plist MOVL LKNAM,(R1)+ MOVL R0,(R1) ; VMS error PUSHAL ERRORMSG ; Log it CALLS #1,G^EMU_LOGGER 20$: ; create new file $CREATE FAB=SCSSECFAB BLBS R0,30$ MOVL #SS$_RESIGNAL,R0 RET 30$: $CONNECT RAB=SCSSECRAB BLBS R0,40$ MOVL #SS$_RESIGNAL,R0 RET 40$: ; analyse section, dec entry count for any deleted recs MOVL SCSDB_A,R10 ; Top of section MOVL COM_DBHDR_L_ENTRIES(R10),R6 ; Number of entries BEQL 65$ ; Br if none MOVL COM_DBHDR_L_RECSIZE(R10),R7 ; Size of entries ADDL3 R7,R10,R8 ; 1st rec 50$: BBC #SYS_COM_V_DELETE,COM_HDR_L_SYSCTL(R8),60$ ; Br if not deleted DECL COM_DBHDR_L_ENTRIES(R10) ; uncount 60$: ADDL R7,R8 SOBGTR R6,50$ ; The count is now the count of valid recs ; Calc a new MAXENTRY 65$: MULL3 #100,COM_DBHDR_L_ENTRIES(R10),R1 DIVL #15,R1 ; increase by 15 % CMPL #10,R1 ; must be > 10 BLSS 70$ MOVL #10,R1 ; Set min BRB 100$ 70$: ; CMPL #100,R1 ; must be < 100 ; BGTR 100$ ; MOVL #100,R1 ; Set min 100$: ; Set header and write it ; MOVW COM_DBHDR_L_RECSIZE(R10),SCSSECRAB+RAB$W_RSZ ; rec size ADDL3 R1,COM_DBHDR_L_ENTRIES(R10),COM_DBHDR_L_MAXENTRIES(R10) ; Set new max size MOVL #-1,COM_HDR_L_ACNT(R10) ; Set this field Max count (FOR SORT) MOVL R10,SCSSECRAB+RAB$L_RBF ; Write this rec $PUT RAB = SCSSECRAB ; Write a record BLBS R0,110$ ; BR IF no error BRW 210$ 110$: ; Write out all recs (skip deletes) MOVL COM_DBHDR_L_ENTRIES(R10),R6 ; Number of entries BEQL 200$ ; Br if none MOVL COM_DBHDR_L_RECSIZE(R10),R7 ; Size of entries MOVW COM_DBHDR_L_RECSIZE(R10),SCSSECRAB+RAB$W_RSZ ; Size of record ADDL3 R7,R10,R8 ; 1st rec 120$: MOVL R8,SCSSECRAB+RAB$L_RBF ; Write this rec $PUT RAB = SCSSECRAB ; Write a record BLBC R0,210$ ; BR IF error ADDL R7,R8 SOBGTR R6,120$ 200$: $CLOSE FAB= SCSSECFAB ; MOVL #SS$_RESIGNAL,R0 RET 210$: $CLOSE FAB= SCSSECFAB ; $ERASE FAB= SCSSECFAB ; Delete Partial MOVL #SS$_RESIGNAL,R0 RET .END PSRSCS