⟦f73c998f3⟧

TextFile

PROGRAM database; æ$A+,C-,R-,V-å


æ***************************************************************å
æ                                                               å
æ                    PolyFile Version 1.10                      å
æ                                                               å
æ                       DATABASE Example                        å
æ                                                               å
æ                      Copyright (C) 1985                       å
æ                   PolyData MicroCenter A/S                    å
æ                                                               å
æ***************************************************************å


æ DATABASE demonstrates how to use PolyFile to create and main- å
æ tain a simple customer data base. DATABASE allows you to add, å
æ find, view, edit, delete and list customers of a predefined   å
æ type (see the CUSTREC type definition below).                 å

æ DATABASE maintains three files: A data file (CUST.DAT), a     å
æ customer code index (CUST.IXC) and a name index (CUST.IXN).   å
æ The customer code index does not allow duplicate keys,        å
æ whereas the name index does. When DATABASE is run for the     å
æ first time, it will automatically create an empty data base.  å

æ The main menu offers three functions: U)pdate, L)ist and      å
æ Q)uit. U)pdate is used to add, find, view, edit and delete    å
æ customers. L)ist is used to list customers, and Q)uit is used å
æ to terminate the program.                                     å

æ On the U)pdate menu, The A)dd function is used to add new     å
æ customers. F)ind is used to locate a customer, either by cus- å
æ tomer code or by last (and first) name. To search for a spe-  å
æ cific customer code, simply enter it when the cursor moves to å
æ the customer code field. If it is found, the customer's data  å
æ is displayed and you may, if you wish, E)dit or D)elete it.   å
æ To search for a name, enter an empty customer code. Then      å
æ enter the last name and optionally the first name. Note that  å
æ if a first name is specified, the first 15 characters of the  å
æ last name must be entered in full. The scan will locate the   å
æ first customer of the specified name or the first customer    å
æ that follows the specified name if no exact match occurs. You å
æ may then use N)ext and P)revious to move forwards and back-   å
æ wards in alphabetical order. Once you have located the wanted å
æ customer, enter Q)uit. You may then E)dit or D)elete the      å
æ record shown on the screen, or simply leave it unchanged.     å

æ L)ist is used to list customers. Listings will show the cus-  å
æ tomer code, the name and the company. They may be output to   å
æ the P)rinter or to the S)creen, and they may be U)nsorted or  å
æ sorted by customer C)ode or N)ame.                            å

æ For further comments, read through this source code.          å


LABEL stop;

CONST

æ Data record size definition å

  crsize = 342;         æ Customer record size å

æ PolyFile constants å

  maxrsize = crsize;    æ Max record size å
  maxksize = 25;        æ Max key size å
  nodesize = 16;        æ Node size å
  nodehalf = 8;         æ Half node size å
  nbufsize = 5;         æ Node buffer size å
  maxdepth = 5;         æ Max index depth å

æ Include PolyFile modules å

æ$I DATMANå
æ$I NPFKEYå
æ$I ADDKEYå
æ$I DELKEYå

TYPE

æ Various string types å

  str5 = STRINGÆ5Å;
  str10 = STRINGÆ10Å;
  str15 = STRINGÆ15Å;
  str25 = STRINGÆ25Å;
  str80 = STRINGÆ80Å;
  anystr = STRINGÆ255Å;

æ Character set type å

  charset = SET OF char;

æ Customer record definition å

  custrec = RECORD
              status: integer;       æ Status å
              ccode: STRINGÆ15Å;     æ Customer code å
              cdate: STRINGÆ8Å;      æ Entry date å
              fname: STRINGÆ15Å;     æ First name å
              lname: STRINGÆ30Å;     æ Last name å
              cmpny: STRINGÆ40Å;     æ Company å
              addr1: STRINGÆ40Å;     æ Address 1 å
              addr2: STRINGÆ40Å;     æ Address 2 å
              phone: STRINGÆ15Å;     æ Phone number å
              pextn: STRINGÆ5Å;      æ Extension å
              rmrk1: STRINGÆ40Å;     æ Remarks 1 å
              rmrk2: STRINGÆ40Å;     æ Remarks 2 å
              rmrk3: STRINGÆ40Å;     æ Ramarks 3 å
            END;

VAR

æ Global variables å

  datf: datafile;
  idxc,idxn: indexfile;
  ch: char;

æ CAP converts a character to upper case å

FUNCTION cap(ch: char): char;
BEGIN
  IF (ch>='a') AND (ch<='z') THEN
  cap:=chr(ord(ch)-32) ELSE cap:=ch;
END;

æ CPAS converts a string to upper case å

FUNCTION caps(s: str80): str80;
VAR
  p: integer;
BEGIN
  FOR p:=1 TO len(s) DO sÆpÅ:=cap(sÆpÅ);
  caps:=s;
END;

æ CSTR returns a string with N characters of value C å

FUNCTION cstr(c: char; n: integer): str80;
VAR
  s: STRINGÆ80Å;
BEGIN
  IF n<0 THEN n:=0; sÆ0Å:=chr(n); fill(sÆ1Å,n,c);
  cstr:=s;
END;

æ BEEP sounds the terminal's bell or beeper å

PROCEDURE beep;
BEGIN
  write(^G);
END;

æ INPSTR is a generalized string input routine which supports   å
æ on-screen editing. S is any string variable. L is the maximum å
æ input length. X and Y are the display coordinates. TERM is a  å
æ set of valid terminator characters, and TC returns the char-  å
æ acter that terminated the input. On entry, S is displayed at  å
æ X,Y on the screen, padded to the right with underscores. The  å
æ string may then be edited using standard control keys: ^S and å
æ ^D for left and right, ^A and ^F for beginning and end of     å
æ line, ^G to delete the character under the cursor, ^H or DEL  å
æ to backspace, and ^Y to delete to end of the line. When a     å
æ character is typed, it is inserted at the cursor at the re-   å
æ mainder of the line is moved to the right. When a terminator  å
æ character is typed, the trailing underscors are removed, and  å
æ INPSTR returns with the edited string in S and the terminator å
æ character in TC.                                              å

PROCEDURE inpstr(VAR s: anystr; l,x,y: integer;
  term: charset; VAR tc: char);
CONST
  fc = '_';
VAR
  p: integer;
  ch: char;
BEGIN
  gotoxy(x,y); write(s,cstr(fc,l-len(s))); p:=0;
  REPEAT
    gotoxy(x+p,y); read(kbd,ch);
    CASE ch OF
      @32..@126:
      IF p<l THEN
      BEGIN
        IF len(s)=l THEN delete(s,l,1);
        p:=p+1; insert(ch,s,p);
        write(copy(s,p,l));
      END ELSE beep;
      ^S: IF p>0 THEN p:=p-1 ELSE beep;
      ^D: IF p<len(s) THEN p:=p+1 ELSE beep;
      ^A: p:=0;
      ^F: p:=len(s);
      ^G:
      IF p<len(s) THEN
      BEGIN
        delete(s,p+1,1); write(copy(s,p+1,l),fc);
      END;
      ^H,@127:
      IF p>0 THEN
      BEGIN
        delete(s,p,1); write(^H,copy(s,p,l),fc); p:=p-1;
      END ELSE beep;
      ^Y:
      BEGIN
        write(cstr(fc,len(s)-p)); delete(s,p+1,l);
      END;
    OTHERWISE
      IF NOT(ch IN term) THEN beep;
    END;
  UNTIL ch IN term;
  p:=len(s); gotoxy(x+p,y); write('':l-p);
  tc:=ch;
END;

æ SELECT display the prompt string PR on line 22, and waits     å
æ until the user enters a character which is contained in the   å
æ TERM character set. The character is then returned in TC.     å

PROCEDURE select(pr: str80; term: charset; VAR tc: char);
VAR
  ch: char;
BEGIN
  gotoxy(0,22); write(pr,'? ',clreol);
  REPEAT
    read(kbd,ch); tc:=cap(ch);
    IF NOT(tc IN term) THEN beep;
  UNTIL tc IN term;
  write(ch);
END;

æ CLRFRAME clears the display frame, i.e. lines 3 to 20 å

PROCEDURE clrframe;
VAR
  i: integer;
BEGIN
  FOR i:=3 TO 20 DO
  BEGIN
    gotoxy(0,i); write(clreol);
  END;
END;

æ OUTFORM displays the entry form on the screen å

PROCEDURE outform;
BEGIN
  gotoxy(6,4); write('Code:');
  gotoxy(28,4); write('Date:');
  gotoxy(0,6); write('First Name:');
  gotoxy(28,6); write('Last Name:');
  gotoxy(3,8); write('Company:');
  gotoxy(1,9); write('Address 1:');
  gotoxy(1,10); write('Address 2:');
  gotoxy(5,12); write('Phone:');
  gotoxy(28,12); write('Extension:');
  gotoxy(1,14); write('Remarks 1:');
  gotoxy(1,15); write('Remarks 2:');
  gotoxy(1,16); write('Remarks 3:');
END;

æ CLRFORM clears all fields in the entry form å

PROCEDURE clrform;
BEGIN
  gotoxy(12,4); write('':15); gotoxy(34,4); write(clreol);
  gotoxy(12,6); write('':15); gotoxy(39,6); write(clreol);
  gotoxy(12,8); write(clreol); gotoxy(12,9); write(clreol);
  gotoxy(12,10); write(clreol); gotoxy(12,12); write('':15);
  gotoxy(39,12); write(clreol); gotoxy(12,14); write(clreol);
  gotoxy(12,15); write(clreol); gotoxy(12,16); write(clreol);
END;

æ INPCUST is used for inputting customer records. The routine   å
æ assumes that the entry form is already displayed and filled   å
æ in with the default data contained in CUSTREC. Apart from the å
æ control characters supported by INPSTR, the user may type ^E  å
æ to move to the previous field, RETURN, ^I or ^X to move to    å
æ the next field. INPCUST returns when the user types ^Z or     å
æ RETURN when the cursor is in the last field.                  å

PROCEDURE inpcust(VAR cust: custrec);
CONST
  term: charset = Æ^E,^I,^M,^X,^ZÅ;
VAR
  l: integer;
  tc: char;
BEGIN
  l:=1;
  WITH cust DO
  REPEAT
    CASE l OF
      1: inpstr(ccode,15,12,4,term,tc);
      2: inpstr(cdate,8,34,4,term,tc);
      3: inpstr(fname,15,12,6,term,tc);
      4: inpstr(lname,30,39,6,term,tc);
      5: inpstr(cmpny,40,12,8,term,tc);
      6: inpstr(addr1,30,12,9,term,tc);
      7: inpstr(addr2,30,12,10,term,tc);
      8: inpstr(phone,15,12,12,term,tc);
      9: inpstr(pextn,5,39,12,term,tc);
      10: inpstr(rmrk1,40,12,14,term,tc);
      11: inpstr(rmrk2,40,12,15,term,tc);
      12: inpstr(rmrk3,40,12,16,term,tc);
    END;
    IF (tc=^I) OR (tc=^M) OR (tc=^X) THEN
    IF l=12 THEN l:=1 ELSE l:=l+1 ELSE
    IF tc=^E THEN
    IF l=1 THEN l:=12 ELSE l:=l-1;
  UNTIL (tc=^M) AND (l=1) OR (tc=^Z);
END;

æ OUTCUST displays the customer data contained in CUST å

PROCEDURE outcust(VAR cust: custrec);
BEGIN
  WITH cust DO
  BEGIN
    gotoxy(12,4); write(ccode,'':15-len(ccode));
    gotoxy(34,4); write(cdate,clreol);
    gotoxy(12,6); write(fname,'':15-len(fname));
    gotoxy(39,6); write(lname,clreol);
    gotoxy(12,8); write(cmpny,clreol);
    gotoxy(12,9); write(addr1,clreol);
    gotoxy(12,10); write(addr2,clreol);
    gotoxy(12,12); write(phone,'':15-len(phone));
    gotoxy(39,12); write(pextn,clreol);
    gotoxy(12,14); write(rmrk1,clreol);
    gotoxy(12,15); write(rmrk2,clreol);
    gotoxy(12,16); write(rmrk3,clreol);
  END;
END;

æ KEYN converts a last name and a first name to a key string.   å
æ The key string consists of the first 15 characters of the     å
æ last name (padded with blanks if required) followed by the    å
æ first 10 characters of the first name.                        å

FUNCTION keyn(ln: str15; fn: str10): str25;
CONST
  blanks = '               ';
BEGIN
  keyn:=caps(ln)+copy(blanks,1,15-len(ln))+caps(fn);
END;

æ UPDATE is used to update the data base å

PROCEDURE update;
VAR
  ch: char;

æ ADD is used to add customers å

PROCEDURE add;
VAR
  d: integer;
  cc: STRINGÆ15Å;
  kn: STRINGÆ25Å;
  cust: custrec;
BEGIN
  WITH cust DO
  BEGIN
    fill(cust,size(cust),0);
    REPEAT
      inpcust(cust); cc:=ccode; findkey(idxc,d,cc);
      IF ok THEN
      BEGIN
        gotoxy(5,18);
        write('ERROR: DUPLICATE CUSTOMER CODE'); beep;
      END;
    UNTIL NOT ok;
    addrec(datf,d,cust); addkey(idxc,d,ccode);
    kn:=keyn(lname,fname); addkey(idxn,d,kn);
    gotoxy(5,18); write(clreol);
  END;
END;

æ FIND is used to find, edit and delete customers å

PROCEDURE find;
VAR
  d,l,i: integer;
  ch,tc: char;
  cc,pc,fn: STRINGÆ15Å;
  kn,pn: STRINGÆ25Å;
  ln: STRINGÆ30Å;
  cust: custrec;
BEGIN
  IF usedrecs(datf)>0 THEN
  BEGIN
    cc:='';
    REPEAT
      inpstr(cc,15,12,4,Æ^M,^ZÅ,tc);
      IF cc<>'' THEN
      BEGIN
        findkey(idxc,d,cc);
        IF ok THEN
        BEGIN
          getrec(datf,d,cust); outcust(cust);
        END ELSE
        BEGIN
          gotoxy(5,18);
          write('ERROR: CUSTOMER CODE NOT FOUND'); beep;
        END;
      END;
    UNTIL ok OR (cc='');
    gotoxy(5,18); write(clreol);
    IF cc='' THEN
    BEGIN
      l:=1; fn:=''; ln:='';
      REPEAT
        CASE l OF
          1: inpstr(fn,15,12,6,Æ^I,^M,^ZÅ,tc);
          2: inpstr(ln,30,39,6,Æ^I,^M,^ZÅ,tc);
        END;
        IF (tc=^I) OR (tc=^M) THEN l:=3-l;
      UNTIL (tc=^M) AND (l=1) OR (tc=^Z);
      kn:=keyn(ln,fn); searchkey(idxn,d,kn);
      IF NOT ok THEN prevkey(idxn,d,kn);
      REPEAT
        getrec(datf,d,cust); outcust(cust);
        select('Find: N)ext, P)revious, Q)uit',Æ'N','P','Q'Å,ch);
        CASE ch OF
          'N': REPEAT nextkey(idxn,d,kn) UNTIL ok;
          'P': REPEAT prevkey(idxn,d,kn) UNTIL ok;
        END;
      UNTIL ch='Q';
    END;
    select('Find: E)dit, D)elete, Q)uit',Æ'E','D','Q'Å,ch);
    WITH cust DO
    CASE ch OF
      'E':
      BEGIN
        pc:=ccode; pn:=keyn(lname,fname);
        REPEAT
          inpcust(cust);
          IF ccode=pc THEN ok:=false ELSE
          BEGIN
            cc:=ccode; findkey(idxc,i,cc); IF ok THEN beep;
          END;
        UNTIL NOT ok;
        putrec(datf,d,cust);
        IF ccode<>pc THEN
        BEGIN
          deletekey(idxc,d,pc); addkey(idxc,d,ccode);
        END;
        kn:=keyn(lname,fname);
        IF kn<>pn THEN
        BEGIN
          deletekey(idxn,d,pn); addkey(idxn,d,kn);
        END;
      END;
      'D':
      BEGIN
        deletekey(idxc,d,ccode);
        kn:=keyn(lname,fname); deletekey(idxn,d,kn);
        deleterec(datf,d);
      END;
    END;
  END ELSE beep;
END;

BEGIN æUPDATEå
  outform;
  REPEAT
    select('Update: A)dd, F)ind, Q)uit',Æ'A','F','Q'Å,ch);
    CASE ch OF
      'A': add;
      'F': find;
    END;
    IF ch<>'Q' THEN
    BEGIN
      gotoxy(59,1); write(usedrecs(datf):5); clrform;
    END;
  UNTIL ch='Q';
END;

æ LIST is used to list customers å

PROCEDURE list;
LABEL escape;
VAR
  d,l,ld: integer;
  ch,co,cs: char;
  cc: STRINGÆ15Å;
  kn: STRINGÆ25Å;
  name: STRINGÆ35Å;
  cust: custrec;
BEGIN
  select('Output Device: P)rinter, S)creen',Æ'P','S'Å,co);
  select('Sort By: C)ode, N)ame, U)nsorted',Æ'C','N','U'Å,cs);
  gotoxy(0,22); write('Press <ESC> to abort',clreol);
  clearkey(idxc);
  clearkey(idxn);
  d:=0; ld:=filelen(datf)-1; l:=3;
  REPEAT
    IF keypress THEN
    BEGIN
      read(kbd,ch); IF ch=@27 THEN GOTO escape;
    END;
    CASE cs OF
      'C': nextkey(idxc,d,cc);
      'N': nextkey(idxn,d,kn);
      'U':
      BEGIN
        ok:=false;
        WHILE (d<ld) AND NOT ok DO
        BEGIN
          d:=d+1; getrec(datf,d,cust);
          ok:=cust.status=0;
        END;
      END;
    END;
    IF ok THEN WITH cust DO
    BEGIN
      IF cs<>'U' THEN getrec(datf,d,cust);
      name:=lname;
      IF fname<>'' THEN name:=name+', '+fname;
      IF co='P' THEN
      BEGIN
        write(lst,ccode,'':16-len(ccode));
        write(lst,name,'':36-len(name));
        writeln(lst,copy(cmpny,1,25));
      END ELSE
      BEGIN
        IF l=21 THEN
        BEGIN
          gotoxy(0,22);
          write('Press <RETURN> to continue or <ESC> to abort',clreol);
          REPEAT read(kbd,ch) UNTIL (ch=^M) OR (ch=@27);
          IF ch=@27 THEN GOTO escape;
          gotoxy(0,22); write('Press <ESC> to abort',clreol);
          clrframe; l:=3;
        END;
        gotoxy(0,l); write(ccode);
        gotoxy(16,l); write(name);
        gotoxy(52,l); write(copy(cmpny,1,25));
        l:=l+1;
      END;
    END;
  UNTIL NOT ok;
  IF co='S' THEN
  BEGIN
    gotoxy(0,22); write('Press <RETURN>',clreol);
    REPEAT read(kbd,ch) UNTIL ch=^M;
  END;
  escape:
END;

æ Main program å

BEGIN
  writeln(clrhom,cstr('-',79));
  writeln('PolyFile Customer Data Base');
  writeln(cstr('-',79));
  gotoxy(0,21); writeln(cstr('-',79));
  writeln; write(cstr('-',79)); gotoxy(0,3);
  initindex;
  openfile(datf,'CUST.DAT',crsize);
  IF ok THEN openindex(idxc,'CUST.IXC',15,0);
  IF ok THEN openindex(idxn,'CUST.IXN',25,1);
  IF NOT ok THEN
  BEGIN
    select('Data files missing. Create new files (Y/N)',Æ'Y','N'Å,ch);
    IF ch='Y' THEN
    BEGIN
      makefile(datf,'CUST.DAT',crsize);
      makeindex(idxc,'CUST.IXC',15,0);
      makeindex(idxn,'CUST.IXN',25,1);
    END ELSE
    GOTO stop;
  END;
  gotoxy(59,1); write(usedrecs(datf):5,' Records In Use');
  REPEAT
    select('Select: U)pdate, L)ist, Q)uit',Æ'U','L','Q'Å,ch);
    CASE ch OF
      'U': update;
      'L': list;
    END;
    IF ch<>'Q' THEN clrframe;
  UNTIL ch='Q';
  closefile(datf);
  closeindex(idxc);
  closeindex(idxn);
  stop:
  write(clrhom);
END.
«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»«nul»
DataMuseum.dk

CP/M

⟦f73c998f3⟧ TextFile

Derivation

TextFile
