Chip 2001 October/Chip_2001-10_cd1.bin/zkuste/delphi/nastroje/d23456/SPLBASE.ZIP/Splbase/Activex/splx.pas

Pascal/Delphi Source File | 2001-08-05 | 35.8 KB | 1,479 lines

(*********** SplitBase Data Management Systems ***********
 *                                                       *
 *           Copyright (c) 2001 Leon O. Romain           *
 *                                                       *
 *                     [e-mail]                    *
 *                                                       *
 *********************************************************)

{
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
}

unit splx;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

const
   spllen = 26;   {Length of index field}
   splmax = 2000; {Maximum number of records before split}
   fldmax = 100;  {Maximum number of fields in record}

type
  Splitrec = record          {SplitBase index structure}
    data : string[spllen];   {Actual index field value}
    ptr : longint;           {Pointer to record containing index}
  end;

  splitbox = record          {Full SplitBase index structure}
     state : byte;           {0 = empty}
     count : longint;        {number of index fields in SplitBase index}
     index :                 {All indexes values within SplitBase index}
             array [1..splmax] of Splitrec;
  end;

  recdef = record            {Record definition for DB}
     size : integer;         {Total number of fields}
     recout : longint;       {Number of deleted records}
     indout : longint;       {Number of indexes deleted}
     SplID : longint;        {SplitBase Identifier}
     rsv101,                 {Reserved}
     rsv102,                 {Reserved}
     rsv103,                 {Reserved}
     rsv104 : longint;       {Reserved}
     def :                   {Size of each field}
            array [1..fldmax] of string[3]
  end;

  splerror = record          {Error definition structure}
     recnum : integer;       {Error number}
     recstr : string;        {Error description}
  end;

  tsplx = class(Twincontrol)
  private
    { Private declarations }
    topbox,   {First or top index holder}
    varbox :  {Variable or current index holder}
             ^splitbox;
    allrec :  {Definition for all fields in record}
             recdef;
    curtop :  {Pointer to current position within top index}
             longint;
    curind,   {Value of current index}
    curdtb :  {Name of current database}
             string;
    cursub,   {Pointer to current subindex}
    curpos,   {Pointer to current data in SplitBase index}
    currec :  {Pointer to current record within DB}
             longint;
    rechld : {Holder for all fields in record}
             ansistring;
    splerr : {Holds number and description of last error}
             splerror;
    recmax : {Maximum number of record in DB. Useful if the
              Database must be limited to a specific number
              of records to avoid overflow}
              Longint;
    limrec : {Limits the number of recors that can be
              entered by comparison to recmax}
             Longint;

    function putdef : boolean;
    Function getsubindex (ind : longint) : boolean;
    function findpos (idx : string) : boolean;
    function findsubindex (idx : string) : boolean;
    function pullrec : boolean;
    function putrec : boolean;
    Function putsubindex (ind : longint) : boolean;
    function puttop : boolean;
    function splitit : boolean;
  protected
    { Protected declarations }
    CreateError : tnotifyevent;
    OpenError : tnotifyevent;
    ReadError : tnotifyevent;
    WriteError : tnotifyevent;
  public
    { Public declarations }
    function getrec (idx : string) : boolean;
    function initspl : boolean;
    function releasespl : boolean;
    function initbase : boolean;
    function activedb : boolean;
    function activerec : boolean;
    function dbempty : boolean;
    function reccount : longint;
    function createspl ( splname : string ) : boolean;
    function openspl ( splname : string ) : boolean;
    function addrec (idx : string) : boolean;
    function setspl ( spldat : string ) : boolean;
    function addfield ( recdat : string; pos : integer ) :
             boolean;
    function getfield ( pos : integer ) : string;
    function delrec: boolean;
    function modrec ( idx : string ) : boolean;
    function firstrec : boolean;
    function lastrec : boolean;
    function nextrec : boolean;
    function prevrec : boolean;
  published
    { Published declarations }
    property Reclimit : Longint read limrec write limrec;
    property CurrentDB : string read curdtb write curdtb;
    property FieldCount : integer read allrec.size;
    property ErrorNumber : integer read splerr.recnum;
    property ErrorString : string read splerr.recstr;
    property OnCreateError : tnotifyevent read CreateError
                           write CreateError;
    property OnOpenError : tnotifyevent read OpenError
                           write OpenError;
    property OnReadError : tnotifyevent read ReadError
                           write ReadError;
    property OnWriteError : tnotifyevent read ReadError
                           write ReadError;
  end;

procedure Register;

implementation


function tsplx.initspl : boolean;
{Initialize spliter system by reserving space in memory
 for the top and curent SplitBase indexes. Return false if
 process fails}
var
   b : boolean;
begin
   recmax := ( splmax div 2 ) * splmax;
   b := true;
   try
      new ( topbox );
      new ( varbox );
   except
      on EOutOfMemory do b := false;
   end;
   if b = false then
   begin
      splerr.recnum := 0;
      splerr.recstr := 'Unable to allocate system memory';
   end;
   initspl := b;
end;

function tsplx.releasespl : boolean;
{Releases memory allocated to spliter system by disposing
 of that memory. The function returns false if
 process fails}
var
   b : boolean;
begin
   b := true;
   try
      dispose ( topbox );
      dispose ( varbox );
   except
      on EInvalidPointer do b := false
   end;
   if b = false then
   begin
      splerr.recnum := 28;
      splerr.recstr := 'No SplitBase Sytem to unload';
   end;
   releasespl := b;
end;

function tsplx.initbase : boolean;
{Initializes all variables of SplitBase DB before creating
 a new Database or opening one.}
var
   b : boolean;
   s : string;
begin
   b := false;
   try
      topbox.state := 0;
      topbox.count := 0;
      varbox.state := 0;
      varbox.count := 0;
   except
      b := false;
   end;
   allrec.size := 0;
   allrec.recout := 0;
   allrec.indout := 0;
   s := 'SB10';
   move ( s[1], allrec.SplID, 4 );
   curind := '';
   curdtb := '';
   currec := 0;
   rechld := '';
   limrec := 0;
   initbase := b;
end;

function tsplx.activedb : boolean;
{This function checks if there is an active DB}
var
   b : boolean;
begin
   b := true;
   if curdtb = '' then
      b := false;
   activedb := b
end;

function tsplx.activerec : boolean;
{This function checks if there is an active record}
var
   b : boolean;
begin
   b := true;
   if currec = 0 then
      b := false;
   activerec := b
end;

function tsplx.dbempty : boolean;
{This function checks if DB is empty}
var
   b : boolean;
begin
   b := true;
   if activedb then
   begin
      if topbox^.count > 0 then
         b := false;
   end;
   dbempty := b
end;

function tsplx.reccount : longint;
{Returns the number of records in database}
var
   l1, l2 : longint;
   f : file;
begin
   l1 := sizeof ( splitbox );
   assignfile ( f, curdtb );
   {$I-}
   reset ( f, 1 );
   l2 := filesize ( f );
   closefile ( f );
   {$I+}
   if ioresult = 0 then
   begin
      if topbox^.count > 0 then
      begin
         l1 := ( l2 - sizeof ( allrec ) - ( l1 *
               ( topbox^.count + 1 ) ) ) div allrec.size;
         l1 := l1 - allrec.recout - ( allrec.indout *
               ( sizeof ( splitbox ) ) );
      end
      else
         l1 := 0;
   end
   else
      l1 := 0;
   reccount := l1;
end;

function tsplx.createspl ( splname : string ) : boolean;
{Creates a new SplitBase DB and saves it to disk. This
 function will return false if process fails}
var
   b : boolean;
   f : file;
   s : string;
begin
   b := true;
   s := splname + '.spd';
   if fileexists ( s ) then
   begin
      b := false;
      splerr.recnum := 1;
      splerr.recstr := 'File already exits.';
   end
   else
   if allrec.size <= 0 then
   begin
      b := false;
      splerr.recnum := 31;
      splerr.recstr := 'Record structure not defined.';
   end
   else
   begin
      assignfile ( f, s );
      {$I-}
      rewrite ( f, 1 );
      {$I+}
      if ioresult = 0 then
      begin
         {initbase;}
         {$I-}
         blockwrite ( f, topbox^, sizeof ( splitbox ) );
         blockwrite ( f, allrec, sizeof ( allrec ) );
         blockwrite ( f, varbox^, sizeof ( splitbox ) );
         {$I+}
         if ioresult <> 0 then
         begin
            b := false;
            splerr.recnum := 3;
            splerr.recstr := 'Unable to write SplitBase file.';
         end;
         {$I-}
         closefile ( f );
         {$I+}
         if ioresult <> 0 then
         begin
            b := false;
            splerr.recnum := 4;
            splerr.recstr := 'Unable to close SplitBase file.';
         end;
      end
      else
      begin
         b := false;
         splerr.recnum := 2;
         splerr.recstr := 'Unable to create SplitBase file.';
      end;
   end;
   if b then
   begin
      curdtb := splname + '.spd';
      setlength ( rechld, allrec.size );
   end
   else
   begin
      curdtb := '';
      if assigned (createerror) then
         createerror (self);
   end;
   createspl := b
end;

function tsplx.openspl ( splname : string ) : boolean;
{Opens an existing SplitBase DB from disk. This
 function will return false if process fails}
var
   b : boolean;
   f : file;
   s : string;
begin
   b := true;
   s := splname + '.spd';
   assignfile ( f, s );
   {$I-}
   reset ( f, 1 );
   {$I+}
   if ioresult = 0 then
   begin
      {$I-}
      blockread ( f, topbox^, sizeof ( splitbox ) );
      blockread ( f, allrec, sizeof ( allrec ) );
      blockread ( f, varbox^, sizeof ( splitbox ) );
      {$I+}
      if ioresult = 0 then
      begin
         s := '    ';
         move ( allrec.SplID, s[1], 4 );
         if s <> 'SB10' then
         begin
            b := false;
            splerr.recnum := 100;
            splerr.recstr := 'Not a SplitBase file.';
         end
      end
      else
      begin
         b := false;
         splerr.recnum := 6;
         splerr.recstr := 'Unable to read SplitBase file.';
      end;
      {$I-}
      closefile ( f );
      {$I+}
      if ioresult <> 0 then
      begin
         b := false;
         splerr.recnum := 7;
         splerr.recstr := 'Unable to close SplitBase file.';
      end;
   end
   else
   begin
      b := false;
      splerr.recnum := 5;
      splerr.recstr := 'Unable to open SplitBase file.';
   end;
   if b then
   begin
      curdtb := splname + '.spd';
      setlength ( rechld, allrec.size );
   end
   else
   begin
      curdtb := '';
      if assigned (openerror) then
         openerror (self);
   end;
   openspl := b
end;

function tsplx.putdef : boolean;
{Updates DB definition record}
var
   b : boolean;
   f : file;
begin
   b := true;
   if activedb then
   begin
      assignfile ( f, curdtb );
      {$I-}
      reset ( f, 1 );
      seek ( f, sizeof ( splitbox ) );
      blockwrite ( f, allrec, sizeof ( allrec ) );
      closefile ( f );
      {$I+}
      if ioresult <> 0 then
      begin
         b := false;
         splerr.recnum := 49;
         splerr.recstr := 'Unable to close SplitBase file.';
      end
   end
   else
      b := false;
   putdef := b;
end;


Function tsplx.getsubindex (ind : longint) : boolean;
{Locates and loads the current secondary index into memory}
var
   b : boolean;
   f : file;
begin
   b := true;
   assignfile ( f, curdtb );
   {$I-}
   reset ( f, 1 );
   seek ( f, ind );
   {$I+}
   if ioresult = 0 then
   begin
      {$I-}
      blockread ( f, varbox^, sizeof ( splitbox ) );
      {$I+}
      if ioresult <> 0 then
      begin
         b := false;
         splerr.recnum := 9;
         splerr.recstr := 'Unable to read SplitBase file.';
      end;
      {$I-}
      closefile ( f );
      {$I+}
      if ioresult <> 0 then
      begin
         b := false;
         splerr.recnum := 10;
         splerr.recstr := 'Unable to close SplitBase file.';
      end;
   end
   else
   begin
      b := false;
      splerr.recnum := 12;
      splerr.recstr := 'Unable to open SplitBase file.';
   end;
   if b then
      cursub := ind;
   getsubindex := b;
end;

function tsplx.findpos (idx : string) : boolean;
{Finds the position of the search field within the
 secondary index or subindex}
var
   b : boolean;
   cnt, l, l1, l2 : longint;
   s : string;
begin
   cnt := varbox^.count;
   b := true;
   l := 0;
   currec := 0;
   if cnt > 0 then
   begin
      if cnt > 1 then
      begin
         l1 := 1;
         l2 := cnt;
         while l1 <= l2 do
         begin
            l := (l2 - l1) div 2 + l1;
            s := varbox^.index[l].data;
            if ansicomparetext ( idx, s ) > 0 then
               l1 := l + 1
            else if ansicomparetext ( idx, s ) < 0 then
               l2 := l - 1
            else
               l2 := l1 - 1
         end
      end
      else
         l := 1;
      s := varbox^.index[l].data;
      {ind := varbox^.index[l].ptr;}
      currec := varbox^.index[l].ptr;
      curind := s;
      curpos := l
   end;
   findpos := b
end;

function tsplx.findsubindex (idx : string) : boolean;
{Locates the secondary index that may contain the
 search field}
var
   b : boolean;
   l1, l2, l, cnt, ind : longint;
   s : string;
begin
   cnt := topbox^.count;
   l := 0;
   if cnt > 0 then
   begin
      if cnt > 1 then
      begin
         l1 := 1;
         l2 := cnt;
         while l1 <= l2 do
         begin
            l := (l2 - l1) div 2 + l1;
            s := topbox^.index[l].data;
            if ansicomparetext ( idx, s ) > 0 then
               l1 := l + 1
            else if ansicomparetext ( idx, s ) < 0 then
               l2 := l - 1
            else
               l2 := l1 - 1
         end
      end
      else
         l := 1;
      s := topbox^.index[l].data;
      if ansicomparetext ( idx, s ) < 0 then
         l := l - 1;
      if l = 0 then
         l := 1;
      s := topbox^.index[l].data;
      ind := topbox^.index[l].ptr;
      curtop := l;

      if ind > 0 then
      begin
         b := getsubindex(ind)
      end
      else
      begin
         b := false;
         splerr.recnum := 11;
         splerr.recstr := 'Illegal SplitBase index value.';
      end;

      if b then
      begin
         b := findpos (idx)
      end

   end
   else
   begin
      b := false;
      splerr.recnum := 8;
      splerr.recstr := 'SplitBase index is empty.';
   end;
   if b = false then
      currec := 0;
   findsubindex := b;
end;

function tsplx.pullrec : boolean;
{Reads a record into memory}
var
   b : boolean;
   f : file;
begin
   b := true;
   assignfile ( f, curdtb );
   {$I-}
   reset ( f, 1 );
   seek ( f, currec );
   {$I+}
   if ioresult = 0 then
   begin
      {$I-}
      setlength ( rechld, allrec.size );
      blockread ( f, rechld[1], allrec.size );
      {$I+}
      if ioresult <> 0 then
      begin
         b := false;
         splerr.recnum := 32;
         splerr.recstr := 'Unable to read record.';
      end;
      {$I-}
      closefile ( f );
      {$I+}
      if ioresult <> 0 then
      begin
         b := false;
         splerr.recnum := 33;
         splerr.recstr := 'Unable to close SplitBase file.';
      end;
   end
   else
   begin
      b := false;
      splerr.recnum := 34;
      splerr.recstr := 'Unable to open SplitBase file.';
   end;
   pullrec := b;
end;

function tsplx.getrec (idx : string) : boolean;
{Loads the found record into memory}
var
   b : boolean;
   f : file;
begin
   b := true;
   if findsubindex (idx) then
   begin
      if comparetext (idx, curind) = 0 then
      begin
         assignfile ( f, curdtb );
         {$I-}
         reset ( f, 1 );
         seek ( f, currec );
         {$I+}
         if ioresult = 0 then
         begin
            {$I-}
            setlength ( rechld, allrec.size );
            blockread ( f, rechld[1], allrec.size );
            {$I+}
            if ioresult <> 0 then
            begin
               b := false;
               splerr.recnum := 14;
               splerr.recstr := 'Unable to read record.';
            end;
            {$I-}
            closefile ( f );
            {$I+}
            if ioresult <> 0 then
            begin
               b := false;
               splerr.recnum := 15;
               splerr.recstr := 'Unable to close SplitBase file.';
            end;
         end
         else
         begin
            b := false;
            splerr.recnum := 13;
            splerr.recstr := 'Unable to open SplitBase file.';
         end;
      end
      else
      begin
         b := false;
         splerr.recnum := 16;
         splerr.recstr := 'Data not found';
      end;
   end
   else
      b := false;
   if b = false then
   begin
      currec := 0;
      if assigned (readerror) then
         readerror (self);
   end;
   getrec := b;
end;

function tsplx.putrec : boolean;
{Saves the new record within DB}
var
   b : boolean;
   f : file;
   l : longint;
begin
   b := true;
   assignfile ( f, curdtb );
   {$I-}
   reset ( f, 1 );
   l := filesize ( f );
   seek ( f, l );
   {$I+}
   if ioresult = 0 then
   begin
      {$I-}
      blockwrite ( f, rechld[1], allrec.size );
      {$I+}
      if ioresult <> 0 then
      begin
         b := false;
         splerr.recnum := 18;
         splerr.recstr := 'Unable to save record.';
      end;
      {$I-}
      closefile ( f );
      {$I+}
      if ioresult <> 0 then
      begin
         b := false;
         splerr.recnum := 19;
         splerr.recstr := 'Unable to close SplitBase file.';
      end;
   end
   else
   begin
      b := false;
      splerr.recnum := 17;
      splerr.recstr := 'Unable to open SplitBase file.';
   end;
   if b then
      currec := l
   else
   begin
      currec := 0;
      if assigned (writeerror) then
         writeerror (self);
   end;
   putrec := b;
end;

Function tsplx.putsubindex (ind : longint) : boolean;
{Saves the secondary index within DB}
var
   b : boolean;
   f : file;
begin
   b := true;
   assignfile ( f, curdtb );
   {$I-}
   reset ( f, 1 );
   seek ( f, ind );
   {$I+}
   if ioresult = 0 then
   begin
      {$I-}
      blockwrite ( f, varbox^, sizeof ( splitbox ) );
      {$I+}
      if ioresult <> 0 then
      begin
         b := false;
         splerr.recnum := 20;
         splerr.recstr := 'Unable to write SplitBase file.';
      end;
      {$I-}
      closefile ( f );
      {$I+}
      if ioresult <> 0 then
      begin
         b := false;
         splerr.recnum := 21;
         splerr.recstr := 'Unable to close SplitBase file.';
      end;
   end
   else
   begin
      b := false;
      splerr.recnum := 22;
      splerr.recstr := 'Unable to open SplitBase file.';
   end;
   putsubindex := b;
end;

function tsplx.puttop : boolean;
{Saves main SplitBase index into DB. This
 function will return false if process fails}
var
   b : boolean;
   f : file;
begin
   b := true;
   assignfile ( f, curdtb );
   {$I-}
   reset ( f, 1 );
   {$I+}
   if ioresult = 0 then
   begin
      {$I-}
      blockwrite ( f, topbox^, sizeof ( splitbox ) );
      {$I+}
      if ioresult <> 0 then
      begin
         b := false;
         splerr.recnum := 25;
         splerr.recstr := 'Unable top index.';
      end;
      {$I-}
      closefile ( f );
      {$I+}
      if ioresult <> 0 then
      begin
         b := false;
         splerr.recnum := 26;
         splerr.recstr := 'Unable to close SplitBase file.';
      end;
   end
   else
   begin
      b := false;
      splerr.recnum := 27;
      splerr.recstr := 'Unable to open SplitBase file.';
   end;
   puttop := b;
end;

function tsplx.splitit : boolean;
{Saves the index field within the main or secondary index
 and splits secondary index}
var
   b : boolean;
   l1, l2 : longint;
   f : file;
   s : string;
begin
   b := true;
   l1 := varbox^.count div 2;
   l2 := varbox^.count - l1;
   varbox^.count := l1;
   putsubindex ( cursub );
   move ( varbox^.index[l1 + 1], varbox^.index[1],
          l2 * sizeof ( Splitrec ) );
   varbox^.count := l2;
   assignfile ( f, curdtb );
   {$I-}
   reset ( f, 1 );
   cursub := filesize ( f );
   close ( f );
   {$I+}
   if ioresult = 0 then
   begin
      if putsubindex ( cursub ) then
      begin
         s := varbox.index[1].data;
         if comparetext ( topbox^.index[ curtop ].data,
                           s ) < 0 then
            curtop := curtop + 1;
         move ( topbox^.index[curtop],
                topbox^.index[curtop + 1],
                (splmax - curtop) * sizeof (Splitrec) );
         topbox^.index[curtop].data :=
            varbox.index[1].data;
         topbox^.index[curtop].ptr := cursub;
         topbox^.count := topbox^.count + 1;
         if not (puttop) then
            b := false;
      end
      else
      begin
         b := false;
         splerr.recnum := 24;
         splerr.recstr := 'Unable to split subindex.';
      end
   end
   else
   begin
      b := false;
      splerr.recnum := 23;
      splerr.recstr := 'Unable to size SplitBase file.';
   end;
   splitit := b
end;

function tsplx.addrec (idx : string) : boolean;
{Adds a new record to DB}
var
   b : boolean;
   l : longint;
begin
   b := true;
   if activedb then
   begin
      {if topbox.count = splmax then}
      if limrec >= recmax then
      begin
         b := false;
         splerr.recstr := 'Maximum records exceeded';
      end
   end
   else
   begin
      b := false;
      splerr.recstr := 'No active database.';
   end;
   if b then
   begin
      if findsubindex (idx) then
      begin
         if ansicomparetext ( idx, curind ) > 0 then
            l := curpos + 1
         else
            l := curpos;
         if putrec then
         begin
            move ( varbox^.index[l], varbox^.index[l + 1],
                   (splmax - l) * sizeof ( Splitrec ) );
            varbox^.index[l].data := idx;
            varbox^.index[l].ptr := currec;
            varbox^.count := varbox^.count + 1;
            if varbox^.count = splmax then
            begin
               if splitit = false then
                  b := false
            end
            else
            begin
               if not (putsubindex ( cursub )) then
                  b := false
            end;
            if (l = 1) and (b) then
            begin
               topbox^.index[1].data := varbox.index[1].data;
               if not (puttop) then
                  b := false;
            end;
         end
      end
      else
      begin
         if splerr.recnum = 8 then
         begin
            if putrec then
            begin
               topbox^.state := 1;
               topbox^.count := 1;
               topbox^.index[1].data := idx;
               topbox^.index[1].ptr := sizeof ( splitbox ) +
                                       sizeof ( recdef );
               cursub := sizeof ( splitbox ) +
                         sizeof ( recdef );
               if puttop then
               begin
                  varbox^.index[1].data := idx;
                  varbox^.index[1].ptr := currec;
                  varbox^.count := 1;
                  if not (putsubindex ( cursub )) then
                     b := false
               end
               else
                  b := false
            end
            else
               b := false
         end
         else
            b := false;
      end;
   end
   else
      splerr.recnum := 50;
   if b then
      limrec := limrec + 1;
   addrec := b;
end;

function tsplx.setspl ( spldat : string ) : boolean;
{Automated record definition through a string. The string
 contains the length of each field starting with the first
 and defined by three digits. If the field length is less
 than three digits fill the left part with zeroes.}
var
   b : boolean;
   x, y, len : integer;
   s : string;
begin
   b := true;
   x := length ( spldat );
   if ( x mod 3 = 0 ) and ( x > 0 ) then
   begin
      x := x div 3;
      len := 0;
      for y := 0 to x - 1 do
      begin
         s := copy ( spldat, (y * 3) + 1, 3 );
         if strtoint ( s ) > 0 then
         begin
            len := len + strtoint ( s );
            allrec.def [ y + 1 ] := s
         end
         else
         begin
            b := false;
            splerr.recnum := 29;
            splerr.recstr := 'Illegal definition data';
         end;
      end;
      if b then
      begin
         allrec.size := len;
         setlength ( rechld, len );
      end
   end
   else
   begin
      b := false;
      splerr.recnum := 30;
      splerr.recstr := 'Illegal definition data';
   end;
   setspl := b;
end;

function tsplx.addfield ( recdat : string; pos : integer ) :
         boolean;
{Adds a field to a record in DB}
var
   x, y : integer;
   b : boolean;
begin
   b := true;
   y := 0;
   x := 1;
   while x < pos do
   begin
      y := y + strtoint ( allrec.def[x] );
      x := x + 1;
   end;
   x := strtoint ( allrec.def[pos] );
   while length ( recdat ) < x do
      recdat := recdat + ' ';
   setlength ( recdat, x );
   rechld := copy ( rechld, 1, y ) + recdat +
             copy ( rechld, y + x + 1, length ( rechld ) -
                    ( x + y ) );
   addfield := b;
end;

function tsplx.getfield ( pos : integer ) : string;
{Retreives a field from a record in DB}
var
   x, y : integer;
   s : string;
begin
   y := 0;
   x := 1;
   s := '';
   while x < pos do
   begin
      y := y + strtoint ( allrec.def[x] );
      x := x + 1;
   end;
   x := strtoint ( allrec.def[pos] );
   s := copy ( rechld, y + 1, x );
   getfield := s;
end;

function tsplx.delrec: boolean;
{Deletes the current record from the database}
var
   b : boolean;
   l : longint;
begin
   b := true;
   if activedb then
   begin
      if not (dbempty) then
      begin
         if not (activerec) then
         begin
            splerr.recstr := 'No active record.';
            b := false
         end
      end
      else
      begin
         splerr.recstr := 'Empty database.';
         b := false
      end
   end
   else
   begin
      splerr.recstr := 'No active database';
      b := false
   end;
   if b then
   begin
      l := curpos;
      move ( varbox^.index[l + 1], varbox^.index[l],
           (splmax - l) * sizeof ( Splitrec ) );
      varbox^.count := varbox^.count - 1;
      if varbox^.count > 0 then
      begin
         if putsubindex ( cursub ) then
         begin
            allrec.recout := allrec.recout + 1;
            if not (putdef) then
               b := false;
            if l = 1 then
            begin
               topbox^.index[curtop].data :=
                  varbox.index[1].data;
               if not (puttop) then
                  b := false;
            end;
         end
         else
            b := false;
      end
      else
      begin
         move ( topbox^.index[curtop + 1],
                varbox^.index[curtop],
                (splmax - curtop) * sizeof ( Splitrec ) );
         topbox^.count := topbox^.count - 1;
         allrec.indout := allrec.indout + 1;
         allrec.recout := allrec.recout + 1;
         if puttop then
         begin
            if not (putdef) then
               b := false;
         end
         else
            b := false
      end;
   end
   else
      splerr.recnum := 48;
   if b then
      limrec := limrec - 1;
   if limrec < 0 then
      limrec := 0;
   delrec := b;
end;

function tsplx.modrec ( idx : string ) : boolean;
{This function replaces the current record by a new one}
var
   b : boolean;
begin
   b := true;
   if delrec then
   begin
      if not ( addrec ( idx ) ) then
         b := false
   end
   else
      b := false;
   modrec := b
end;

function tsplx.firstrec : boolean;
{This function locates and loads the first record in DB}
var
   l, ind : longint;
   s : string;
   b : boolean;
begin
   b := true;
   if activedb then
   begin
      if dbempty then
      begin
         splerr.recstr := 'Empty database.';
         b := false
      end
   end
   else
   begin
      splerr.recstr := 'No active database';
      b := false
   end;
   if b then
   begin
      curtop := 1;
      l := 1;
      s := topbox^.index[l].data;
      ind := topbox^.index[l].ptr;

      if ind > 0 then
      begin
         if getsubindex(ind) then
         begin
            s := varbox^.index[1].data;
            currec := varbox^.index[1].ptr;
            curind := s;
            curpos := 1;
            if not (pullrec) then
            begin
               b := false;
               splerr.recnum := 35;
               splerr.recstr := 'Unable to load record';
            end;
         end
         else
         begin
            b := false;
            splerr.recnum := 36;
            splerr.recstr := 'Error loading subindex';
         end;
      end
   end
   else
      splerr.recnum := 47;
   firstrec := b;
end;

function tsplx.lastrec : boolean;
{This function locates and loads the last record in DB}
var
   l, ind : longint;
   s : string;
   b : boolean;
begin
   b := true;
   if activedb then
   begin
      if dbempty then
      begin
         splerr.recstr := 'Empty database.';
         b := false
      end
   end
   else
   begin
      splerr.recstr := 'No active database';
      b := false
   end;
   if b then
   begin
      curtop := topbox^.count;
      l := topbox^.count;
      s := topbox^.index[l].data;
      ind := topbox^.index[l].ptr;

      if ind > 0 then
      begin
         if getsubindex(ind) then
         begin
            s := varbox^.index[varbox^.count].data;
            currec := varbox^.index[varbox^.count].ptr;
            curind := s;
            curpos := varbox^.count;
            if not (pullrec) then
            begin
               b := false;
               splerr.recnum := 37;
               splerr.recstr := 'Unable to load record.';
            end;
         end
         else
         begin
            b := false;
            splerr.recnum := 38;
            splerr.recstr := 'Error loading subindex';
         end;
      end
   end
   else
      splerr.recnum := 46;
   lastrec := b;
end;

function tsplx.nextrec : boolean;
{This function locates and loads the next record in DB}
var
   l, ind : longint;
   s : string;
   b : boolean;
begin
   b := true;
   if activedb then
   begin
      if not (dbempty) then
      begin
         if not (activerec) then
         begin
            splerr.recstr := 'No active record.';
            b := false
         end
      end
      else
      begin
         splerr.recstr := 'Empty database.';
         b := false
      end
   end
   else
   begin
      splerr.recstr := 'No active database';
      b := false
   end;
   if b then
   begin
      l := curpos + 1;
      if l > varbox^.count then
      begin
         if curtop < topbox^.count then
         begin
            curtop := curtop + 1;
            l := curtop;
            s := topbox^.index[l].data;
            ind := topbox^.index[l].ptr;
            if ind > 0 then
            begin
               if getsubindex(ind) then
               begin
                  s := varbox^.index[1].data;
                  currec := varbox^.index[1].ptr;
                  curind := s;
                  curpos := 1;
                  if not (pullrec) then
                  begin
                     b := false;
                     splerr.recnum := 39;
                     splerr.recstr := 'Error accesing fields';
                  end;
               end
               else
               begin
                  b := false;
                  splerr.recnum := 40;
                  splerr.recstr := 'Error loading subindex';
               end;
            end
         end
      end
      else
      begin
         s := varbox^.index[l].data;
         currec := varbox^.index[l].ptr;
         curind := s;
         curpos := l;
         if not (pullrec) then
         begin
            b := false;
            splerr.recnum := 41;
            splerr.recstr := 'Error loading record';
         end;
      end
   end
   else
      splerr.recnum := 45;
   nextrec := b
end;

function tsplx.prevrec : boolean;
{This function locates and loads the previous record in DB}
var
   l, ind : longint;
   s : string;
   b : boolean;
begin
   b := true;
   if activedb then
   begin
      if not (dbempty) then
      begin
         if not (activerec) then
         begin
            splerr.recstr := 'No active record.';
            b := false
         end
      end
      else
      begin
         splerr.recstr := 'Empty database.';
         b := false
      end
   end
   else
   begin
      splerr.recstr := 'No active database';
      b := false
   end;
   if b then
   begin
      l := curpos - 1;
      if l = 0 then
      begin
         if curtop > 1 then
         begin
            curtop := curtop - 1;
            l := curtop;
            s := topbox^.index[l].data;
            ind := topbox^.index[l].ptr;
            if ind > 0 then
            begin
               if getsubindex(ind) then
               begin
                  s := varbox^.index[varbox^.count].data;
                  currec := varbox^.index[varbox^.count].ptr;
                  curind := s;
                  curpos := varbox^.count;
                  if not (pullrec) then
                  begin
                     b := false;
                     splerr.recnum := 42;
                     splerr.recstr := 'Error loading record';
                  end;
               end
               else
               begin
                  b := false;
                  splerr.recnum := 43;
                  splerr.recstr := 'Error loading subindex';
               end;
            end
         end
      end
      else
      begin
         s := varbox^.index[l].data;
         currec := varbox^.index[l].ptr;
         curind := s;
         curpos := l;
         if not (pullrec) then
         begin
            b := false;
            splerr.recnum := 41;
            splerr.recstr := 'Error loading record';
         end;
      end
   end
   else
      splerr.recnum := 44;
   prevrec := b
end;

procedure Register;
begin
  RegisterComponents('Samples', [tsplx]);
end;

end.