home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / sigm / vols000 / vol025 / dbbuilde.cpm < prev    next >
Encoding:
Text File  |  1984-04-29  |  21.2 KB  |  848 lines
  1. (**********************************************************
  2. *
  3. *
  4.  
  5.  
  6.  
  7.  
  8.  
  9.  
  10.  
  11.  
  12.  
  13.  
  14.  
  15.  
  16.  
  17.  
  18.  
  19. *********************************************************)
  20.  
  21. PROGRAM DESCRIPTORBUILDER;  (*version 0.0 - 2 Feb 1980*)
  22.   (*Copyright 1980 Kenneth L. Bowles. All rights reserved. Permission is
  23.     hereby granted to use this material for any non-commerical purpose*)
  24. USES DBUNIT;
  25.  
  26. CONST
  27.   WA0 = 0;
  28.   FDNAMEOFFSET = 12;
  29.   LASTFIELDDESCRIPTOR = 255;
  30.   
  31. TYPE
  32.   CHSET=SET OF CHAR;
  33.   REFLIST=ARRAY[0..0] OF INTEGER; (*index range checking off*)
  34.  
  35.   (*fixed layout parts of descriptors*)
  36.   GRPDESCRIPTOR=
  37.     PACKED RECORD
  38.       OVERLINK:BYTE; (*descriptor longer than 240 bytes not allowed*)
  39.       SWITCHES:BYTE; (*packed array gets allocated in whole words*)
  40.                      (*bit 0 = tagged; bit 1 = linked *)
  41.       RECLINK:BYTE;
  42.       FILLER:BYTE;
  43.       RECNUM:REFLIST;
  44.       (*expand here with additional recnum's*)
  45.     END;
  46.   GRPDESPTR=^GRPDESCRIPTOR;
  47.   
  48.   RECDESCRIPTOR=
  49.     PACKED RECORD
  50.       OVERLINK:BYTE;
  51.       SWITCHES:BYTE; (*bit 0 = tagged; bit 1 = fixed width; bit 2 = sparse *)
  52.       SIZE:INTEGER;
  53.       FIRSTLITEMNUM:BYTE;
  54.       USECOUNT:BYTE;
  55.       LAYOUT:BYTE; (*on a large system this could be declared TAG*)
  56.       LASTFLDLINK:BYTE;  (*points to name field*)
  57.       FLDREF:ARRAY [0..0] OF
  58.                PACKED RECORD
  59.                  FDNUM: 0..LASTFIELDDESCRIPTOR;
  60.                  FLDOFFSET:BYTE; (*for fixed size fields; =0 for linked*)
  61.                END;
  62.       (*expand here with additional fldref's*)
  63.     END;
  64.   RECDESPTR=^RECDESCRIPTOR;
  65.  
  66.   FDTYPE=
  67.     PACKED RECORD
  68.       CASE BOOLEAN OF
  69.         TRUE: (S:STRING);
  70.         FALSE: (R:FLDDESCRIPTOR)
  71.       END;
  72.       
  73.   RDTYPE=
  74.     PACKED RECORD
  75.       CASE BOOLEAN OF
  76.         TRUE: (S:STRING);
  77.         FALSE: (R:RECDESCRIPTOR)
  78.       END;
  79.       
  80.   GDTYPE=
  81.     PACKED RECORD
  82.       CASE BOOLEAN OF
  83.         TRUE: (S:STRING);
  84.         FALSE: (R:GRPDESCRIPTOR)
  85.       END;
  86.       
  87.   STRINGPTR = ^STRING;
  88.       
  89.   TRIXPTR=
  90.     RECORD CASE DBLEVELTYPE OF
  91.       FIELDT: (F:FLDDESPTR);
  92.       RECORDT:(R:RECDESPTR);
  93.       GROUPT: (G:GRPDESPTR);
  94.       NONET:  (S:STRINGPTR)
  95.     END (*TRIXPTR*);
  96.       
  97.       
  98.   
  99. VAR
  100.   DONE:BOOLEAN;
  101.   ITEMLEVEL:DBLEVELTYPE;
  102.   REMFILE:BOOLEAN;
  103.   FOUT:INTERACTIVE;
  104.   
  105. FUNCTION GETCOMMAND(S:STRING; OKSET:CHSET):CHAR;
  106. VAR CH:CHAR;
  107. BEGIN
  108.   REPEAT
  109.     WRITELN;
  110.     WRITE(S);
  111.     READ(CH);
  112.     IF CH IN ['a'..'z'] THEN
  113.       CH:=CHR(ORD(CH)-32);
  114.     IF NOT (CH IN OKSET) THEN
  115.       WRITE(' ORD(CH)=',ORD(CH));
  116.   UNTIL CH IN OKSET;
  117.   WRITELN;
  118.   GETCOMMAND:=CH;
  119. END (*GETCOMMAND*);
  120.  
  121. PROCEDURE LOCATOR(GROUPNUM,RECNUM:INTEGER);
  122. VAR I:INTEGER;
  123. BEGIN
  124.   DBSHOWERR('LOC#1', DBHOME(WA0));
  125.   DBSHOWERR('LOC#2', DBSEEK(WA0, GROUPNUM));
  126.   DBSHOWERR('LOC#3', DBDESCEND(WA0));
  127.   DBSHOWERR('LOC#4', DBSEEK(WA0, RECNUM));
  128. END (*LOCATOR*);
  129.  
  130. FUNCTION READI(S:STRING; X:INTEGER): INTEGER;
  131. VAR I:INTEGER;
  132. BEGIN
  133.   WRITE(S,X, '  >');
  134.   READLN(I);
  135.   IF EOF THEN
  136.     BEGIN
  137.       RESET(INPUT);
  138.       READI:=X;
  139.       WRITELN;
  140.     END
  141.   ELSE
  142.     READI:=I;
  143. END (*READI*);
  144.  
  145. PROCEDURE SHOWFLDTYPE(FLDTYPE:DBFIELDTYPES);
  146. BEGIN
  147.   WRITE('FLD TYPE:');
  148.   IF NOT (FLDTYPE IN [BYTEF, GROUPF, INTEGERF, LONGINTF, STRINGF,
  149.                      SETF, PICF]) THEN
  150.     WRITELN('***** ILLEGAL ****')
  151.   ELSE
  152.     CASE FLDTYPE OF
  153.       BYTEF: WRITELN('BYTEF');
  154.       GROUPF: WRITELN('GROUPF');
  155.       INTEGERF: WRITELN('INTEGERF');
  156.       LONGINTF: WRITELN('LONGINTF');
  157.       SETF: WRITELN('SETF');
  158.       PICF: WRITELN('PICF');
  159.       TEXTF: WRITELN('TEXTF');
  160.       STRINGF: WRITELN('STRINGF')
  161.     END (*CASE*);
  162. END (*SHOWFLDTYPE*);
  163.  
  164. PROCEDURE SHOWFD(PS:STRING);
  165. VAR 
  166.   FD:FDTYPE;
  167. BEGIN
  168.   FD.S:=PS;
  169.   WITH FD.R DO
  170.     BEGIN
  171.       (*note: link value is one more than correct string length*)
  172.       WRITELN('FIELD DESCRIPTOR:',NAME:(LENGTH(NAME)-1));
  173.       WRITELN('SWITCHES:', SWITCHES);
  174.       WRITELN('MAX WIDTH:', MAXWIDTH);
  175.       WRITELN('USECOUNT:', USECOUNT);
  176.       SHOWFLDTYPE(FLDTYPE);
  177.       WRITELN('FLDREF:', FLDREF);
  178.       IF FLDREF = 0 THEN
  179.         BEGIN
  180.           WRITELN('ROW:', ROW);
  181.           WRITELN('DATACOL:', DATACOL);
  182.           WRITELN('LABELCOL:', LABELCOL);
  183.           WRITELN('CONTROLBITS:', CONTROLBITS);
  184.         END;
  185.     END (*WITH*);
  186. END (*SHOWFD*);
  187.  
  188. PROCEDURE BUILDFD;
  189. VAR NS:STRING;
  190.   I,FLDNUM:INTEGER;
  191.   CH:CHAR;
  192.   FD:FDTYPE;
  193. BEGIN
  194.   DBTYPECHECK:=FALSE;
  195.   WRITELN;
  196.   WRITE('FIELD NUMBER:');
  197.   READLN(FLDNUM);
  198.   LOCATOR(3(*FD'S*), FLDNUM);
  199.   CASE GETCOMMAND('BUILDFD: C(hange old field or N(ew field?',
  200.                         ['C','c','N','n']) OF
  201.     'C','c': BEGIN
  202.                DBSHOWERR('BUILDFD-GET', DBGET(WA0));
  203.                FD.S:=DBMAIL.STRG;
  204.              END;
  205.     'N','n': FILLCHAR(FD.S, 82, CHR(0))
  206.   END (*CASE*);
  207.   WITH FD.R DO
  208.     BEGIN
  209.   
  210.       WRITE('FIELD NAME:', NAME:LENGTH(NAME)-1, '  >');
  211.       READLN(NS);
  212.       IF LENGTH(NS) > 0 THEN
  213. (*$R-*)
  214.         BEGIN
  215.           MOVELEFT(NS,NAME,LENGTH(NS)+1);
  216.           NAME[0]:=CHR(LENGTH(NS)+1);
  217.           OVERLINK:=LENGTH(NS)+SIZEOF(FLDDESCRIPTOR)-1;
  218.         END
  219.       ELSE
  220.         WRITELN;
  221. (*$R+*)
  222.       SWITCHES:=READI('SWITCH BYTE:',SWITCHES);
  223.       MAXWIDTH:=READI('MAXIMUM WIDTH:', MAXWIDTH);
  224.       USECOUNT:=0;
  225.       SHOWFLDTYPE(FLDTYPE);
  226.       WRITE('  G(ROUP R(EC S(TRING B(YTE I(NTEGER  >');
  227.       REPEAT
  228.         READ(CH);
  229.       UNTIL (CH IN ['G', 'S', 'B', 'I']) OR EOF;
  230.       WRITELN;
  231.       IF EOF THEN
  232.         RESET(INPUT)
  233.       ELSE
  234.         CASE CH OF
  235.           'B': FLDTYPE:=BYTEF;
  236.           'G': FLDTYPE:=GROUPF;
  237.           'I': FLDTYPE:=INTEGERF;
  238.           'S': FLDTYPE:=STRINGF
  239.         END (*CASE*);
  240.       IF FLDTYPE = GROUPF THEN
  241.         FLDREF:=READI('DESCRIPTOR NUMBER:',FLDREF)
  242.       ELSE
  243.         FLDREF:=READI('Displayable (=0) or not (=1):', FLDREF);
  244.       IF FLDTYPE <> GROUPF THEN
  245.         BEGIN
  246.           WRITE('Set Display Params? (Y/N)');
  247.           READ(CH);
  248.           WRITELN;
  249.           IF CH IN ['Y', 'y'] THEN
  250.             BEGIN
  251.               ROW:=READI('ROW:',ROW);
  252.               DATACOL:=READI('DATACOL:', DATACOL);
  253.               LABELCOL:=READI('LABELCOL:',LABELCOL);
  254.               CONTROLBITS:=READI('CONTROLBITS:',CONTROLBITS);
  255.             END;
  256.         END;
  257.     END (*WITH FD.R*);
  258.   WRITELN;
  259.   WRITE('<ETX> ACCEPTS; <RET> TRY AGAIN');
  260.   READ(KEYBOARD,CH);
  261.   IF CH = CHR(3(*ETX*)) THEN
  262.     WITH DBMAIL DO
  263.       BEGIN
  264.         STRG:=FD.S;
  265.         DBMAILTYPE:=STRINGF;
  266.         DBSHOWERR('BUILDFD', DBPUT(WA0));
  267.       END;
  268. END (*BUILDFD*);
  269.  
  270. PROCEDURE SHOWRD(PS:STRING);
  271. VAR I,J,N:INTEGER;
  272.   NS:STRING;
  273.   RD:RDTYPE;
  274. BEGIN
  275.   RD.S:=PS;
  276.   NS:=RD.S;
  277.   DELETE(NS,1,(RD.R.LASTFLDLINK+SIZEOF(RECDESCRIPTOR)-3));
  278.   WRITELN('RECORD DESCRIPTOR:',NS);
  279.   WITH RD.R DO
  280.     BEGIN
  281.       WRITELN('SWITCHES:', SWITCHES);
  282.       WRITELN('SIZE:', SIZE);
  283.       WRITELN('FIRSTLINK - ITEM# ', FIRSTLITEMNUM);
  284.       WRITELN('USECOUNT:', USECOUNT);
  285.       WRITELN('LAYOUT:', LAYOUT);
  286.       WRITELN('LASTFLDLINK:', LASTFLDLINK);
  287.     END (*WITH*);
  288.   I:=0;
  289.   N:=0;
  290.   J:=RD.R.LASTFLDLINK - 2;
  291.   WHILE I < J DO
  292.     BEGIN
  293. (*$R-*)
  294.       WITH RD.R.FLDREF[N] DO
  295.         WRITELN(' FLDREF(', N, ') - FDNUM:', FDNUM,
  296.                                     '   OFFSET:', FLDOFFSET);
  297.       I:=I+2;
  298.       N:=N+1;
  299. (*$R+*)
  300.     END;
  301. END (*SHOWRD*);
  302.  
  303. PROCEDURE BUILDRD;
  304. VAR I,J,N,X,RECNUM:INTEGER;
  305.   NAME:STRING;
  306.   CH:CHAR;
  307.   RD:RDTYPE;
  308. BEGIN
  309.   REPEAT
  310.     FILLCHAR(RD.S, 82, CHR(0));
  311.     WRITELN;
  312.     WRITE('RECORD DEF NUMBER:');
  313.     READLN(RECNUM);
  314.     LOCATOR(2(*RD'S*), RECNUM);
  315.     WRITE('RECDEF NAME:');
  316.     READLN(NAME);
  317.     WRITE('SWITCH BYTES:');
  318.     WITH RD.R DO
  319.       BEGIN
  320.         READLN(I);
  321.         SWITCHES:=I;
  322.         WRITE('SIZE:');
  323.         READLN(SIZE);
  324.         WRITE('FIRSTLITEMNUM:'); READLN(I); FIRSTLITEMNUM:=I;
  325.         USECOUNT:=0;
  326.         WRITE('LAYOUT#:');
  327.         READLN(I);
  328.         LAYOUT:=I;
  329.       END (*WITH*);
  330.     I:=8;
  331.     J:=3;
  332.     REPEAT
  333.       N:=(I-8) DIV 2;
  334.       WRITE('FLDREF #', N, ':');
  335.       READ(X);
  336.       IF X >= 0 THEN
  337. (*$R-*)
  338.         WITH RD.R.FLDREF[N] DO
  339.           BEGIN
  340.             FDNUM:=X;
  341.             WRITE('  OFFSET #', N, ':'); 
  342.             READLN(X);
  343.             FLDOFFSET:=X;
  344. (*$R+*)
  345.             J:=J+2;
  346.             I:=I+2;
  347.           END;
  348.     UNTIL X < 0;
  349.     RD.R.OVERLINK:=2+I;
  350.     RD.R.LASTFLDLINK:=J; (*leave 2 empty bytes*)
  351.     RD.S:=CONCAT(RD.S,NAME);
  352.     RD.S[2+I]:=CHR(LENGTH(NAME)+1);
  353.     WRITELN;
  354.     SHOWRD(RD.S);
  355.     WRITE('<ETX> ACCEPTS; <RET> TRY AGAIN');
  356.     READ(KEYBOARD,CH);
  357.   UNTIL CH = CHR(3(*ETX*));
  358.   WITH DBMAIL DO
  359.     BEGIN
  360.       STRG:=RD.S;
  361.       DBMAILTYPE:=STRINGF;
  362.     END;
  363.   READ(CH); (*flush buffered char left by READ(X) of '-1<RET>'*)
  364.   WRITELN;
  365. END (*BUILDRD*);
  366.  
  367. PROCEDURE SHOWGD(PS:STRING);
  368. VAR I,J,N:INTEGER;
  369.   A: ARRAY[0..0] OF INTEGER;
  370.   NS:STRING;
  371.   GD:GDTYPE;
  372. BEGIN
  373.   GD.S:=PS;
  374.   NS:=GD.S;
  375.   DELETE(NS,1,(GD.R.RECLINK+SIZEOF(GRPDESCRIPTOR)-4));
  376.   WRITELN('GROUP DESCRIPTOR:',NS);
  377.   WITH GD.R DO
  378.     BEGIN
  379.       WRITELN('SWITCHES:', SWITCHES);
  380.       WRITELN('RECLINK:', RECLINK);
  381.     END (*WITH*);
  382.   I:=0;
  383.   N:=0;
  384.   J:=GD.R.RECLINK-2;
  385.   WHILE I < J DO
  386.     BEGIN
  387. (*$R-*)
  388.       WRITELN(' RECNUM(', N, '):', GD.R.RECNUM[N]);
  389. (*$R+*)
  390.       N:=N+1;
  391.       I:=I+2;
  392.     END;
  393. END (*SHOWGD*);
  394.  
  395. PROCEDURE BUILDGD;
  396. VAR I,J,N,X,GRPNUM:INTEGER;
  397.   NAME:STRING;
  398.   CH:CHAR;
  399.   GD:GDTYPE;
  400. BEGIN
  401.   FILLCHAR(GD.S, 82, CHR(0));
  402.   REPEAT
  403.     WRITELN;
  404.     WRITE('GROUP DEF NUMBER:');
  405.     READLN(GRPNUM);
  406.     LOCATOR(1(*GD'S*), GRPNUM);
  407.     WRITE('GRPDEF NAME:');
  408.     READLN(NAME);
  409.     WRITE('SWITCH BYTES:');
  410.     READLN(I);
  411.     GD.R.SWITCHES:=I;
  412.     I:=4;
  413.     REPEAT
  414.       N:=(I-4) DIV 2;
  415.       WRITE('RECNUM #', N, ':');
  416.       READLN(X);
  417.       IF X >= 0 THEN
  418.         BEGIN
  419. (*$R-*)
  420.           GD.R.RECNUM[N]:=X;
  421. (*$R+*)
  422.           I:=I+2;
  423.         END;
  424.     UNTIL X < 0;
  425.     GD.R.OVERLINK:=2+I;
  426.     GD.R.RECLINK:=I;
  427.     GD.S:=CONCAT(GD.S,NAME);
  428.     GD.S[2+I]:=CHR(LENGTH(NAME)+1);
  429.     WRITELN;
  430.     SHOWGD(GD.S);
  431.     WRITE('<ETX> ACCEPTS; <RET> TRY AGAIN');
  432.     READ(KEYBOARD,CH);
  433.   UNTIL CH = CHR(3(*ETX*));
  434.   WITH DBMAIL DO
  435.     BEGIN
  436.       STRG:=GD.S;
  437.       DBMAILTYPE:=STRINGF;
  438.     END;
  439. END (*BUILDGD*);
  440.  
  441. PROCEDURE BUILDLITERAL;
  442. VAR I:INTEGER;
  443.   S:STRING;
  444. BEGIN
  445.   CASE GETCOMMAND('LITERAL: I(NTEGER S(TRING ', ['I','S']) OF
  446.     'I': BEGIN
  447.            WRITE('I>');
  448.            READLN(I);
  449.            WITH DBMAIL DO
  450.              BEGIN
  451.                INT:=I;
  452.                DBMAILTYPE:=INTEGERF;
  453.              END;
  454.          END;
  455.     'S': BEGIN
  456.            WRITE('S>');
  457.            READLN(S);
  458.            WITH DBMAIL DO
  459.              BEGIN
  460.                STRG:=S;
  461.                DBMAILTYPE:=STRINGF;
  462.              END;
  463.          END
  464.   END (*CASES*);
  465. END (*BUILDLITERAL*);
  466.  
  467. PROCEDURE SHOWLITERAL;
  468. BEGIN
  469.   WRITELN;
  470.   CASE DBMAIL.DBMAILTYPE OF
  471.     STRINGF: WRITELN('STRG: ', DBMAIL.STRG);
  472.     INTEGERF: WRITELN('INT: ', DBMAIL.INT)
  473.     (*LONGINTF: WRITELN('LINT: ', DBMAIL.LINT) *)
  474.   END (*CASES*);
  475. END (*SHOWLITERAL*);
  476.  
  477. PROCEDURE SHOWDATASTRUCTURE;
  478. VAR TP:TRIXPTR;
  479.   GN:INTEGER;
  480.   
  481.   PROCEDURE GDOUT(TP:TRIXPTR; LEVEL,GN:INTEGER); FORWARD;
  482.   
  483.   PROCEDURE FDOUT(TP:TRIXPTR; LEVEL,FN:INTEGER);
  484.   VAR NS:STRING;
  485.     GP:TRIXPTR;
  486.   BEGIN
  487.     WITH TP.F^ DO
  488.       BEGIN
  489.         NS:=NAME;
  490.         DELETE(NS,LENGTH(NS),1);
  491.         (*note: link value is one more than correct string length*)
  492.         WRITE(FOUT,'FLD(':(4+LEVEL), FN, '):',NS, ' ':17-LENGTH(NS));
  493.         WRITE(FOUT,'   SW:', SWITCHES);
  494.         WRITE(FOUT,'  W:', MAXWIDTH);
  495.         WRITE(FOUT,'  T:');
  496.         IF NOT (FLDTYPE IN [BYTEF, GROUPF, INTEGERF, LONGINTF, STRINGF,
  497.                            SETF, PICF]) THEN
  498.           WRITE(FOUT,'***** ILLEGAL ****')
  499.         ELSE
  500.           BEGIN
  501.             CASE FLDTYPE OF
  502.               BYTEF: WRITE(FOUT,'BYT');
  503.               GROUPF: WRITE(FOUT,'GRP');
  504.               INTEGERF: WRITE(FOUT,'INT');
  505.               LONGINTF: WRITE(FOUT,'LNI');
  506.               SETF: WRITE(FOUT,'SET');
  507.               PICF: WRITE(FOUT,'PIC');
  508.               TEXTF: WRITE(FOUT,'TXT');
  509.               STRINGF: WRITE(FOUT,'STR')
  510.             END (*CASE*);
  511.             IF FLDTYPE = GROUPF THEN
  512.               BEGIN
  513.                 WRITELN(FOUT);
  514.                 DBGETDESCRIPTORNUM(GROUPT, FLDREF, GP.F);
  515.                 IF GP.F <> NIL THEN
  516.                   GDOUT(GP, LEVEL+2, FLDREF);
  517.               END
  518.             ELSE
  519.               BEGIN
  520.                 IF FLDREF = 0 THEN
  521.                   WRITE(FOUT, '  ROW=', ROW,
  522.                               '  LCOL=', LABELCOL,
  523.                               '  DCOL=', DATACOL);
  524.                 WRITELN(FOUT);
  525.               END;
  526.           END (*FLDTYPE OK*);
  527.       END (*WITH TP.F^*);
  528.   END (*FDOUT*);
  529.   
  530.   PROCEDURE RDOUT(TP:TRIXPTR; LEVEL,RN:INTEGER);
  531.   VAR I,J,N:INTEGER;
  532.     NS:STRING;
  533.     FP:TRIXPTR;
  534.   BEGIN
  535.     NS:=TP.S^;
  536.     DELETE(NS,1,(TP.R^.LASTFLDLINK+SIZEOF(RECDESCRIPTOR)-3));
  537.     (*correct for link to string length*)
  538.     DELETE(NS, LENGTH(NS),1);
  539.     WRITE(FOUT,'REC(':(4+LEVEL), RN, '):',NS, ' ':18-LENGTH(NS));
  540.     WITH TP.R^ DO
  541.       BEGIN
  542.         WRITE(FOUT,'   SW:', SWITCHES);
  543.         WRITELN(FOUT,'  SIZE:', SIZE);
  544.       END (*WITH*);
  545.     I:=0;
  546.     N:=0;
  547.     J:=TP.R^.LASTFLDLINK - 4;
  548.     WHILE I < J DO
  549.       BEGIN
  550. (*$R-*)
  551.         WITH TP.R^.FLDREF[N] DO
  552.           BEGIN
  553.             DBGETDESCRIPTOR(FIELDT, FDNUM, FP.F);
  554. (*$R+*)
  555.             IF FP.F <> NIL THEN
  556.               FDOUT(FP, LEVEL+2, FDNUM);
  557.           END;
  558.         I:=I+2;
  559.         N:=N+1;
  560.       END;
  561.   END (*RDOUT*);
  562.   
  563.   PROCEDURE GDOUT(*TP:TRIXPTR; LEVEL,GN:INTEGER*);
  564.   VAR I,J,N:INTEGER;
  565.     NS:STRING;
  566.     RP:TRIXPTR;
  567.   BEGIN
  568.     NS:=TP.S^;
  569.     DELETE(NS,1,(TP.G^.RECLINK+SIZEOF(GRPDESCRIPTOR)-4));
  570.     (*correct for link to string length*)
  571.     DELETE(NS, LENGTH(NS),1);
  572.     WRITE(FOUT,'GRP(':(4+LEVEL), GN, '):',NS, ' ':18-LENGTH(NS));
  573.     WITH TP.G^ DO
  574.       BEGIN
  575.         WRITELN(FOUT,'   SW:', SWITCHES);
  576.         I:=0;
  577.         N:=0;
  578.         J:=RECLINK-4;
  579.         WHILE I < J DO
  580.           BEGIN
  581. (*$R-*)
  582.             DBGETDESCRIPTOR(RECORDT, RECNUM[N], RP.F);
  583. (*$R+*)
  584.             IF RP.F <> NIL THEN
  585.               RDOUT(RP,LEVEL+2, RECNUM[N]);
  586.             N:=N+1;
  587.             I:=I+2;
  588.           END;
  589.       END (*WITH TP.G^*);
  590. END (*GDOUT*);
  591.   
  592. BEGIN (*SHOWDATASTRUCTURE*)
  593.   WRITELN(FOUT);
  594.   GN:=0;
  595.   DBGETDESCRIPTOR(GROUPT, GN, TP.F);
  596.   WHILE TP.F <> NIL DO
  597.     BEGIN
  598.       GDOUT(TP,0, GN);
  599.       WRITELN(FOUT);
  600.       GN:=GN+1;
  601.       DBGETDESCRIPTOR(GROUPT, GN, TP.F);
  602.     END;
  603. END (*SHOWDATASTRUCTURE*);
  604.   
  605. PROCEDURE SHOWITEMINFO;
  606. VAR ITEMNUM,OFFSET,DESCRIPTORNUM:INTEGER;
  607.   NAME:STRING;
  608. BEGIN
  609.   WRITELN;
  610.   DBITEMINFO(WA0,ITEMLEVEL,ITEMNUM,OFFSET,DESCRIPTORNUM,NAME);
  611.   WRITE('LEVEL=');
  612.   CASE ITEMLEVEL OF
  613.     GROUPT: WRITE('GROUPT');
  614.     RECORDT:WRITE('RECORDT');
  615.     FIELDT: WRITE('FIELDT');
  616.     NONET:  WRITE('NONET')
  617.   END (*CASES*);
  618.   WRITELN('  ITEM#', ITEMNUM, '  OFFSET=', OFFSET,
  619.           '  DESCRIP#', DESCRIPTORNUM, '  NAME=', NAME);
  620. END (*SHOWITEMINFO*);
  621.  
  622. PROCEDURE NEWEMPTY;
  623. VAR CH:CHAR;
  624.   TAG:INTEGER;
  625. BEGIN
  626.   SHOWITEMINFO;
  627.   WRITE('Make new item? (Y/N)');
  628.   READ(CH);
  629.   WRITELN;
  630.   IF CH IN ['Y','y'] THEN
  631.     BEGIN
  632.       CASE ITEMLEVEL OF
  633.         GROUPT: 
  634.           CASE GETCOMMAND('new embedded R(ecord or new G(roup?',
  635.                                           ['G','R']) OF
  636.             'G': BEGIN
  637.                    WRITE('TAG VALUE:');
  638.                    READLN(TAG);
  639.                    DBSHOWERR('NEWEMPTY-GROUPT',
  640.                           DBEMPTYITEM(WA0,GROUPT,TAG));
  641.                  END;
  642.             'R': DBSHOWERR('NEWEMPTY-REC', DBEMPTYITEM(WA0,RECORDT,TAG))
  643.           END (*CASE GROUPT*);
  644.         RECORDT,FIELDT: 
  645.           DBSHOWERR('NEWEMPTY', DBEMPTYITEM(WA0,ITEMLEVEL,TAG));
  646.         NONET: BEGIN (*do nothing*) END
  647.       END (*CASE ITEMLEVEL*);
  648.     END (*IF CH*);
  649. END (*NEWEMPTY*);
  650.  
  651. PROCEDURE TRANSFERPRIMITIVES;
  652. BEGIN
  653.   CASE GETCOMMAND('XFER: E(MPTY G(ET P(UT R(EMOUT T(YPECHECK Q(UIT ',
  654.                         ['E', 'G', 'P', 'R', 'T', 'Q']) OF
  655.     'E': NEWEMPTY;
  656.     'P': DBSHOWERR('XFER-PUT', DBPUT(WA0));
  657.     'G': DBSHOWERR('XFER-GET', DBGET(WA0));
  658.     'R': BEGIN
  659.            REMFILE:=NOT REMFILE;
  660.            CLOSE(FOUT);
  661.            IF REMFILE THEN
  662.              BEGIN
  663.                RESET(FOUT, 'CONSOLE:');
  664.                WRITELN('Output now to CONSOLE:');
  665.              END
  666.            ELSE
  667.              BEGIN
  668.                RESET(FOUT, 'REMOUT:');
  669.                WRITELN('Output now to REMOUT:');
  670.              END;
  671.          END;
  672.     'T': BEGIN
  673.            DBTYPECHECK:=NOT DBTYPECHECK;
  674.            WRITE('DBTYPECHECK NOW ');
  675.            IF DBTYPECHECK THEN
  676.              WRITELN('TRUE')
  677.            ELSE
  678.              WRITELN('FALSE');
  679.          END;
  680.     'Q': BEGIN (*do nothing*) END
  681.   END (*CASES*);
  682. END (*TRANSFERPRIMITIVES*);
  683.  
  684. PROCEDURE FILEHANDLER;
  685. CONST
  686.   FNUM=0;
  687.   PGZERO=0;
  688.   EMPTYSTRING='';
  689. VAR
  690.   TITLE:STRING;
  691.   CH:CHAR;
  692.   DUMMY:INTEGER;
  693.   
  694.   PROCEDURE GETTITLE;
  695.   BEGIN
  696.     WRITE('FILE TITLE:');
  697.     READLN(TITLE);
  698.   END (*GETTITLE*);
  699.   
  700. BEGIN (*FILEHANDLER*)
  701.   CASE GETCOMMAND(
  702.         'FILE: N(EWFILE O(PEN I(NIT-GROUPS C(LOSE R(EMOVE G(ET P(UT Q(UIT',
  703.                         ['C','G','I','N','O','P','R','Q']) OF
  704.     'C': DBSHOWERR('FILE(C)', DBFCLOSE(FNUM));
  705.     'G': DBSHOWERR('FILE(G)', DBGETPAGE(FNUM,WA0,PGZERO));
  706.     'I': DBSHOWERR('FILE(I)', DBGROUPINIT(FNUM,DUMMY,'ALL'));
  707.     'N': BEGIN
  708.            WRITE('NEW ');
  709.            GETTITLE;
  710.            DBSHOWERR('FILE(N)', DBFCREATE(FNUM,WA0,EMPTYSTRING,TITLE));
  711.          END;
  712.     'O': BEGIN
  713.            WRITE('OLD ');
  714.            GETTITLE;
  715.            DBSHOWERR('FILE(O)', DBFOPEN(FNUM, TITLE));
  716.          END;
  717.     'P': DBSHOWERR('FILE(P)', DBPUTPAGE(FNUM, WA0, PGZERO));
  718.     'R': BEGIN
  719.            WRITE('REMOVE OLD FILE (Y/N)?');
  720.            READ(CH);
  721.            IF CH = 'Y' THEN
  722.              DBSHOWERR('FILE(R)', DBFREMOVE(FNUM));
  723.          END;
  724.     'Q': BEGIN
  725.            (*DO NOTHING*);
  726.          END
  727.   END (*CASE*);
  728. END (*FILEHANDLER*);
  729.  
  730. PROCEDURE TESTFINDREC;
  731. VAR FN,RN:INTEGER;
  732.   FOUND:BOOLEAN;
  733.   KEY:STRING;
  734. BEGIN
  735.   WRITELN('TEST DBFINDREC PROCEDURE');
  736.   WRITE('FIELDNUM:');
  737.   READLN(FN);
  738.   WRITE('KEY(STRING):');
  739.   READLN(KEY);
  740.   DBSHOWERR('TESTFINDREC', DBFINDREC(WA0, ASCENDING, FN, KEY, RN, FOUND));
  741.   IF FOUND THEN WRITE('  FOUND RECORD')
  742.            ELSE WRITE('  COULDN''T FIND KEY');
  743.   WRITELN('  RECNUM=', RN);
  744.   WRITELN;
  745. END (*TESTFINDREC*);
  746.  
  747. PROCEDURE MOVER;
  748. VAR N,G,R:INTEGER;
  749. BEGIN
  750.   CASE GETCOMMAND(
  751.     'MOVE: B(EGIN-LEVEL F(IND H(OME N(EXT T(AIL S(EEK D(ESCEND L(OCATE Q(UIT',
  752.                                 ['B','F','H','N','S','T','D','L','Q']) OF
  753.     'B': DBSHOWERR('MOVE-HEAD', DBHEAD(WA0));
  754.     'F': TESTFINDREC;
  755.     'H': DBSHOWERR('MOVE-HOME', DBHOME(WA0));
  756.     'N': DBSHOWERR('MOVE-NEXT', DBNEXT(WA0));
  757.     'T': DBSHOWERR('MOVE-TAIL', DBTAIL(WA0));
  758.     'S': BEGIN
  759.            WRITELN;
  760.            WRITE('ITEM NUMBER:');
  761.            READLN(N);
  762.            DBSHOWERR('MOVE-SEEK', DBSEEK(WA0, N));
  763.          END;
  764.     'D': DBSHOWERR('MOVE-DESCEND', DBDESCEND(WA0));
  765.     'L': BEGIN
  766.            WRITELN;
  767.            WRITE('GROUP:');
  768.            READLN(G);
  769.            WRITE('  RECORD:');
  770.            READLN(R);
  771.            LOCATOR(G,R);
  772.          END;
  773.     'Q': BEGIN
  774.            (*DO NOTHING*)
  775.          END
  776.   END (*CASES*);
  777. END (*MOVER*);
  778.  
  779. PROCEDURE SETTRACESITES;
  780. VAR I:INTEGER;
  781. BEGIN
  782.   WRITELN('ENTER TRACE SITE NUMBERS (<ETX> Terminates input list)');
  783.   REPEAT
  784.     WRITE('>');
  785.     READLN(I);
  786.     IF NOT EOF THEN
  787.       IF (I>=0) AND (I <= 100) THEN
  788.         DBTRACESET := DBTRACESET + [I];
  789.   UNTIL EOF;
  790.   RESET(INPUT);
  791. END (*SETTRACESITES*);
  792.  
  793. PROCEDURE INIT;
  794. VAR I:INTEGER;
  795. BEGIN
  796.   DBINITIALIZE;
  797.   WRITELN('DESCRIPTOR BUILDER INITIALIZING');
  798.   DBTYPECHECK:=FALSE;
  799.   SETTRACESITES;
  800.   
  801.   (*put 5 empty groups in wa0*)
  802.   FOR I:=0 TO 4 DO DBSHOWERR('INIT#2', DBEMPTYITEM(WA0,GROUPT,0));
  803.   
  804.   (*put one empty linked record in each group, thus permitting traversal
  805.     operations to function*)
  806.   FOR I:=1 TO 4 DO
  807.     BEGIN
  808.       DBSHOWERR('INIT-HOME',DBHOME(WA0));
  809.       DBSHOWERR('INIT-SEEK',DBSEEK(WA0,I));
  810.       DBSHOWERR('INIT#4', DBEMPTYITEM(WA0, RECORDT,0));
  811.     END;
  812.   DONE:=FALSE;
  813.   REMFILE:=FALSE;
  814.   RESET(FOUT, 'CONSOLE:');
  815. END (*INIT*);
  816.  
  817. BEGIN (*MAIN PROGRAM*)
  818.   INIT;
  819.   REPEAT
  820.     CASE GETCOMMAND(
  821.       'B(UILD X(FER D(ISPLAY F(ILE M(OVE S(TRUCT W(RITE Q(UIT',
  822.                                 ['B','X','D','F','M','S','T','W','Q']) OF
  823.       'B': CASE GETCOMMAND('BUILD: G(ROUP R(ECORD F(IELD L(ITERAL', 
  824.                                 ['G','R','F','L']) OF
  825.              'F': BUILDFD;
  826.              'G': BUILDGD;
  827.              'L': BUILDLITERAL;
  828.              'R': BUILDRD
  829.            END (*CASE*);
  830.       'X': TRANSFERPRIMITIVES;
  831.       'D': CASE GETCOMMAND('DISPLAY: G(ROUP R(ECORD F(IELD L(ITERAL', 
  832.                                                    ['G','R','F','L']) OF
  833.              'F': SHOWFD(DBMAIL.STRG);
  834.              'G': SHOWGD(DBMAIL.STRG);
  835.              'L': SHOWLITERAL;
  836.              'R': SHOWRD(DBMAIL.STRG)
  837.            END (*CASE*);
  838.       'F': FILEHANDLER;
  839.       'M': MOVER;
  840.       'S': SHOWDATASTRUCTURE;
  841.       'T': SETTRACESITES;
  842.       'W': DBSHOWERR('WRITEFIELD', DBWRITEFIELD(OUTPUT,WA0));
  843.       'Q': DONE:=TRUE
  844.     END (*CASE*);
  845.   UNTIL DONE;
  846. END.
  847.  
  848.