DataMuseum.dk

top - download

    Length: 17408 (0x4400)
    Types: TextFile
    Names: »DATABASE.PAS«

└─⟦c96461903⟧ Bits:30002787 SW1602 COMPAS Pascal Version 3.07 Release 1.1
    └─ ⟦this⟧ »DATABASE.PAS« 

TextFile

PROGRAM DATABASE; (*$A+,C-,R-,V-*)


(****************************************************************)
(*                                                              *)
(*                     C-FILE Version 1.00                      *)
(*                                                              *)
(*                       DATABASE Example                       *)
(*                                                              *)
(*                    Copyright (C) 1984 by                     *)
(*                  Poly-Data microcenter ApS                   *)
(*                                                              *)
(****************************************************************)


(* DATABASE demonstrates how to use C-FILE to create and main-  *)
(* tain a simple customer data base. DATABASE allows you to     *)
(* add, find, view, edit, delete and list customers of a pre-   *)
(* defined 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     *)
(* customer code or by last (and first) name. To search for a   *)
(* specific customer code, simply enter it when the cursor      *)
(* moves to the customer code field. If it is found, the custo- *)
(* mer'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 backwards 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 *)

(* C-FILE 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 C-FILE 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 maxi-  *)
(* mum input length. X and Y are the display coordinates. TERM  *)
(* is a set of valid terminator characters, and TC returns the  *)
(* character that terminated the input. On entry, S is display- *)
(* ed at X,Y on the screen, padded to the right with undersco-  *)
(* res. 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 cur-   *)
(* sor, ^H or DEL to backspace, and ^Y to delete to end of the  *)
(* line. When a character is typed, it is inserted at the cur-  *)
(* sor at the remainder 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('C-FILE 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.
«eof»