ftp.barnyard.co.uk/2015.02.ftp.barnyard.co.uk.tar/ftp.barnyard.co.uk/cpm/walnut-creek-CDROM/CPM/TURBOPAS/TP/UTL3/INDEXBPP.PZS/INDEXBPP.PAS

Pascal/Delphi Source File | 2000-06-30 | 16KB | 590 lines

{$V-}
program FileIndex;

const
  IndexMax          = 1000;
  RecCountErr       =   -2;
  NewFileCreated    =   -1;
  NoError           =    0;
  RecordNotFound    =    1;
  NoMoreRoom        =    2;
  AlreadyExists     =    3;
  OutOfRange        =    4;

type

  Keytype      = string[40];
  FileStr      = string[80];
  Whatever     = string[12];

  DataRec = record
    case Boolean of
      True     : (NumRecs     : Integer);
      False    : (Key         : Keytype;
                  theRest     : Whatever);
  end;

  IndexRec = record
    Key        : Keytype;
    Num        : Integer
  end;

  IndexList    = array[1..IndexMax] of IndexRec;

var
  KList        : IndexList;
  DFile        : file of DataRec;
  MaxRec       : Integer;

{            compiler-specific file I/O routines                  }
{      these procedures are specific to TURBO Pascal.  If you
       are using another Pascal compiler, you will need to
       modify them appropriately.  Note that TURBO Pascal does
       not support the standard routines GET and PUT, but instead
       uses READ and WRITE.                                       }

{$I-} { turn off I/O error checking }

procedure FRead(RNum : Integer; var Rec : DataRec; var Error : Integer);
{
     reads record #RNum into Rec
}
begin
  if (RNum < 0) or (RNum > MaxRec)
    then Error := OutOfRange
  else begin
    Seek(DFile,RNum);
    Read(DFile,Rec);
    Error := IOResult;
    if Error > 0
      then Error := 100 + Error
  end
end; { of proc FRead }

procedure FWrite(RNum : Integer; Rec : DataRec; var Error : Integer);
{
     writes record #RNum into Rec
}
begin
  if (RNum < 0) or (RNum > MaxRec)
    then Error := OutOfRange
  else begin
    Seek(DFile,RNum);
    Write(DFile,Rec);
    Error := IOResult;
    if Error > 0
      then Error := 100 + Error
  end
end; { of proc FRead }

procedure FOpen(FileName : FileStr; var Error : Integer);
{
       tries to open FileName; if it doesn't exist, creates
       it with the appropriate header record
}
const
  TurboNoFile  =  1; { "no file" error code for TURBO Pascal }
  NoIOError    =  0;
var
  IOCode       : Integer;
  TRec         : DataRec;
begin
  Assign(DFile,FileName);
  Reset(DFile);
  IOCode := IOResult;
  if IOCode = TurboNoFile then begin { file doesn't exist }
    FillChar(TRec,SizeOf(TRec),0);
    Rewrite(DFile);
    TRec.NumRecs := 0;
    Write(DFile,TRec);
    Close(DFile);
    Assign(DFile,Filename);
    Reset(DFile);
    IOCode := IOResult;
    if IOCode = NoIOError
      then Error := NewFileCreated
  end;
  if IOCode <> NoIOError
    then Error := 100 + IOCode;
end; { of proc FOpen }

procedure FClose(var Error : Integer);
{
       closes file
}
begin
  Close(DFile);
  Error := IOResult;
  if Error > 0
    then Error := Error + 100
end; { of proc FClose }

{$I+} { turn on I/O error checking }

{               initialization and cleanup routines                  }

procedure SortIndexList;
{
     sorts the array KList using a selection sort technique
}
var
  I,J,Min      : Integer;
  Temp         : IndexRec;
begin
  for I := 1 to MaxRec-1 do begin
    Min := I;
    for J := I+1 to MaxRec do
      if KList[J].Key < KList[Min].Key
        then Min := J;
    Temp := KList[I];
    KList[I] := KList[Min];
    KList[Min] := Temp
  end
end; { of proc SortIndexList }

procedure InitStuff(FileName : FileStr; var Error : Integer);
{
     sets everything up for indexing system.  This assumes that
     there are no more than IndexMax (=1000) records, and that the
     records are numbered 1..IndexMax.  Record #0 is the header
     record and is used to store the current number of records
     actively being used in the file
}
var
  Indx,TErr           : Integer;
  TRec                : DataRec;
begin
  Error := NoError;
  FOpen(FileName,Error);
  if Error <= NoError then begin
    MaxRec := 0;
    FRead(0,TRec,TErr);
    Error := TErr;
    MaxRec := TRec.NumRecs;
    for Indx := 1 to MaxRec do begin
      FRead(Indx,TRec,TErr);
      if TErr > 0
        then Error := TErr;
      KList[Indx].Key := TRec.Key;
      KList[Indx].Num := Indx
    end;
    SortIndexList
  end
end; { of proc InitStuff }

procedure CleanUpStuff(var Error : Integer);
{
     this just does an orderly shutdown and should be called
     before you leave your program (or open another data file)
}
var
  TRec                : DataRec;
begin
  TRec.NumRecs := MaxRec; { save out # of records }
  FWrite(0,TRec,Error);
  FClose(Error)
end; { of proc CleanUpStuff }

function FindKey(Key : Keytype) : Integer;
{
     looks for Key in KList; returns location in KList
     if found; otherwise returns - 1
}
var
  L,R,Mid      : Integer;
begin
  L := 1; R := MaxRec;
  repeat
    Mid := (L+R) div 2;
    if Key < KList[Mid].Key
      then R := Mid-1
      else L := Mid+1
  until (Key = KList[Mid].Key) or (L > R);
  if Key = KList[Mid].Key
    then FindKey := Mid
    else FindKey :=  -1
end; { of proc FindKey }

procedure GetRecord(Key : Keytype; var Rec : DataRec;
                    var Error : Integer);
{
     looks through KList for Key; if found, returns in Rec.
     It and the routines that follow assume the procedure Seek
     for random access of the file of records.
}
var
  Item                : Integer;
begin
  Error := NoError;
  Item := FindKey(Key);
  if Item > 0
    then FRead(KList[Item].Num,Rec,Error)
    else Error := RecordNotFound
end; { of proc GetRecord }

procedure PutRecord(Rec : DataRec; var Error : Integer);
{
     writes Rec out to the file.  If a record with that
     key already exists, then overwrites that record;
     otherwise, adds the record to the end of the file.
     If there's no more room for records, exits with an
     error code
}
var
  Item         : Integer;
begin
  Error := NoError;
  Item := FindKey(Rec.Key);
  if Item >= 0
    then FWrite(KList[Item].Num,Rec,Error)
  else if MaxRec < IndexMax then begin
    MaxRec := MaxRec + 1;
    FWrite(MaxRec,Rec,Error);
    KList[MaxRec].Key := Rec.Key;
    KList[MaxRec].Num := MaxRec;
    SortIndexList
  end
  else Error := NoMoreRoom
end; { of proc PutRecord }

procedure AddRecord(Rec : DataRec; var Error : Integer);
{
     adds a record to the file.  If a record with the same
     key already exists, then exits with an error code
}
var
  Item         : Integer;
begin
  Error := NoError;
  Item := FindKey(Rec.Key);
  if Item > 0
    then Error := AlreadyExists
    else PutRecord(Rec,Error)
end; { of proc AddRecord }

procedure DeleteRecord(Key : Keytype; var Error : Integer);
{
     deletes the record with 'Key' by copying the last record
     in the file to that slot, then modifies KList by shuffling
     all the key entries up
}
var
  Item,Last,Max,MVal     : Integer;
  TRec                   : DataRec;
begin
  Error := NoError;
  Item := FindKey(Key);
  if Item = -1
    then Error := RecordNotFound
  else begin
    Max := 1; MVal := KList[Max].Num;
    for Last := 2 to MaxRec do
      if KList[Last].Num > MVal then begin
        Max := Last; MVal := KList[Last].Num
      end;
    if Max <> Item then begin
      FRead(MVal,TRec,Error);             { get last record in file }
      FWrite(KList[Item].Num,TRec,Error); { write over it }
      KList[Max].Num := KList[Item].Num
    end;
    for Last := Item to MaxRec-1 do     { delete KList[Item] }
      KList[Last] := KList[Last+1];
    MaxRec := MaxRec - 1                { adjust # of records }
  end
end; { of proc DeleteRecord }

{                         USERIO.LIB

                 procedure and functions in this library

  WriteStr           write message out at (Col,Line)
  Error              writes message out at (1,1), waits for character
  GetChar            prompt user for one of a set of characters
  Yes                gets Y/N answer from user
  GetString          prompt user for a string
  IOCheck            checks for I/O error; prints message if necessary

}

type
  MsgStr             = string[80];
  CharSet            = set of Char;

var
  IOErr              : Boolean;
  IOCode             : Integer;

procedure WriteStr(Col,Line : Integer; TStr : MsgStr);
{
       purpose       writes message out at spot indicated
       last update   23 Jun 85
}
begin
  GoToXY(Col,Line); ClrEol;
  Write(TStr)
end; { of proc WriteStr }

procedure Error(Msg : MsgStr);
{
       purpose       writes error message out at (1,1); waits for character
       last update   05 Jul 85
}
const
  Bell               = ^G;
var
  Ch                 : Char;
begin
  WriteStr(1,1,Msg+Bell+' (hit any key) ');
  Read(Kbd,Ch)
end; { of proc Error }

procedure GetChar(var Ch : Char; Prompt : MsgStr; OKSet : CharSet);
{
       purpose       let user enter command
       last update   23 Jun 85
}
begin
  WriteStr(1,1,Prompt);
  repeat
    Read(Kbd,Ch);
    Ch := UpCase(Ch)
  until Ch in OKSet;
  WriteLn(Ch)
end; { of proc GetChar }

function Yes(Question : MsgStr) : Boolean;
{
       purpose       asks user Y/N question
       last update   03 Jul 85
}
var
  Ch                 : Char;
begin
  GetChar(Ch,Question+' (Y/N) ',['Y','N']);
  Yes := (Ch = 'Y')
end; { of func Yes }

procedure GetString(var NStr : MsgStr; Prompt : MsgStr; MaxLen : Integer;
                    OKSet : CharSet);
{
       purpose       get string from user
       last update   09 Jul 85
}
const
  BS                 = ^H;
  CR                 = ^M;
  ConSet             : CharSet = [BS,CR];
var
  TStr               : MsgStr;
  TLen,X             : Integer;
  Ch                 : Char;
begin
  {$I-} { turn off I/O checking }
  TStr := '';
  TLen := 0;
  WriteStr(1,1,Prompt);
  X := 1 + Length(Prompt);
  OKSet := OKSet + ConSet;
  repeat
    GoToXY(X,1);
    repeat
      Read(Kbd,Ch)
    until Ch in OKSet;
    if Ch = BS then begin
      if TLen > 0 then begin
        TLen := TLen - 1;
        X := X - 1;
        GoToXY(X,1); Write(' ');
      end
    end
    else if (Ch <> CR) and (TLen < MaxLen) then begin
      Write(Ch);
      TLen := TLen + 1;
      TStr[TLen] := Ch;
      X := X + 1;
    end
  until Ch = CR;
  if TLen > 0 then begin
    TStr[0] := Chr(TLen);
    NStr := TStr
  end
  else Write(NStr)
  {$I+}
end; { of proc GetString }

procedure IOCheck(IOCode : Integer);
{
       purpose       check for IO error; print message if needed
       last update   19 Feb 86
}
var
  TStr               : string[4];
begin
  IOErr  := (IOCode <> 0);
  if IOErr then case IOCode of
    $01  : Error('IOERROR> File does not exist');
    $02  : Error('IOERROR> File not open for input');
    $03  : Error('IOERROR> File not open for output');
    $04  : Error('IOERROR> File not open');
    $10  : Error('IOERROR> Error in numeric format');
    $20  : Error('IOERROR> Operation not allowed on logical device');
    $21  : Error('IOERROR> Not allowed in direct mode');
    $22  : Error('IOERROR> Assign to standard files not allowed');
    $90  : Error('IOERROR> Record length mismatch');
    $91  : Error('IOERROR> Seek beyond end of file');
    $99  : Error('IOERROR> Unexpected end of file');
    $F0  : Error('IOERROR> Disk write error');
    $F1  : Error('IOERROR> Directory is full');
    $F2  : Error('IOERROR> File size overflow');
    $FF  : Error('IOERROR> File disappeared')
    else   Str(IOCode:3,TStr);
           Error('IOERROR> Unknown I/O error:  '+TStr)
  end
end; { of proc IOCheck }


{              declarations and code for test program            }
const
  CmdPrompt           : MsgStr =
             'TEST> A)dd, D)elete, F)ind, L)ist, I)ndex, C)lose, Q(uit: ';
  FilePrompt          : MsgStr = 'TEST> Enter file name: ';
  DonePrompt          : MsgStr = 'TEST> Another file?';

  CmdSet              : CharSet = ['A','D','F','L','I','C','Q'];
  NameSet             : CharSet = [' '..'~'];
  PhoneSet            : CharSet = ['0'..'9','-','/','(',')'];

var
  Cmd                 : Char;
  ErrVal              : Integer;
  FileName            : FileStr;
  Done                : Boolean;


procedure FileError(ErrVal : Integer);
begin
  if ErrVal < 100 then case ErrVal of
    RecCountErr       : Error('Record count mismatch');
    NewFileCreated    : Error('Creating new file');
    RecordNotFound    : Error('Record not found');
    NoMoreRoom        : Error('No more room');
    AlreadyExists     : Error('Record already exists')
  end
  else begin
    IOCheck(ErrVal-100)
  end
end; { of proc FileError }

procedure DoAdd;
{
       purpose        add a record to the file
       last update    19 Feb 86
}
var
  TStr                : MsgStr;
  TRec                : DataRec;
begin
  FillChar(TRec,SizeOf(TRec),0);
  with TRec do begin
    TStr := '';
    GetString(TStr,'ADD> Enter name:  ',40,NameSet);
    if TStr <> '' then begin
      Key := TStr;  TStr := '';
      GetString(TStr,'ADD> Enter phone #: ',12,PhoneSet);
      theRest := TStr;
      AddRecord(TRec,ErrVal);
      Flush(DFile);
      FileError(ErrVal)
    end
  end;
end; { of proc DoAdd }

procedure DoDelete;
{
       purpose        delete a record from the file
       last update    19 Feb 86
}
var
  Key                 : Keytype;
begin
  GetString(Key,'DELETE> Enter name:  ',40,NameSet);
  DeleteRecord(Key,ErrVal);
  FileError(ErrVal)
end; { of proc DoDelete }

procedure DoFind;
{
       purpose        find a record in the file
       last update    19 Feb 86
}
var
  Key                 : Keytype;
  TRec                : DataRec;
begin
  GetString(Key,'FIND> Enter name:  ',40,NameSet);
  GetRecord(Key,TRec,ErrVal);
  if ErrVal = NoError then begin
    WriteStr(1,2,'The phone number is ');
    Writeln(TRec.theRest)
  end
  else FileError(ErrVal)
end; { of proc DoDelete }

procedure DoList;
{
       purpose        list out contents of the file
       last update    19 Feb 86
}
var
  TRec                : DataRec;
  Indx                : Integer;
begin
  ClrScr; Writeln;
  for Indx := 1 to MaxRec do with KList[Indx] do begin
    WriteStr(1,Indx+1,Key); Write(' ':(45-Length(Key)));
    GetRecord(Key,TRec,ErrVal);
    if ErrVal = NoError then with TRec do
      Writeln(theRest)
    else FileError(ErrVal)
  end
end; { of proc DoList }

procedure ShowIndex;
{
       purpose        list out contents of the key list
       last update    19 Feb 86
}
var
  Indx                : Integer;
begin
  ClrScr; Writeln;
  for Indx := 1 to MaxRec do with KList[Indx] do
    Writeln(Key,' ':(45-Length(Key)),Num:5)
end; { of proc DoList }

begin
  repeat
    Done := False;
    ClrScr;
    GetString(FileName,FilePrompt,80,NameSet);
    InitStuff(FileName,ErrVal);
    FileError(ErrVal);
    repeat
      GetChar(Cmd,CmdPrompt,CmdSet);
      case Cmd of
        'A'    : DoAdd;
        'D'    : DoDelete;
        'F'    : DoFind;
        'L'    : DoList;
        'I'    : ShowIndex;
        'Q'    : Done := True
      end
    until (Cmd = 'C') or Done;
    CleanUpStuff(ErrVal);
    FileError(ErrVal);
    ClrScr;
    if not Done
      then Done := not Yes(DonePrompt)
  until Done
end. { of program TestIndex }