DELETE ADD_DTR_FUNCTION; REDEFINE PROCEDURE ADD_DTR_FUNCTION ! ! This procedure is used to update the DTR_FUNCTIONS.DAT data file which ! all the necessary data to construct the DTRFUN.MAR file needed to add ! User Defined Functions (UDF's) to Datatrieve. ! ! NOTE: The domains DTR_FUNCTION_INFO and DTR_FUNCTION_INPUTS must be ! readed for WRITE access before invoking this procedure. ! ! Donald E. Stern, Jr. - October 24, 1986 ! !Create variables to contain data passed back from FMS ! DECLARE FNAME PIC X(31). DECLARE NARG BYTE. DECLARE ARGNM BYTE. DECLARE ARGORDER BYTE. ! ARGNM=0 ! FN$CREATE_LOG("SCHICK$DTR", "DISK:[DTRSIG.FUNCTIONS]") !Shorthand ! BEGIN STORE DTR_FUNCTION_INFO USING DISPLAY_FORM DTR_FUNCTION_ADD IN SCHICK$DTR:DTR_FUNCTIONS RETRIEVE USING BEGIN FNAME = GET_FORM NAME DTR_FUNCTION_NAME = FNAME FUNCTION_DESCRIPTION = GET_FORM FUN_DESC EXT_FUNCTION_NAME = GET_FORM EXTERNAL OUT_ARG_TYPE = GET_FORM OUT_TYPE OUT_ARG_DTYPE = GET_FORM OUT_DTYPE OUT_ARG_DESCRIPTION = GET_FORM OUT_DESC EDIT_STR = GET_FORM EDT_STR QUERY_HDR = GET_FORM QRY_HDR NOVALUE = GET_FORM NOVAL NO_OPTIMIZE = GET_FORM NOOPT NARG = GET_FORM NARGS IN_COUNT = NARG END ARGORDER = 0 REPEAT NARG BEGIN ARGORDER = ARGORDER + 1 ARGNM = ARGNM + 1 STORE DTR_FUNCTION_INPUTS USING DISPLAY_FORM DTR_FUNCTION_ADD_INARGS IN SCHICK$DTR:DTR_FUNCTIONS USING BEGIN PUT_FORM NAME = FNAME PUT_FORM ARGNUM = ARGNM END RETRIEVE USING BEGIN DTR_FUNCTION_NAME = FNAME IN_ARG_TYPE = GET_FORM IN_TYPE IN_ARG_DESCRIPTION = GET_FORM IN_DESC IN_ARG_DTYPE = GET_FORM IN_DTYPE ORDER = GET_FORM ARG_ORDER OUT_PUT = GET_FORM OUTPUT ALL_LEN = GET_FORM ALLLEN FUNCTION_ARG_ORDER = ARGORDER END END END END-PROCEDURE DELETE ADD_DTR_FUNCTIONS; REDEFINE PROCEDURE ADD_DTR_FUNCTIONS READY DTR_FUNCTION_INFO SHARED WRITE READY DTR_FUNCTION_INPUTS SHARED WRITE DECLARE MORE PIC X. FN$CREATE_LOG("SCHICK$DTR","DISK:[DTRSIG.FUNCTIONS]") MORE = "Y" WHILE MORE="Y" BEGIN :ADD_DTR_FUNCTION MORE=FN$UPCASE(*.MORE) END END-PROCEDURE DELETE BUCKETS; REDEFINE PROCEDURE BUCKETS ! !=================================================================+ ! + ! This procedure calculates the number of index buckets + ! in an RMS indexed file containing TEXED length records + ! and then specifies a GLOBAL BUFFER count. + !=================================================================+ ! DECLARE MORE PIC X VALID IF MORE = "Y","N","y","n". DECLARE PRIMARY_DONE PIC X VALID IF PRIMARY_DONE = "Y","N","y","n". DECLARE KEY_PROMPT PIC X VALID IF KEY_PROMPT = "P","A","p","a". DECLARE BUCKET_SIZE PIC 9(2) VALID IF BUCKET_SIZE BETWEEN 1 AND 32. DECLARE KEY_SIZE PIC 9(3) VALID IF KEY_SIZE BETWEEN 1 AND 125. DECLARE REC_SIZE PIC 9(4). DECLARE NUM_RECS PIC 9(6). DECLARE REC_OVHD PIC 9(2). DECLARE KEY_OVHD PIC 9(1). DECLARE NUM_DUPS PIC 9(3). DECLARE FILL_FACTOR PIC 9(3)V99. DECLARE TMP_DRPB PIC 9(5)V99. DECLARE DRPB PIC 9(5). DECLARE NUM_DB PIC 9(5). DECLARE NUM_IB PIC 9(5). DECLARE TMP_NUM_DB PIC 9(5)V99. DECLARE TMP_NUM_IB PIC 9(5)V99. DECLARE PREV_NUM_BUCK PIC 9(5). DECLARE IRPB PIC 9(5). DECLARE TOT_IDB PIC 9(5) EDIT_STRING IS ZZZZ9. DECLARE GRAND_NUM_IDB PIC 9(5) EDIT_STRING IS ZZZZ9. DECLARE ICOUNT PIC 9. !======================================================== KEY_OVHD = 3 MORE = "Y" GRAND_NUM_IDB = 0 NUM_RECS = 0 PRIMARY_DONE = "N" PRINT " " PRINT "************************************************************" PRINT "* *" PRINT "* This procedure calculates the number of index buckets *" PRINT "* in an RMS indexed file containing FIXED length records *" PRINT "* and then specifies a GLOBAL BUFFER count. *" PRINT "************************************************************" WHILE MORE EQ "Y" BEGIN TOT_IDB = 0 PRINT " " CHOICE (PRIMARY_DONE EQ "N") THEN BEGIN KEY_PROMPT = *."Primary or Alternate key structure (P or A) " KEY_PROMPT = FN$UPCASE(KEY_PROMPT) END ELSE KEY_PROMPT = "A" END_CHOICE CHOICE (KEY_PROMPT EQ "P") THEN BEGIN PRIMARY_DONE = "Y" BUCKET_SIZE = *."bucket size of the primary key sturcture (0-32) " REC_SIZE = *."record size in bytes (1-9999) " KEY_SIZE = *."size of the primary key in bytes (1-125) " NUM_RECS = *."number of records in the file (0 - 999,999) " FILL_FACTOR = *."fill factor of the primary key structure (0-100) " FILL_FACTOR = FILL_FACTOR / 100.0 REC_OVHD = 7 END ELSE BEGIN BUCKET_SIZE = *."bucket size of the alternate key struc.(0-32) " KEY_SIZE = *."size of the alternate key in bytes (1-125) " REC_SIZE = KEY_SIZE CHOICE (NUM_RECS EQ 0) THEN NUM_RECS = *."number of records in the file (0 - 999,999) " END_CHOICE FILL_FACTOR = *."the fill factor of the alternate key (0 - 100) " FILL_FACTOR = FILL_FACTOR / 100.0 NUM_DUPS = *."the number of dup keys in the alternate key (0 - 100) " CHOICE (NUM_DUPS EQ 0) THEN REC_OVHD = 9 ELSE REC_OVHD = (8 + (5 * NUM_DUPS)) END_CHOICE END END_CHOICE ! !Find the floor number of data records per bucket. ! TMP_DRPB = (((BUCKET_SIZE * 512) * FILL_FACTOR) - 15) / (REC_SIZE + REC_OVHD) DRPB = TMP_DRPB ! ! Find ceiling number of data buckets. ! TMP_NUM_DB = (NUM_RECS / DRPB) + 0.49 NUM_DB = TMP_NUM_DB ! IRPB = (((BUCKET_SIZE * 512) * FILL_FACTOR) - 15) / (KEY_SIZE + KEY_OVHD) PREV_NUM_BUCK = NUM_DB NUM_IB = 0 ICOUNT = 0 WHILE (NUM_IB NE 1) BEGIN ICOUNT = ICOUNT + 1 ! ! Find ceiling number of index buckets. ! TMP_NUM_IB = (PREV_NUM_BUCK / IRPB) + 0.49 NUM_IB = TMP_NUM_IB CHOICE (NUM_IB GT 1) THEN BEGIN TOT_IDB = TOT_IDB + NUM_IB PREV_NUM_BUCK = NUM_IB END END_CHOICE END TOT_IDB = TOT_IDB +1 PRINT " " PRINT "=============================================================" PRINT " " CHOICE (KEY_PROMPT EQ "P") THEN PRINT "NUMBER OF TOTAL INDEX BUCKETS FOR PRIMARY KEY STRUCTURE ==> ", TOT_IDB(-) ELSE PRINT "NUMBER OF TOTAL INDEX BUCKETS FOR ALTERNATE KEY STRUCTURE ==> ", TOT_IDB(-) END_CHOICE PRINT " " PRINT "=============================================================" PRINT " " ! MORE = *. "Y to calculate more index structures, N to exit" MORE = FN$UPCASE(MORE) GRAND_NUM_IDB = GRAND_NUM_IDB + TOT_IDB END; PRINT " " PRINT "*************************************************************" PRINT " " PRINT "NUMBER OF TOTAL INDEX BUCKETS FOR KEY STRUCTURES ==> ", GRAND_NUM_IDB(-) PRINT " " ! !Add 5 to the number of index buckets ! GRAND_NUM_IDB = GRAND_NUM_IDB + 5 PRINT "Set the GLOBAL BUFFER attribute on the file to ", GRAND_NUM_IDB(-) PRINT " " PRINT "*************************************************************" PRINT " " END-PROCEDURE DELETE MAKE_COMMAND_FILE; REDEFINE PROCEDURE MAKE_COMMAND_FILE ON CHECK.COM BEGIN PRINT "$MAC/LIS DTRFND" PRINT "$COPY DTRFND.MAR, DTRFND.LIS, DTRFND.OBJ -" PRINT " DISK:[DTRSIG.FUNCTIONS]*/LOG" PRINT "$LIBR/LOG/REP DISK:[DTRSIG.FUNCTIONS]DTRFUN -" PRINT " DISK:[DTRSIG.FUNCTIONS]DTRFND" END END-PROCEDURE DELETE MAKE_DTRFND; REDEFINE PROCEDURE MAKE_DTRFND READY DTR_FUNCTIONS SHARED SET COLUMNS_PAGE = 132 ON DTRFND.MAR BEGIN PRINT ".TITLE DTRFND VAX-11 Datatrieve Function Definitions", SKIP, ";+++++++++++++++++++++++++++++++++++++++++++++++++++", SKIP, ";", SKIP, "; F U N C T I O N D E F I N I T I O N S", SKIP, ";", SKIP, ";---------------------------------------------------", SKIP 2, ".PSECT FND,NOWRT,SHR,PIC,2", SKIP 1, ".LIBRARY /DTR$LIBRARY:DTRFNLB/", SKIP 1, ".LIBRARY /SYS$LIBRARY:STARLET/", SKIP 1, ";.SHOW EXPANSIONS", SKIP 1, "$DSCDEF", SKIP 1, "$DTR$FUN_INIT", SKIP 4 ! ! Print all of the functions ! FOR DTR_FUNCTIONS :PRINT_FUNCTION ! ! Print the trailer ! PRINT "$DTR$FUN_FINI", SKIP 2, ".END" END; END-PROCEDURE DELETE MAKE_FUNCTION_HELP; REDEFINE PROCEDURE MAKE_FUNCTION_HELP ! ! Print help text for a single function ! READY DTR_FUNCTIONS SHARED ON WL_FUNCTIONS.HLP FOR DTR_FUNCTIONS WITH DTR_FUNCTION_NAME STARTING "WL" BEGIN ! Print the comments about the function PRINT "2 "|DTR_FUNCTION_NAME, SKIP 2, FUNCTION_DESCRIPTION (-),SKIP 2, OUT_ARG_DESCRIPTION (-), SKIP 2,"Arguments:", SKIP 1, ALL " "|IN_ARG_DESCRIPTION (-), SKIP OF IN_ARGS, SKIP END END-PROCEDURE DELETE PRINT_FUNCTION; REDEFINE PROCEDURE PRINT_FUNCTION ! ! Print a single function definition ! BEGIN ! Print the comments about the function PRINT "; "|DTR_FUNCTION_NAME|||"- "|FUNCTION_DESCRIPTION, SKIP, ";", SKIP, "; "|OUT_ARG_DESCRIPTION, SKIP, ALL "; "|IN_ARG_DESCRIPTION, SKIP OF IN_ARGS, SKIP ! The opening line PRINT "$DTR$FUN_DEF"|||DTR_FUNCTION_NAME|| ", "|EXT_FUNCTION_NAME||", "|IN_COUNT ! The output argument PRINT " $DTR$FUN_OUT_ARG TYPE = "|OUT_ARG_TYPE VIA FUN_TYPE_TABLE|| IF (OUT_ARG_TYPE EQ "STATUS","INPUT") THEN " " ELSE ", DTYPE = DSC$K_DTYPE_"|OUT_ARG_DTYPE VIA DTYPE_VALUE_TO_NAME ! If the function is a novalue function, say so. IF (NOVALUE EQ "Y") THEN PRINT " $DTR$FUN_NOVALUE" ! If the function is a nooptimize function, say so IF (NO_OPTIMIZE EQ "Y") THEN PRINT " $DTR$FUN_NOOPTIMIZE" ! Do the edit-string and query-header IF (EDIT_STR NOT MISSING) THEN PRINT " $DTR$FUN_EDIT_STRING ^\"||EDIT_STR||"\" IF (HDR NOT MISSING) THEN PRINT " $DTR$FUN_HEADER HDR = <"||HDR||">" ! OK, now for the input arguments FOR A IN IN_ARGS CHOICE (IN_ARG_TYPE = "TEXT") THEN PRINT " $DTR$FUN_IN_ARG TYPE ="||| (IN_ARG_TYPE VIA FUN_TYPE_TABLE)|| (IF (ALL_LEN EQ 0) THEN " " ELSE ",ALL_LEN = "|ALL_LEN)| (CHOICE (ORDER NE 0) THEN ", ORDER = "|ORDER (OUT_PUT EQ "Y") THEN ", OUT_PUT = TRUE" ELSE ";;; illegal OUTPUT or ORDER" END_CHOICE) (IN_ARG_TYPE = "VALUE") THEN PRINT " $DTR$FUN_IN_ARG TYPE ="||| (IN_ARG_TYPE VIA FUN_TYPE_TABLE)|| ", DTYPE = DSC$K_DTYPE_"| IN_ARG_DTYPE VIA DTYPE_VALUE_TO_NAME|| ", ORDER = "|ORDER (IN_ARG_TYPE = "NULL") THEN PRINT " $DTR$FUN_IN_ARG TYPE ="||| (IN_ARG_TYPE VIA FUN_TYPE_TABLE) (IN_ARG_TYPE = "REF", "DESC") THEN PRINT " $DTR$FUN_IN_ARG TYPE ="||| (IN_ARG_TYPE VIA FUN_TYPE_TABLE)|| ", DTYPE = DSC$K_DTYPE_"| IN_ARG_DTYPE VIA DTYPE_VALUE_TO_NAME|| (CHOICE (ORDER NE 0) THEN ", ORDER = "|ORDER (OUT_PUT EQ "Y") THEN ", OUT_PUT = TRUE" ELSE ";;; Illegal OUTPUT or ORDER" END_CHOICE) ELSE PRINT ";;; Illegal input type" END_CHOICE PRINT "$DTR$FUN_END_DEF", SKIP END END-PROCEDURE DELETE PRINT_FUNCTION_HELP; REDEFINE PROCEDURE PRINT_FUNCTION_HELP ! ! Print help text for a single function ! READY DTR_FUNCTIONS SHARED FOR DTR_FUNCTIONS WITH DTR_FUNCTION_NAME STARTING "WL" BEGIN ! Print the comments about the function PRINT "2 "|DTR_FUNCTION_NAME, SKIP 2, FUNCTION_DESCRIPTION (-),SKIP, OUT_ARG_DESCRIPTION (-), SKIP 2,"Arguments:", SKIP 1, ALL IN_ARG_DESCRIPTION (-), SKIP OF IN_ARGS, SKIP END END-PROCEDURE