TITLE 'Retrieve File Information From File Object'; /*==================================================================*/ /* */ /* Program : FILEINFO */ /* */ /* Author : Robert McDowell */ /* */ /* Narrative : This module retrieves a datafile's characteristics*/ /* keys and fields */ /* */ /* Parameters : 1) Fields */ /* File/Library Char(20) */ /* File Text Char(50) */ /* Return Code Char(1) */ /* Number Of Fields Bin(2) */ /* Record Length Bin(2) */ /* Format Name Char(10) */ /* Format Level Char(13) */ /* Field Array Char(68) Occurs x Times */ /* - Name Char(10) */ /* - Text Char(50) */ /* - Type Bin(2) */ /* - Storage Length Bin(2) */ /* - Field Size Bin(2) */ /* - Decimal Positions Bin(2) */ /* 2) Number Of Keys Bin(2) */ /* File Keys Char(10) Occurs x Times */ /* */ /*==================================================================*/ ENTRY * (PLIST) EXT; /*------------------------------------------------------------------*/ /* Parameter Declarations */ /*------------------------------------------------------------------*/ DCL SPCPTR STRUCT@ PARM; DCL SPCPTR KEYS@ PARM; /*------------------------------------------------------------------*/ /* Parameter Operand List */ /*------------------------------------------------------------------*/ DCL OL PLIST (STRUCT@, KEYS@) PARM EXT MIN(2); /*------------------------------------------------------------------*/ /* Parameter Redefinitions */ /*------------------------------------------------------------------*/ DCL SPC STRUCT BAS(STRUCT@); DCL DD FILE_NAME CHAR(10) DEF(STRUCT) POS(1); DCL DD FILE_LIB CHAR(10) DEF(STRUCT) POS(11); DCL DD FILE_DESC CHAR(50) DEF(STRUCT) POS(21); DCL DD RET_CODE CHAR(1) DEF(STRUCT) POS(71); DCL DD NBR_FLDS BIN(2) DEF(STRUCT) POS(72); DCL DD REC_LENGTH BIN(2) DEF(STRUCT) POS(74); DCL DD FILE_FMT CHAR(10) DEF(STRUCT) POS(76); DCL DD FILE_LEVEL CHAR(13) DEF(STRUCT) POS(86); DCL DD FLD(8192) CHAR(68) DEF(STRUCT) POS(99); DCL SPC KEYS BAS(KEYS@); DCL DD NBR_KEYS BIN(2) DEF(KEYS) POS(1); DCL DD KEY(8192) CHAR(10) DEF(KEYS) POS(3); /*------------------------------------------------------------------*/ /* Resolve System Pointer Template */ /*------------------------------------------------------------------*/ DCL DD SYSPTR_TEMPLATE CHAR(34) BDRY(16); DCL DD SYSPTR_TYPE CHAR(2) DEF(SYSPTR_TEMPLATE) POS(1); DCL DD SYSPTR_NAME CHAR(30) DEF(SYSPTR_TEMPLATE) POS(3); DCL DD SYSPTR_AUTH CHAR(2) DEF(SYSPTR_TEMPLATE) POS(33); /*------------------------------------------------------------------*/ /* Working Storage Section <== COBOL LIVES !!! */ /*------------------------------------------------------------------*/ DCL CON *CTX BIN(2) INIT(X'0401'); DCL CON *FILE BIN(2) INIT(X'1901'); DCL CON *READ BIN(2) INIT(X'0000'); /*------------------------------------------------------------------*/ /* System Pointers */ /*------------------------------------------------------------------*/ DCL SYSPTR LIB@; DCL SYSPTR FILE@; /*------------------------------------------------------------------*/ /* Format Pointer Declarations */ /*------------------------------------------------------------------*/ DCL SPCPTR WFMT@; DCL SPC WRKFMT BAS(WFMT@); DCL SYSPTR THE_FMT@ DEF(WRKFMT) POS(1); /*------------------------------------------------------------------*/ /* Format Workspace */ /*------------------------------------------------------------------*/ DCL SPCPTR FMT@; DCL SPC FMT_OBJ BAS(FMT@); DCL DD * CHAR(52) DIR; DCL DD FMT_NAME CHAR(10) DIR; DCL DD FMT_LEVEL CHAR(13) DIR; DCL DD FMT_TEXT CHAR(50) DIR; DCL DD FMT_FIELDS BIN(2) DIR; /*------------------------------------------------------------------*/ /* Field Workspace */ /*------------------------------------------------------------------*/ DCL SPCPTR FLD@; DCL SPC FLD_OBJ BAS(FLD@); DCL DD FLD_TOTLEN BIN(2) DIR; DCL DD FLD_EXTNAME CHAR(10) DIR; DCL DD FLD_INTNAME CHAR(10) DIR; DCL DD FLD_TYPE BIN(2) DIR; DCL DD FLD_USAGE CHAR(1) DIR; DCL DD FLD_INPOFF BIN(2) DIR; DCL DD FLD_OUTOFF BIN(2) DIR; DCL DD FLD_DDSLEN BIN(2) DIR; DCL DD FLD_LENGTH BIN(2) DIR; DCL DD FLD_DECPOS BIN(2) DIR; DCL DD * CHAR(18) DIR; DCL DD FLD_EXTATTR BIN(2) DIR; DCL DD FLD_TEXTLEN BIN(2) DIR; DCL DD FLD_TEXTOFF BIN(2) DIR; DCL DD FLD_REFLEN BIN(2) DIR; DCL DD FLD_REFOFF BIN(2) DIR; DCL DD FLD_EDITLEN BIN(2) DIR; DCL DD FLD_EDITOFF BIN(2) DIR; DCL DD FLD_COLLEN BIN(2) DIR; DCL DD FLD_COLOFF BIN(2) DIR; DCL DD FLD_VALLEN BIN(2) DIR; DCL DD FLD_VALOFF BIN(2) DIR; /*------------------------------------------------------------------*/ /* Field Text Workspace */ /*------------------------------------------------------------------*/ DCL SPCPTR TXT@; DCL SPC TXT_OBJ BAS(TXT@); DCL DD TEXT CHAR(50) DEF(TXT_OBJ) POS(1); /*------------------------------------------------------------------*/ /* File Object Workspace */ /*------------------------------------------------------------------*/ DCL SPCPTR WSPC@; DCL SPC FILE_OBJ BAS(WSPC@); DCL DD * CHAR(61) DIR; DCL DD FILE_LVL CHAR(13) DIR; DCL DD * CHAR(2) DIR; DCL DD FILE_TEXT CHAR(50) DIR; DCL DD * CHAR(194) DIR; DCL DD FILE_RECL BIN(2) DIR; DCL DD * CHAR(8) DIR; DCL DD FILE_KEYS BIN(2) DIR; DCL DD FMT_OFFSET BIN(4) DIR; DCL DD * BIN(4) DIR; DCL DD KEY_OFFSET BIN(4) DIR; /*------------------------------------------------------------------*/ /* Field Entry Workspace */ /*------------------------------------------------------------------*/ DCL DD WFLD CHAR(68) BDRY(16); DCL DD WFLD_NAME CHAR(10) DEF(WFLD) POS(1); DCL DD WFLD_TEXT CHAR(50) DEF(WFLD) POS(11); DCL DD WFLD_TYPE BIN(2) DEF(WFLD) POS(61); DCL DD WFLD_LENGTH BIN(2) DEF(WFLD) POS(63); DCL DD WFLD_FLDSIZE BIN(2) DEF(WFLD) POS(65); DCL DD WFLD_DECPOS BIN(2) DEF(WFLD) POS(67); /*------------------------------------------------------------------*/ /* Keys Workspace */ /*------------------------------------------------------------------*/ DCL SPCPTR WKEYS@; DCL DD KEY_OBJ BAS(WKEYS@); DCL DD FLD_KEYS(80) CHAR(16) DIR; /*------------------------------------------------------------------*/ /* Miscellaneous Variables */ /*------------------------------------------------------------------*/ DCL DD OFFSET BIN(4) AUTO; DCL DD BEGIN_FLDS BIN(4) INIT(127); DCL DD LOOP_MAX BIN(4) AUTO; DCL DD IX BIN(4) AUTO; /********************************************************************/ /* Exception Monitors */ /********************************************************************/ DCL EXCM * IMD BP(ERROR) CV('CPF') EXCID(H'0000'); DCL EXCM * IMD BP(ERROR) CV('MCH') EXCID(H'0000'); /*==================================================================*/ /* Library Specified? */ /*==================================================================*/ BRK 'CHK_LIB'; CMPBLA(B) FILE_LIB,'*LIBL '/EQ(USE_LIBL); CMPBLA(B) FILE_LIB,' '/EQ(USE_LIBL); /*==================================================================*/ /* Resolve Library Pointer */ /*==================================================================*/ BRK 'GET_LIB'; CPYBLA SYSPTR_TYPE,*CTX; /* Set Library Type */ CPYBLAP SYSPTR_NAME,FILE_LIB,' '; /* Copy Name To Template */ CPYBLA SYSPTR_AUTH,*READ; /* Read Only Access */ RSLVSP LIB@,SYSPTR_TEMPLATE,*,*; /* Resolve Context Pointer */ /*==================================================================*/ /* Resolve File Pointer Using Library Pointer */ /*==================================================================*/ BRK 'GET_FILE'; CPYBLA SYSPTR_TYPE,*FILE; /* Set File Type */ CPYBLAP SYSPTR_NAME,FILE_NAME,' '; /* Copy Name To Template */ CPYBLA SYSPTR_AUTH,*READ; /* Read Only Access */ RSLVSP FILE@,SYSPTR_TEMPLATE,LIB@,*; B GET_ADDR; /*==================================================================*/ /* Resolve File Pointer Using *LIBL */ /*==================================================================*/ BRK 'USE_LIBL'; USE_LIBL: CPYBLA SYSPTR_TYPE,*FILE; /* Set File Type */ CPYBLAP SYSPTR_NAME,FILE_NAME,' '; /* Copy Name To Template */ CPYBLA SYSPTR_AUTH,*READ; /* Read Only Access */ RSLVSP FILE@,SYSPTR_TEMPLATE,*,*; /* Resolve File Obj */ /*==================================================================*/ /* Resolve Object Addressability */ /*==================================================================*/ BRK 'GET_ADDR'; GET_ADDR: SETSPPFP WSPC@,FILE@; /* Convert SYSPTR To SPCPTR */ ADDN OFFSET,32,FMT_OFFSET; /* Format Offset + X'20' ?? */ ADDSPP WFMT@,WSPC@,OFFSET; /* Calc Beg Of Format Ptrs */ SETSPPFP FMT@,THE_FMT@; /* Convert SYSPTR To SPCPTR */ /*==================================================================*/ /* Return File Level Attributes */ /*==================================================================*/ BRK 'FORMAT'; DO_FORMAT: ADDSPP FLD@,FMT@,BEGIN_FLDS; /* Calc First Field Offset */ CPYNV LOOP_MAX,1; /* Initialize Field Counter */ CPYBLA FILE_DESC,FILE_TEXT; /* Return File Text */ CPYBLA FILE_FMT,FMT_NAME; /* Return Format Name */ CPYBLA FILE_LEVEL,FMT_LEVEL; /* Return File Level Desc */ CPYNV REC_LENGTH,FILE_RECL; /* Return Record Length */ CPYNV NBR_FLDS,FMT_FIELDS; /* Return Number Of Fields */ CPYNV NBR_KEYS,FILE_KEYS; /* Return Number Of Keys */ /*==================================================================*/ /* Field Main Loop */ /*==================================================================*/ BRK 'FLDLOOP'; FLD_LOOP: CMPNV(B) LOOP_MAX,FMT_FIELDS/HI(END_LOOP); CPYBLA WFLD_NAME,FLD_EXTNAME; /* Return Field Name */ CPYNV WFLD_TYPE,FLD_TYPE; /* Return Field Type (Binary)*/ CPYNV WFLD_LENGTH,FLD_LENGTH; /* Return Physical Length */ CPYNV WFLD_FLDSIZE,FLD_DDSLEN; /* Return Display Length */ CPYNV WFLD_DECPOS,FLD_DECPOS; /* Return Decimal Places */ CPYBREP WFLD_TEXT,' '; /* Initialize Text */ CMPNV(B) FLD_TEXTLEN,0/EQ(FLD_NEXT); ADDSPP TXT@,FLD@,FLD_TEXTOFF; /* Calc Text Offset To Ptr */ CPYBLA WFLD_TEXT(1:FLD_TEXTLEN), TEXT; /*==================================================================*/ /* Increment For Next Field */ /*==================================================================*/ BRK 'FLDNEXT'; FLD_NEXT: CPYBLA FLD(LOOP_MAX),WFLD; /* Return Work Structure */ ADDN(S) LOOP_MAX,1; /* Bump Index */ ADDSPP FLD@,FLD@,FLD_TOTLEN; /* Point To Next Field */ B FLD_LOOP; /*==================================================================*/ /* Field Key Fields If Any */ /*==================================================================*/ BRK 'ENDLOOP'; END_LOOP: CPYNV NBR_KEYS,FILE_KEYS; /* Return File Keys */ CMPNV(B) FILE_KEYS,0/EQ(CALL_OK); /* Any Keys .. No, Exit */ CPYNV IX,1; /* Reset Index */ ADDSPP WKEYS@,WSPC@,KEY_OFFSET; /* Address Keys From Object */ BRK 'KEYLOOP'; KEY_LOOP: CMPNV(B) IX,FILE_KEYS/HI(CALL_OK); /* At End?? */ CPYBLA KEY(IX),FLD_KEYS(IX); /* Return Key Field Name */ ADDN(S) IX,1; /* Bump Index */ B KEY_LOOP; /* Get Some More */ /*==================================================================*/ /* Return To Caller */ /*==================================================================*/ CALL_OK: CPYBLA RET_CODE,'0'; /* This Tuna Smells Good */ BRK 'EXIT_PGM'; EXIT_PGM: RTX *; /*==================================================================*/ /* Exception Handler */ /*==================================================================*/ BRK 'EXCEPT'; ERROR: CPYBLA RET_CODE,'1'; /* This Tuna Smells BAD!! */ B EXIT_PGM; /*'/*'/*"/*"*/; PEND;