KB#00887-Program to shrink MKEYED files by rewriting keys in non-sequential loop iteration.
Title:
Program to shrink MKEYED files by rewriting keys in non-sequential loop iteration.
Description:
The following program can be used to shrink MKEYED files by writing records in a non-sequential loop.
0010 REM Program to write MKEYED keys in non-sequential order
0020 REM Will shrink MKEYED files by re-writing them in a 5-pass loop
0030 REM You can set the number of passes at line 70 (CYCLES=5).
0040 REM
0050 IF TCB(13)=0 THEN BEGIN ; IF TCB(15)<255 THEN START 255,PGM(-1)
0060 LET F1N$=FIN(0),CUR_WDW=DEC(F1N$(9,2)); PRINT 'GOTO'(0),'PUSH','CS',
0070 LET F1N$=FIN(0),XM=ASC(F1N$(7)),YM=ASC(F1N$(8)),LN=29,CYCLES=5
0080 LET TXT$="Shrink MKEYED files in a "+STR(CYCLES)+"-pass rewrite"
0090 GOSUB CENTER; PRINT @(X,0),TXT$,'CE','GS',@(0,1),FILL(XM,"0"),'GE',
0100 LET DIR$=DIR(""); SETERR GET_DIR; ENTER DIR$; GOTO TST_DIR
0110 GET_DIR: LET Y=INT((YM-3)/2)-1,TXT$="Directory to examine : "+FILL(LN)
0120 GOSUB CENTER; PRINT @(X,Y),'SB',TXT$,'CE',; LET TXT$=TXT$(1,LEN(TXT$)-LN)
0130 INPUTE (0,ERR=GET_DIR)X+LEN(TXT$),Y,LN,"_",DIR$:(""=QUIT,LEN=0,LN)
0140 TST_DIR: SETERR 0; IF DIR$(LEN(DIR$),1)<>"/" THEN LET DIR$=DIR$+"/"
0150 LET Z=X,CHAN=UNT; OPEN (CHAN,ERR=OOPS_0)DIR$; GOTO CHECK
0160 OOPS_0: LET TXT$="Error "+STR(ERR)+" during 'OPEN' of "+DIR$
0170 OOPS_1: GOSUB CENTER; PRINT @(X,YM-2),'SF','BR',TXT$,'ER',
0180 INPUT (0,ERR=GET_DIR,SIZ=1)'CI',*; GOTO GET_DIR
0190 OOPS_2: LET TXT$="Error "+STR(ERR)+" during 'OPEN' ..."
0200 GOSUB CENTER; GOSUB WAIT; GOTO READ
0210 OOPS_3: LET TXT$="'LOCK' on this file not possible at the time !!!"
0220 GOSUB CENTER; GOSUB WAIT; CLOSE (CHECK); GOTO READ
0230 OOPS_4: LET TXT$="'"+PATH$+"' => NO read/write permission"
0240 GOSUB CENTER; GOSUB WAIT; GOTO EOD
0250 OOPS_5: LET TXT$="Error "+STR(ERR)+" during creation '"+TMP$+"'"
0260 GOSUB CENTER; GOSUB WAIT; CLOSE (CHECK); GOTO READ
0270 CHECK: LET F1D$=FID(CHAN); IF ASC(F1D$)=5 THEN GOTO GET_SUB
0280 LET TXT$="'"+DIR$+"' is NOT a directory !!!"; GOTO OOPS_1
0290 GET_SUB: LET TXT$="Examine subdirectories of "+DIR$+" too : "
0300 PRINT @(Z,Y+1),'SB',TXT$,'CE',
0310 INPUTE (0,ERR=GET_SUB)Z+LEN(TXT$),Y+1,"A","_",SUB$:(""=GET_DIR,LEN=0,1)
0320 ON POS(SUB$="NJY") GOTO GET_SUB,GO
0330 GO: CLOSE (CHAN); DIM NO[19]; LET PATH$="",NAME$=DIR$,CNT=-1,NO[0]=CHAN
0340 GET: LET CNT=CNT+1,PATH$=PATH$+NAME$
0350 PRINT @(Z,Y+2),'SB',"Directory : ",'CE',PATH$,@(Z,Y+3),'SB',"File : ",
0360 IF NO[CNT]=0 THEN LET NO[CNT]=UNT FI; OPEN (NO[CNT],ERR=OOPS_4)PATH$
0370 READ: READ RECORD(NO[CNT],ERR=EOD)NAME$; PRINT @(Z+7,Y+3),'CL',NAME$,
0380 IF POS(NAME$="..") THEN GOTO READ
0390 IF NAME$(LEN(NAME$))<>"/" THEN GOTO GOT_FILE
0400 IF POS(SUB$="YJ") THEN GOSUB GET; GOTO READ ELSE GOTO READ
0410 GOT_FILE: LET CHECK=UNT; OPEN (CHECK,ERR=OOPS_2)PATH$+NAME$
0420 LET F1D$=FID(CHECK),F1N$=FIN(CHECK)
0430 IF ASC(F1D$)<>6 OR ASC(F1D$(2))<>0 THEN CLOSE (CHECK); GOTO READ
0440 IF DEC(F1N$(77,4))<CYCLES+1 THEN CLOSE (CHECK); GOTO READ
0450 IF POS($00$<>F1N$(86))=0 THEN CLOSE (CHECK); GOTO READ
0460 LOCK (CHECK,ERR=OOPS_3); LET COPY=UNT
0470 LET TMP$=PATH$+"TMP"+HTA(INFO(3,0))+"."+FID(0),F1D$=F1D$(1,8)+TMP$
0480 PRINT @(Z,Y+4),'SB',"Rewrite : ",'CE',TMP$,
0490 ERASE: LET X=Z+LEN(TMP$)+10; ERASE TMP$,ERR=COPY; GOTO ERASE
0500 COPY: LET NR=DEC($00$+F1N$(77,4)); FILE F1D$,F1N$(86),ERR=OOPS_5
0510 OPEN (COPY)TMP$; LOCK (COPY)
0520 FOR PASS=1 TO CYCLES; CLOSE (CHECK); PREFIX PFX
0530 OPEN (CHECK)PATH$+NAME$; LOCK (CHECK); LET TIMES=PASS-1
0540 WHILE TIMES; READ RECORD(CHECK,END=EOF0); GOTO EOW0
0550 EOF0: LET TIMES=1
0560 EOW0: LET TIMES=TIMES-1; WEND
0570 GET_REC: READ RECORD(CHECK,END=EOF2,DIR=CYCLES)D$; LET NR=NR-1
0580 WRITE RECORD(COPY,ERR=EOF2,DOM=EOF2)D$; PRINT @(X,Y+4),NR,PASS," ",
0590 GOTO GET_REC
0600 EOF2: NEXT PASS; LET D$="",NEWFIN$=FIN(COPY)
0610 IF NR=0 AND F1N$(77,4)=NEWFIN$(77,4) THEN GOTO RENAME
0620 LET TXT$="'"+NAME$+"' => Possible KEY-POINTER problem ..."
0630 GOSUB CENTER; GOSUB WAIT; CLOSE (CHECK); CLOSE (COPY); PREFIX PFX
0640 ERASE TMP$; GOTO READ
0650 RENAME: CLOSE (CHECK); CLOSE (COPY); PREFIX PFX
0660 ERASE PATH$+NAME$,ERR=OOPS_6; GOTO RENAME_1
0670 OOPS_6: LET TXT$="Error "+STR(ERR)+" during erase '"+PATH$+NAME$+"'"
0680 GOSUB CENTER; GOSUB WAIT; GOTO READ
0690 RENAME_1: PREFIX PFX; RENAME TMP$ TO PATH$+NAME$
0700 PRINT @(0,Y+4),'CE',; GOTO READ
0710 EOD: CLOSE (NO[CNT]); LET CNT=CNT-1
0720 LET PATH$=PATH$(1,POS("/"=PATH$(1,LEN(PATH$)-1),-1))
0730 PRINT @(Z,Y+2),'SB',"Directory : ",'CL',PATH$,
0740 IF PATH$>=DIR$ THEN RETURN
0750 LET TXT$="End of re-write, hit <CR>"; GOSUB CENTER; GOSUB WAIT
0760 GOTO QUIT
5000 REM ^5000
5010 QUIT: PRINT 'POP','GOTO'(CUR_WDW),; RESET
5020 IF TCB(13) THEN EXIT ELSE STOP
5030 CENTER: LET X=INT((XM-LEN(TXT$))/2); IF X<0 THEN LET X=0 FI; RETURN
5040 WAIT: PRINT @(X,YM-2),'CE','BR',TXT$,'ER','RB',
5050 INPUT (0,ERR=TIMEOUT,SIZ=1,TIM=10)'CI',*
5060 TIMEOUT: PRINT @(0,YM-2),'CE',; RETURN
5070 END
Last Modified: 02/23/2004 Product: PRO/5 Operating System: All platforms
BASIS structures five components of their technology into the BBx Generations.
