Power-Programmierung/CD1.mdf/pascal/library/dos/nicol/sti_dbas/sti_db1.pas

Pascal/Delphi Source File | 1980-01-01 | 31.5 KB | 1,100 lines

program STI_DB1;

Uses Crt,Dos;


Const
  STI_DB_VLOB           =  1;               { field type for VLOBS          }
  STI_DB_DATE           =  2;
  STI_DB_TIME           =  3;
  STI_DB_BYTE           =  4;
  STI_DB_CHAR           =  5;
  STI_DB_STRING         =  6;
  STI_DB_INTEGER        =  7;
  STI_DB_WORD           =  8;
  STI_DB_REAL           =  9;
  STI_DB_SOUND          =  10;
  STI_DB_TEXT           =  11;
  STI_DB_IMAGE          =  12;


  VLOB_BLOCK_SIZE       =  128;             { very large object block       }
  MAX_REC_LEN           =  5120;            { maximum record size           }
  MAX_FIELDS            =  255;             { maximum number of fields      }
  FIELD_DESC_LEN        =  10;              { length of field desciptor     }
  MAX_HEAD_LEN          =  4000;            { maximum header length         }
  MAX_FILES             =  5;               { maximum nuber of files        }

  STI_DB_NOT_OPEN       =  1;               { file states : unopened        }
  STI_DB_NOT_UPDATED    =  2;               { opened : not updated          }
  STI_DB_UPDATED        =  3;               { opened : updated              }
  STI_DB_LOCKED         =  4;               { access is locked              }
  STI_DB_ACCESS_OK      =  5;               { access is ok                  }

  STI_DB_ILLEGAL_FIELD  =  1;               { this is an illegal field      }
  STI_NOT_STI_DB_FILE   =  2;               { this is not an STI file       }
  STI_DB_ALREADY_OPEN   =  3;               { the file is already open      }
  STI_DB_ILLEGAL_FILE   =  4;               { not a legal file number       }
  STI_DB_BAD_FIELD_NUM  =  5;               { bot a legal field number      }
  STI_DB_BAD_RECORD_NUM =  6;               { illegal record number         }

  ASCEND                =  1;
  DESCEND               =  2;


Type
  STI_Sort = array[1..255] of byte;         { for sorting                   }
  STI_BDat = array[1..3] of byte;           { for binary dates              }
  STI_Ver  = array[1..2] of byte;           { for playing with version      }
  STI_VLOB = array[1..VLOB_BLOCK_SIZE] of byte; { one VLOB block            }
  STI_Rec  = array[1..MAX_REC_LEN] of char; { one record                    }
  STI_Date = string[8];                     { type for date                 }
  STIFDesc = string[FIELD_DESC_LEN];        { field descriptor              }

  STI_DBHead  =  record
                   Version    : word;       { hi byte = major, lo  = minor  }
                   With_VLOB  : boolean;    { does it have a VLOB field     }
                   LastUpDate : STI_BDat;   { YY MM DD (YY = 1960 + 1..255  }
                   RecNumber  : longint;    { 0..2147483647 records         }
                   RecordLen  : word;       { 65535 bytes or 255 * 255      }
                   FieldNum   : byte;       { 255 fields                    }
                   HeaderLen  : word;       { size of header                }
                 end;

   STI_DBField = record
                   Descriptor : STIFDesc;   { field descriptor              }
                   Length     : byte;       { 1..255 bytes in length        }
                   FieldType  : byte;       { type of this field            }
                   Offset     : word;       { offset in bytes in record     }
                 end;

   STI_DBFArr  = array[1..MAX_FIELDS] of STI_DBField; { array of fields     }

   STI_DBFile  = record
                   Name       : string;     { file name                     }
                   DataFile   : file;       { the input file                }
                   Header     : STI_DBHead; { the file header               }
                   Status     : byte;       { the file status               }
                   CurRecord  : longint;    { current record number         }
                   Fields     : ^STI_DBFArr;{ the field and desciptors      }
                   RecData    : ^STI_Rec;   { the current record            }
                 end;
   STI_DBFS = array[1..MAX_FILES] of STI_DBFile; { array of files           }

Var
  STI_DB_Error    : byte;                   { error types                   }
  STI_DB_IOStatus : integer;                { status of file IO             }
  STI_OK          : boolean;                { error flag                    }

  STI_DBFiles     : STI_DBFS;               { files for access              }
  STI_DBCurrent   : byte;                   { currently active file         }

{---------------------------------------------------------------------------}
{                                                                           }
{       ATOMIC PROCEDURES FOLLOW. BASIC I/O                                 }
{                                                                           }
{---------------------------------------------------------------------------}

procedure STI_DB_IOcheck(RecordNo : longint);

begin
  if STI_DB_IOstatus <> 0 then
    with STI_DBFiles[STI_DBCurrent] do
      begin
        Writeln;
        Writeln('STI_DB I/O error ',STI_DB_IOstatus);
        Write('File ');
        Writeln(Name);
        Writeln('- Record ',RecordNo);
        Writeln('- Program aborted');
        Halt;
      end;
end;

{---------------------------------------------------------------------------}

procedure STI_DB_ErrorCheck;

begin
  if not(STI_OK) then
    begin
      WriteLn;
      WriteLn('STI_DB Runtime Error ',STI_DB_Error);
      WriteLn('File ',STI_DBFiles[STI_DBCurrent].Name);
      WriteLn('- Record ',STI_DBFiles[STI_DBCurrent].CurRecord);
      WriteLn('- Program aborted');
      Halt;
    end;
end;

{---------------------------------------------------------------------------}

procedure STI_DBGetRec(RecordNo : longint);

begin
  Seek(STI_DBFiles[STI_DBCurrent].DataFile,
       STI_DBFiles[STI_DBCurrent].Header.HeaderLen+
       (RecordNo*STI_DBFiles[STI_DBCurrent].Header.RecordLen));
  STI_DB_IOstatus := IOresult;
  STI_DB_IOcheck(RecordNo);
  BlockRead(STI_DBFiles[STI_DBCurrent].DataFile,
            STI_DBFiles[STI_DBCurrent].RecData^,
            STI_DBFiles[STI_DBCurrent].Header.RecordLen);
  STI_DB_IOstatus := IOresult;
  STI_DB_IOcheck(RecordNo);
  STI_DBFiles[STI_DBCurrent].CurRecord := RecordNo;
  if STI_DBFiles[STI_DBCurrent].Header.RecNumber < RecordNo then
    STI_DBFiles[STI_DBCurrent].Header.RecNumber := RecordNo;
end;

{---------------------------------------------------------------------------}

procedure STI_DBPutRec(RecordNo : longint);

begin
  Seek(STI_DBFiles[STI_DBCurrent].DataFile,
       STI_DBFiles[STI_DBCurrent].Header.HeaderLen+
       (RecordNo*STI_DBFiles[STI_DBCurrent].Header.RecordLen));
  STI_DB_IOstatus := IOresult;
  STI_DB_IOcheck(RecordNo);
  BlockWrite(STI_DBFiles[STI_DBCurrent].DataFile,
            STI_DBFiles[STI_DBCurrent].RecData^,
            STI_DBFiles[STI_DBCurrent].Header.RecordLen);
  STI_DB_IOstatus := IOresult;
  STI_DB_IOcheck(RecordNo);
  STI_DBFiles[STI_DBCurrent].CurRecord := RecordNo;
  if STI_DBFiles[STI_DBCurrent].Header.RecNumber < RecordNo then
    STI_DBFiles[STI_DBCurrent].Header.RecNumber := RecordNo;
end;

{---------------------------------------------------------------------------}

procedure STI_DBPutRec2(RecordNo : longint; var Data; RecLen   : word);

begin
  if STI_DBFiles[STI_DBCurrent].Status = STI_DB_NOT_OPEN then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_NOT_OPEN;
    end;
  STI_DB_ErrorCheck;
  Move(Data,STI_DBFiles[STI_DBCurrent].RecData^[2],RecLen);
  STI_DBPutRec(RecordNo);
end;

{---------------------------------------------------------------------------}

procedure STI_DBGetRec2(RecordNo : longint; var Data; RecLen   : word);

begin
  if STI_DBFiles[STI_DBCurrent].Status = STI_DB_NOT_OPEN then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_NOT_OPEN;
    end;
  STI_DB_ErrorCheck;
  STI_DBGetRec(RecordNo);
  Move(STI_DBFiles[STI_DBCurrent].RecData^[2],Data,RecLen);
end;

{---------------------------------------------------------------------------}

procedure STI_DB_Check_Fields(Fields : STI_DBFArr; Num : byte);

Var
  Loop : byte;

begin
  for Loop := 1 to Num do
    begin
      if not(Fields[Loop].FieldType in[STI_DB_VLOB..STI_DB_IMAGE]) then
        begin
          STI_OK := FALSE;
          STI_DB_Error := STI_DB_ILLEGAL_FIELD;
        end;
    end;
end;

{---------------------------------------------------------------------------}

procedure STI_DBCreate(FileName : String; NumField : byte; Fields : STI_DBFArr);

Var
  Count,
  Loop,
  YEAR,MONTH,
  DAY,DOW      : word;
  InFile       : STI_DBFile;

begin
  if STI_DBFiles[STI_DBCurrent].Status <> STI_DB_NOT_OPEN then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_ALREADY_OPEN;
    end;
  STI_DB_ErrorCheck;
  Assign(InFile.DataFile,FileName);
  STI_DB_IOstatus := IOresult;
  STI_DB_IOcheck(0);
  Rewrite(InFile.DataFile,1);
  STI_DB_IOstatus := IOresult;
  if STI_DB_IOstatus = $F1 then
    STI_OK := FALSE
  else
    begin
      GetDate(YEAR,MONTH,DAY,DOW);
      STI_DB_IOcheck(0);
      with InFile.Header do
        begin
          STI_Ver(Version)[1]  := 1;
          STI_Ver(Version)[2]  := 0;
          LastUpDate[1]        := YEAR-1980;
          LastUpDate[2]        := MONTH;
          LastUpDate[3]        := DAY;
          RecNumber            := 0;
          RecordLen := 0;
          for Loop := 1 to NumField do
            begin
              Inc(RecordLen,Fields[Loop].Length);
            end;
          Inc(RecordLen);
          FieldNum  := NumField;
          HeaderLen := sizeof(STI_DBHead)+(sizeof(STI_DBField)*NumField);
          With_VLOB := FALSE;
          for Loop := 1 to NumField do
            begin
              if Fields[Loop].FieldType = STI_DB_VLOB then
                With_VLOB := TRUE;
            end;
        end;
      BlockWrite(InFile.DataFile,InFile.Header,sizeof(STI_DBHead));
      STI_OK := TRUE;
      STI_DB_Check_Fields(Fields,NumField);
      Count := 2;
      for Loop := 1 to NumField do
        begin
          Fields[Loop].OffSet := Count;
          BlockWrite(InFile.DataFile,Fields[Loop],sizeof(STI_DBField));
          Inc(Count,Fields[Loop].Length);
        end;
      GetMem(InFile.Fields,NumField*sizeof(STI_DBField));
      Move(Fields,InFile.Fields^,NumField*sizeof(STI_DBField));
      GetMem(InFile.RecData,InFile.Header.RecordLen);
      InFile.RecData^[1] := ' ';
      InFile.Name       := FileName;
      InFile.Status     := STI_DB_UPDATED;
      InFile.CurRecord  := 1;
   end;
  STI_DB_ErrorCheck;
  STI_DBFIles[STI_DBCurrent] := InFile;
end;

{---------------------------------------------------------------------------}

procedure STI_DBOpen(FileName : string);

Var
  Loop    : byte;
  InFile  : STI_DBFile;

begin
  if STI_DBFiles[STI_DBCurrent].Status <> STI_DB_NOT_OPEN then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_ALREADY_OPEN;
    end;
  STI_DB_ErrorCheck;
  Assign(InFile.DataFile,FileName);
  STI_DB_IOstatus := IOresult;
  STI_DB_IOcheck(0);
  Reset(InFile.DataFile,1);
  STI_DB_IOstatus := IOresult;
  if STI_DB_IOstatus = 1 then
    STI_OK := FALSE
  else
    begin
      STI_DB_IOcheck(0);
      BlockRead(InFile.DataFile,InFile.Header,sizeof(STI_DBHead));
      STI_OK := TRUE;
      GetMem(InFile.Fields,InFile.Header.FieldNum*sizeof(STI_DBField));
      for Loop := 1 to InFile.Header.FieldNum do
        begin
          BlockRead(InFile.DataFile,InFile.Fields^[Loop],sizeof(STI_DBField));
        end;
      InFile.Name        := FileName;
      InFile.CurRecord   := 1;
      InFile.Status      := STI_DB_NOT_UPDATED;
      GetMem(InFile.RecData,InFile.Header.RecordLen);
      InFile.RecData^[1] := ' ';
    end;
  STI_DBFIles[STI_DBCurrent] := InFile;
end;

{---------------------------------------------------------------------------}

procedure STI_DBClose;

Var
  YEAR,MONTH,DAY,DOW : word;
  InFile             : STI_DBFile;

begin
  if STI_DBFiles[STI_DBCurrent].Status = STI_DB_NOT_OPEN then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_NOT_OPEN;
    end;
  STI_DB_ErrorCheck;
  InFile := STI_DBFiles[STI_DBCurrent];
  GetDate(YEAR,MONTH,DAY,DOW);
  InFile.Header.LastUpDate[1]        := YEAR-1980;
  InFile.Header.LastUpDate[2]        := MONTH;
  InFile.Header.LastUpDate[3]        := DAY;
  STI_DBPutRec(InFile.CurRecord);
  Seek(InFile.DataFile,0);
  BlockWrite(InFile.DataFile,InFile.Header,sizeof(STI_DBHead));
  Close(InFile.DataFile);
  FreeMem(InFile.Fields,InFile.Header.FieldNum*sizeof(STI_DBField));
  FreeMem(InFile.RecData,InFile.Header.RecordLen);
  STI_DB_IOStatus := IOResult;
  InFile.Status := STI_DB_NOT_OPEN;
  STI_DBFiles[STI_DBCurrent] := InFile;
end;

{---------------------------------------------------------------------------}
{                                                                           }
{        HIGH LEVEL PROCEDURES AND FUNCTIONS FOLLOW                         }
{                                                                           }
{---------------------------------------------------------------------------}

function STI_DBFileExist(FileName : string) : boolean;

Var
  FP : file;

begin
  assign(FP,FileName);
  reset(FP);
  STI_DBFileExist := IOResult = 0;
end;

{---------------------------------------------------------------------------}

procedure STI_DBSelect(FileNum : byte);

begin
  if (FileNum = 0) or (FileNum > MAX_FILES) then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_ILLEGAL_FILE;
    end
  else
    begin
      STI_OK := TRUE;
      STI_DB_Error := 0;
      STI_DBCurrent := FileNum;
    end;
  STI_DB_ErrorCheck;
end;

{---------------------------------------------------------------------------}

procedure STI_DBGetFieldData(FieldNum : byte; Var Data);

Var
  DBOffSet : word;
  FLength  : byte;

begin
  if STI_DBFiles[STI_DBCurrent].Status = STI_DB_NOT_OPEN then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_NOT_OPEN;
      STI_DB_ErrorCheck;
    end;
  if (FieldNum < 1) or (FieldNum > STI_DBFiles[STI_DBCurrent].Header.FieldNum) then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_BAD_FIELD_NUM;
    end
  else
    begin
      STI_OK := TRUE;
      STI_DB_Error := 0;
      DBOffset := STI_DBFiles[STI_DBCurrent].Fields^[FieldNum].OffSet;
      Flength  := STI_DBFiles[STI_DBCurrent].Fields^[FieldNum].Length;
      Move(STI_DBFiles[STI_DBCurrent].RecData^[DBOffset],Data,Flength);
    end;
  STI_DB_ErrorCheck;
end;

{---------------------------------------------------------------------------}

procedure STI_DBPutFieldData(FieldNum : byte; Var Data);

Var
  DBOffSet : word;
  FLength  : byte;
  Dummy    : string absolute Data;

begin
  if STI_DBFiles[STI_DBCurrent].Status = STI_DB_NOT_OPEN then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_NOT_OPEN;
      STI_DB_ErrorCheck;
    end;
  if (FieldNum < 1) or (FieldNum > STI_DBFiles[STI_DBCurrent].Header.FieldNum) then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_BAD_FIELD_NUM;
    end
  else
    begin
      STI_OK := TRUE;
      STI_DB_Error := 0;
      DBOffset := STI_DBFiles[STI_DBCurrent].Fields^[FieldNum].OffSet;
      Flength  := STI_DBFiles[STI_DBCurrent].Fields^[FieldNum].Length;
      Move(Data,STI_DBFiles[STI_DBCurrent].RecData^[DBOffset],FLength);
    end;
  STI_DB_ErrorCheck;
end;

{---------------------------------------------------------------------------}

procedure STI_DBGetFieldAttributes(FieldNum : byte; Var Field : STI_DBField);

begin
  if STI_DBFiles[STI_DBCurrent].Status = STI_DB_NOT_OPEN then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_NOT_OPEN;
      STI_DB_ErrorCheck;
    end;
  if (FieldNum < 1) or (FieldNum > STI_DBFiles[STI_DBCurrent].Header.FieldNum) then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_BAD_FIELD_NUM;
    end
  else
    begin
      Field := STI_DBFiles[STI_DBCurrent].Fields^[FieldNum];
    end;
  STI_DB_ErrorCheck;
end;

{---------------------------------------------------------------------------}

procedure STI_DBSetFieldAttributes(FieldNum : byte;     Field : STI_DBField);

begin
  if STI_DBFiles[STI_DBCurrent].Status = STI_DB_NOT_OPEN then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_NOT_OPEN;
      STI_DB_ErrorCheck;
    end;
  if (FieldNum < 1) or (FieldNum > STI_DBFiles[STI_DBCurrent].Header.FieldNum) then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_BAD_FIELD_NUM;
    end
  else
    begin
      STI_DBFiles[STI_DBCurrent].Fields^[FieldNum] := Field;
    end;
  STI_DB_ErrorCheck;
end;

{---------------------------------------------------------------------------}

function  STI_DBGetFieldName(FieldNum : byte) : string;

begin
  if STI_DBFiles[STI_DBCurrent].Status = STI_DB_NOT_OPEN then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_NOT_OPEN;
      STI_DB_ErrorCheck;
    end;
  if (FieldNum < 1) or (FieldNum > STI_DBFiles[STI_DBCurrent].Header.FieldNum) then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_BAD_FIELD_NUM;
    end
  else
    begin
      STI_DBGetFieldName :=
        STI_DBFiles[STI_DBCurrent].Fields^[FieldNum].Descriptor;
    end;
  STI_DB_ErrorCheck;
end;

{---------------------------------------------------------------------------}

procedure STI_DBSetFieldName(FieldNum : byte; Name : string);

begin
  if STI_DBFiles[STI_DBCurrent].Status = STI_DB_NOT_OPEN then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_NOT_OPEN;
      STI_DB_ErrorCheck;
    end;
  if (FieldNum < 1) or (FieldNum > STI_DBFiles[STI_DBCurrent].Header.FieldNum) then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_BAD_FIELD_NUM;
    end
  else
    begin
      STI_DBFiles[STI_DBCurrent].Fields^[FieldNum].Descriptor := Name;
    end;
  STI_DB_ErrorCheck;
end;

{---------------------------------------------------------------------------}

function STI_DBNumRecs : longint;

begin
  if STI_DBFiles[STI_DBCurrent].Status = STI_DB_NOT_OPEN then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_NOT_OPEN;
    end;
  STI_DBNumRecs := STI_DBFiles[STI_DBCurrent].Header.RecNumber;
  STI_DB_ErrorCheck;
end;

{---------------------------------------------------------------------------}

function STI_DBNumFields : byte;

begin
  if STI_DBFiles[STI_DBCurrent].Status = STI_DB_NOT_OPEN then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_NOT_OPEN;
    end;
  STI_DBNumFields := STI_DBFiles[STI_DBCurrent].Header.FieldNum;
  STI_DB_ErrorCheck;
end;

{---------------------------------------------------------------------------}

function STI_DBCurrentRec : longint;

begin
  if STI_DBFiles[STI_DBCurrent].Status = STI_DB_NOT_OPEN then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_NOT_OPEN;
    end;
  STI_DBCurrentRec := STI_DBFiles[STI_DBCurrent].CurRecord;
  STI_DB_ErrorCheck;
end;

{---------------------------------------------------------------------------}

function STI_DBEof : boolean;

begin
  if STI_DBFiles[STI_DBCurrent].Status = STI_DB_NOT_OPEN then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_NOT_OPEN;
    end;
  STI_DBEof := STI_DBCurrentRec = STI_DBNumRecs;
  STI_DB_ErrorCheck;
end;

{---------------------------------------------------------------------------}

function STI_DBRecLen : word;

begin
  if STI_DBFiles[STI_DBCurrent].Status = STI_DB_NOT_OPEN then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_NOT_OPEN;
    end;
  STI_DBRecLen := STI_DBFiles[STI_DBCurrent].Header.RecordLen;
  STI_DB_ErrorCheck;
end;

{---------------------------------------------------------------------------}

function STI_DBFieldLen(FieldNum : byte) : byte;

begin
  if STI_DBFiles[STI_DBCurrent].Status = STI_DB_NOT_OPEN then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_NOT_OPEN;
      STI_DB_ErrorCheck;
    end;
  if (FieldNum < 1) or (FieldNum > STI_DBFiles[STI_DBCurrent].Header.FieldNum) then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_BAD_FIELD_NUM;
    end
  else
    begin
      STI_DBFieldLen := STI_DBFiles[STI_DBCurrent].Fields^[FieldNum].Length;
    end;
  STI_DB_ErrorCheck;
end;

{---------------------------------------------------------------------------}

function STI_DBFieldType(FieldNum : byte) : byte;

begin
  if STI_DBFiles[STI_DBCurrent].Status = STI_DB_NOT_OPEN then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_NOT_OPEN;
      STI_DB_ErrorCheck;
    end;
  if (FieldNum < 1) or (FieldNum > STI_DBFiles[STI_DBCurrent].Header.FieldNum) then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_BAD_FIELD_NUM;
    end
  else
    begin
      STI_DBFieldType := STI_DBFiles[STI_DBCurrent].Fields^[FieldNum].FieldType;
    end;
  STI_DB_ErrorCheck;
end;

{---------------------------------------------------------------------------}

function STI_DBState : byte;

begin
  if STI_DBFiles[STI_DBCurrent].Status = STI_DB_NOT_OPEN then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_NOT_OPEN;
    end;
  STI_DBState := STI_DBFiles[STI_DBCurrent].Status;
  STI_DB_ErrorCheck;
end;

{---------------------------------------------------------------------------}

function STI_DBFileName : string;

begin
  if STI_DBFiles[STI_DBCurrent].Status = STI_DB_NOT_OPEN then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_NOT_OPEN;
    end;
  STI_DBFileName := STI_DBFiles[STI_DBCurrent].Name;
  STI_DB_ErrorCheck;
end;

{---------------------------------------------------------------------------}

function STI_DBLastUpDate : string;

Var
  Year,Month,Day : string[10];

begin
  if STI_DBFiles[STI_DBCurrent].Status = STI_DB_NOT_OPEN then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_NOT_OPEN;
    end;
  str(STI_DBFiles[STI_DBCurrent].Header.LastUpDate[1]+1980,Year);
  str(STI_DBFiles[STI_DBCurrent].Header.LastUpDate[2],    Month);
  str(STI_DBFiles[STI_DBCurrent].Header.LastUpDate[3],      Day);
  STI_DBLastUpDate := Year+'/'+Month+'/'+Day;
  STI_DB_ErrorCheck;
end;

{---------------------------------------------------------------------------}

function STI_DBRecordDeleted(Rec : longint) : boolean;

begin
  if STI_DBFiles[STI_DBCurrent].Status = STI_DB_NOT_OPEN then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_NOT_OPEN;
    end;
  if (STI_DBFiles[STI_DBCurrent].Header.RecNumber < Rec) or (Rec < 0) then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_BAD_RECORD_NUM;
    end
  else
    begin
      STI_DBGetRec(Rec);
      STI_DBRecordDeleted := STI_DBFiles[STI_DBCurrent].RecData^[1] = '*';
      STI_DBPutRec(Rec);
    end;
  STI_DB_ErrorCheck;
end;

{---------------------------------------------------------------------------}

procedure STI_DBSetCurrentRec(Rec : longint);

begin
  if STI_DBFiles[STI_DBCurrent].Status = STI_DB_NOT_OPEN then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_NOT_OPEN;
    end;
  if (STI_DBFiles[STI_DBCurrent].Header.RecNumber < Rec) or (Rec < 0) then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_BAD_RECORD_NUM;
    end
  else
    begin
      STI_DBFiles[STI_DBCurrent].CurRecord := Rec;
      STI_DBGetRec(Rec);
    end;
  STI_DB_ErrorCheck;
end;

{---------------------------------------------------------------------------}

procedure STI_DBDeleteRecord(Rec : longint);

begin
  if STI_DBFiles[STI_DBCurrent].Status = STI_DB_NOT_OPEN then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_NOT_OPEN;
    end;
  if (STI_DBFiles[STI_DBCurrent].Header.RecNumber < Rec) or (Rec < 0) then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_BAD_RECORD_NUM;
    end
  else
    begin
      STI_DBGetRec(Rec);
      STI_DBFiles[STI_DBCurrent].RecData^[1] := '*';
      STI_DBPutRec(Rec);
    end;
  STI_DB_ErrorCheck;
end;

{---------------------------------------------------------------------------}

procedure STI_DBGoto(Rec : longint);

begin
  STI_DBSetCurrentRec(Rec);
end;

{---------------------------------------------------------------------------}

procedure STI_DBSKip(Rec : longint);

begin
  STI_DBSetCurrentRec(Rec+STI_DBFiles[STI_DBCurrent].CurRecord);
end;

{---------------------------------------------------------------------------}

procedure STI_DBAppend(Blank : boolean);

Var
  Rec  : longint;

begin
  if STI_DBFiles[STI_DBCurrent].Status = STI_DB_NOT_OPEN then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_NOT_OPEN;
    end;
  Rec := STI_DBFiles[STI_DBCurrent].Header.RecNumber + 1;
  STI_DBFiles[STI_DBCurrent].CurRecord := Rec;
  if Blank then
    FillChar(STI_DBFiles[STI_DBCurrent].RecData,
             STI_DBFiles[STI_DBCurrent].Header.RecordLen,#32);
  STI_DBPutRec(Rec);
  STI_DB_ErrorCheck;
end;

{---------------------------------------------------------------------------}

procedure STI_DBSwapRecord(RecA,RecB : longint);

Var
  Dummy1,
  Dummy2 : array[1..MAX_REC_LEN] of byte;

begin
  if STI_DBFiles[STI_DBCurrent].Status = STI_DB_NOT_OPEN then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_NOT_OPEN;
    end;
  if (STI_DBFiles[STI_DBCurrent].Header.RecNumber < RecA) or (RecA < 0) then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_BAD_RECORD_NUM;
    end;
  if (STI_DBFiles[STI_DBCurrent].Header.RecNumber < RecB) or (RecB < 0) then
    begin
      STI_OK := FALSE;
      STI_DB_Error := STI_DB_BAD_RECORD_NUM;
    end
  else
    begin
      STI_DBGetRec2(RecA,Dummy1,STI_DBFiles[STI_DBCurrent].Header.RecordLen);
      STI_DBGetRec2(RecB,Dummy2,STI_DBFiles[STI_DBCurrent].Header.RecordLen);
      STI_DBPutRec2(RecB,Dummy1,STI_DBFiles[STI_DBCurrent].Header.RecordLen);
      STI_DBPutRec2(RecA,Dummy2,STI_DBFiles[STI_DBCurrent].Header.RecordLen);
    end;
  STI_DB_ErrorCheck;
end;

{---------------------------------------------------------------------------}

procedure STI_DBInit;

Var
  Loop : byte;

begin
  for Loop := 1 to MAX_FILES do
    begin
      STI_DBFiles[Loop].Name      := '';
      STI_DBFiles[Loop].Status    := STI_DB_NOT_OPEN;
      STI_DBFiles[Loop].CurRecord := 1;
    end;
  STI_DBCurrent    := 1;
  STI_DB_Error     := 0;
  STI_DB_IOStatus  := 0;
  STI_OK           := TRUE;
end;

{---------------------------------------------------------------------------}

function STI_DBPosSameData(Start : longint; Field : byte) : longint;

Var
  Dummy1,
  Dummy2 : string;
  Count  : longint;

begin
  Count := Start;
  STI_DBGetRec(Start);
  STI_DBGetFieldData(Field,Dummy1);
  STI_DBGetRec(Count);
  STI_DBGetFieldData(Field,Dummy2);
  while (Dummy2 = Dummy1) and (Count < STI_DBFiles[STI_DBCurrent].Header.RecNumber) do
    begin
      Inc(Count);
      STI_DBGetRec(Count);
      STI_DBGetFieldData(Field,Dummy2);
    end;
  Dec(Count);
  STI_DBPosSameData := Count;
end;

{---------------------------------------------------------------------------}

procedure STI_DBMultiFieldInFileSort(Max : byte; Flds : STI_Sort; Mode : Byte);

var
  loop      : byte;
  beginrec,
  lastrec   : longint;

procedure sort(l,r : longint; FNum : word);

var
  i,j    : longint;
  ai,aj,
  x      : string;


begin
  i := l; j := r;
  STI_DBGetRec((l+r) DIV 2);
  STI_DBGetFieldData(FNum,x);
  TextColor(White);
  GotoXY(21,11);
  Write('Mem   =',MemAvail:12);
  GotoXY(21,12);
  Write('Field =',FNum:12);
  GotoXY(21,13);
  Write('Left  =',i:12);
  GotoXY(21,14);
  Write('Right =',j:12);
  repeat
    STI_DBGetRec(i);
    STI_DBGetFieldData(FNum,ai);
    if Mode = ASCEND then
      begin
        while (ai < x) and (i <= STI_DBFiles[STI_DBCurrent].Header.RecNumber - 1) do
          begin
            i := i + 1;
            GotoXY(21,13);
            Write('Left  =',i:12);
            STI_DBGetRec(i);
            STI_DBGetFieldData(FNum,ai);
          end;
      end else
      begin
        while (ai > x) and (i <= STI_DBFiles[STI_DBCurrent].Header.RecNumber - 1) do
          begin
            i := i + 1;
            GotoXY(21,13);
            Write('Left  =',i:12);
            STI_DBGetRec(i);
            STI_DBGetFieldData(FNum,ai);
          end;
      end;
    STI_DBGetRec(j);
    STI_DBGetFieldData(FNum,aj);
    if Mode = ASCEND then
     begin
       while (x < aj) and (j >= 1) do
         begin
           j := j - 1;
           GotoXY(21,14);
           Write('Right =',j:12);
           STI_DBGetRec(j);
           STI_DBGetFieldData(FNum,aj);
         end;
     end else
     begin
       while (x > aj) and (j >= 1) do
         begin
           j := j - 1;
           GotoXY(21,14);
           Write('Right =',j:12);
           STI_DBGetRec(j);
           STI_DBGetFieldData(FNum,aj);
         end;
     end;
    if (i <= j) then
      begin
        STI_DBSwapRecord(j,i);
        if i < STI_DBFiles[STI_DBCurrent].Header.RecNumber then i := i + 1;
        if j >=          2 then j := j - 1;
      end;
  until i>j;
  if l<j then sort(l,j,FNum);
  if i<r then sort(i,r,FNum);
end;


begin {qsort}
  Sort(1,STI_DBFiles[STI_DBCurrent].Header.RecNumber,flds[1]);
  loop := 1;
  beginrec := 1;
  lastrec  := STI_DBPosSameData(beginrec,flds[1]);

  while loop < Max do
    begin
      while beginrec < STI_DBFiles[STI_DBCurrent].Header.RecNumber-1 do
        begin
          if (loop+1 <= max) then
            sort(beginrec,lastrec,flds[loop+1]);
          beginrec := lastrec+1;
          if beginrec < STI_DBFiles[STI_DBCurrent].Header.RecNumber-1 then
            lastrec := STI_DBPosSameData(beginrec,flds[loop]);
        end;
      inc(loop);
      beginrec := 1;
      lastrec  := STI_DBPosSameData(beginrec,flds[loop]);
    end;

  ClrScr;
end;

{---------------------------------------------------------------------------}

Type
  MyData  = record
              A : string[10];
              B : word;
              C : word;
              D : string[10];
            end;

Var
  DBFArr : STI_DBFArr;
  Dummy  : MyData;
  Loop   : word;
  OH,OM,OS,OSS,
  NH,NM,NS,NSS  : word;
  Test4,
  Test1   : string;
  Test3,
  Test2   : word;
  Flds    : STI_Sort;

begin
  ClrScr;

  DBFArr[1].Descriptor  := '##STRING##';
  DBFArr[1].Length      := 11;
  DBFArr[1].FieldType   := STI_DB_STRING;
  DBFArr[2].Descriptor  := '###WORD###';
  DBFArr[2].Length      := 2;
  DBFArr[2].FieldType   := STI_DB_WORD;
  DBFArr[3].Descriptor  := '###WORD###';
  DBFArr[3].Length      := 2;
  DBFArr[3].FieldType   := STI_DB_WORD;
  DBFArr[4].Descriptor  := '##STRING##';
  DBFArr[4].Length      := 11;
  DBFArr[4].FieldType   := STI_DB_STRING;


  STI_DBInit;
  STI_DBSelect(1);
  STI_DBCreate('A:TEST.SDB',4,DBFArr);
  STI_DBClose;
  STI_DBSelect(1);
  STI_DBOpen('A:TEST.SDB');

  GetTime(OH,OM,OS,OSS);

  for loop := 1 to 100 do
    begin
      str(random(500):10,Test1);
      Test2 := trunc(random(10));
      str(random(500):10,Test4);
      Test3 := trunc(random(10));
      STI_DBPutFieldData(1,Test1);
      STI_DBPutFieldData(2,Test2);
      STI_DBPutRec(Loop);
    end;

  for loop := 1 to 100 do
    begin
      STI_DBGetRec(Loop);
      STI_DBGetFieldData(1,Test1);
      STI_DBGetFieldData(2,Test2);
    end;

  GetTime(NH,NM,NS,NSS);


  Writeln(OH,':',OM,':',OS,':',OSS,'/',NH,':',NM,':',NS,':',NSS);

  STI_DBClose;
end.