[Back to MISC SWAG index] [Back to Main SWAG index] [Original]

    {$F+,O+}
    UNIT OOPX;
                         (**************************************)
                         (*         OOPX  Version 1.00         *)
                         (* Object-Oriented Interface for the  *)
                         (*    Paradox Engine Version 2.0      *)
                         (*    and Turbo Pascal Version 6.0    *)
                         (*     Copyright 1991 Brian Corll     *)
                         (**************************************)
                         (*    Portions Copyright 1990-1991    *)
                         (*        Borland International       *)
                         (**************************************)

    INTERFACE

    Uses PXEngine;

    const
         PXError : Integer = PXSUCCESS;
         VarLong  = 1;
         VarInt   = 2;
         VarDate  = 3;
         VarDoub  = 4;
         VarAlpha = 5;
         VarShort = 6;

    type
       DateRec = record
          M,D,Y : Integer;
          end;

    type
       PXObject = object
          ErrCode : Integer;
          THandle : TableHandle;
          RHandle : RecordHandle;
          LHandles: Array[1..32] of LockHandle;
          SearchBuf : RecordHandle;
          LastLock: Byte;
          Name    : String;
          RecNo   : RecordNumber;
          Locked  : Boolean;
          UnLocked: Boolean;
          constructor InitName(TblName : String);
          constructor InitOpen(TblName : String;
                      IndexID : Integer;
                      SaveEveryChange : Boolean);
          constructor InitCreate(TblName : String;
                      NFields : Integer;
                      Fields,Types : NamesArrayPtr);
          destructor Done;
          procedure  ClearErrors;
          procedure  LockRecord;
          procedure  LockTable(LockType : Integer);
          procedure  UnLockRecord;
          procedure  UnLockTable(LockType : Integer);
          procedure  RenameTable(FromName,ToName : String);
          procedure  AddTable(AddTableName : String);
          procedure  CopyTable(CopyName : String);
          procedure  CreateIndex(NFlds : Integer;
                     FldHandles : FieldHandleArray;
                     Mode : Integer);
          procedure  Encrypt(Password : String);
          procedure  Decrypt(Password : String);
          procedure  DeleteIndex(IndexID : Integer);
          procedure  EmptyTable;
          procedure  EmptyRecord;
          procedure  ReadRecord;
          procedure  InsertRecord;
          procedure  AddRecord;
          procedure  UpdateRecord;
          procedure  DeleteRecord;
          procedure  NextRecord;
          procedure  PrevRecord;
          procedure  GotoRecord(R : RecordNumber);
          procedure  Flush;
          procedure  SearchField(FHandle : FieldHandle;Mode : Integer);
          procedure  SearchKey(NFlds : Integer;Mode : Integer);
          procedure  InitSearchBuf(FldName : NameString;var Variable;VarType : Byte);
          procedure  PutField(FldName : NameString;var Variable);
          procedure  PutLongField(FldName : NameString;var L : Longint);
          procedure  GetField(FldName : NameString;var Variable);
          procedure  GetLongField(FldName : NameString;var L : Longint);
          function   FieldNumber(FldName : NameString) : Integer;
          function   FieldName(FHandle : FieldHandle) : NameString;
          function   FieldType(FHandle : FieldHandle) : NameString;
          function   IsBlank(FldName : NameString) : Boolean;
          function   TableChanged : Boolean;
          procedure  Refresh;
          procedure  Top;
          procedure  Bottom;
          function   GetRecordNumber : Longint;
          end;

    function PXOk : Boolean;

    IMPLEMENTATION

       function PXOk : Boolean;
       begin
          PXOk := (PXError = PXSUCCESS);
       end;

       constructor PXObject.InitName;
       begin
          Name := TblName;
       end;

       constructor PXObject.InitOpen;
       begin
          THandle := 0;
          Name := '';
          ErrCode := PXTblOpen(TblName,
                              THandle,
                              IndexID,
                              SaveEveryChange);
          If ErrCode = PXSUCCESS then
          begin
          Name := TblName;
          ErrCode := PXRecBufOpen(THandle,RHandle);
          ErrCode := PXRecBufOpen(THandle,SearchBuf);
          end;
          LastLock := 0;
          FillChar(LHandles,32,0);
          PXError := ErrCode;
          Locked := False;
          UnLocked := False;
       end;

       constructor PXObject.InitCreate(TblName : String;
                      NFields : Integer;
                      Fields,Types : NamesArrayPtr);
       begin
          ErrCode := PXTblCreate(TblName,NFields,Fields,Types);
          PXError := ErrCode;
       end;

       procedure  PXObject.Encrypt(Password : String);
       begin
          ErrCode := PXTblEncrypt(Name,Password);
          If ErrCode = PXERR_TABLEOPEN then
          begin
             ErrCode := PXTblClose(THandle);
             If ErrCode = PXSUCCESS then
             ErrCode := PXTblEncrypt(Name,Password);
          end;
          PXError := ErrCode;
       end;

       procedure PXObject.ClearErrors;
       begin
          ErrCode := 0;
          PXError := 0;
       end;

       procedure  PXObject.Decrypt(Password : String);
       begin
         ErrCode := PXPswAdd(Password);
         If ErrCode = PXSUCCESS then
         begin
          ErrCode := PXTblDecrypt(Name);
          If ErrCode = PXERR_TABLEOPEN then
          begin
             ErrCode := PXTblClose(THandle);
             If ErrCode = PXSUCCESS then
             ErrCode := PXTblDecrypt(Name);
          end;
         end;
         PXError := ErrCode;
       end;

       procedure PXObject.CreateIndex(NFlds : Integer;
                    FldHandles : FieldHandleArray;
                    Mode : Integer);
       begin
          ErrCode := PXKeyAdd(Name,NFlds,FldHandles,Mode);
          PXError := ErrCode;
       end;

       procedure PXObject.DeleteIndex;
       begin
          ErrCode := PXKeyDrop(Name,IndexID);
          PXError := ErrCode;
       end;

       procedure PXObject.Flush;
       begin
          ErrCode := PXSave;
          PXError := ErrCode;
       end;

       procedure PXObject.LockRecord;
       var LockTest : Boolean;
       begin
          Locked := False;
          Inc(LastLock);
          ErrCode := PXNetRecLock(THandle,LHandles[LastLock]);
          ErrCode := PXNetRecLocked(THandle,LockTest);
          Locked := (ErrCode = PXSUCCESS)
             and LockTest;
          If not Locked then Dec(LastLock);
          PXError := ErrCode;
       end;

       procedure PXObject.LockTable;
       begin
          Locked := False;
          ErrCode := PXNetTblLock(THandle,LockType);
          Locked := (ErrCode = PXSUCCESS);
          PXError := ErrCode;
       end;

       procedure  PXObject.UnLockRecord;
       begin
          UnLocked := False;
          ErrCode := PXNetRecUnlock(THandle,LHandles[LastLock]);
          If (ErrCode = PXSUCCESS) then
          begin
             UnLocked := True;
             LHandles[LastLock] := 0;
             Dec(LastLock);
          end;
       end;

       procedure  PXObject.UnLockTable(LockType : Integer);
       begin
          UnLocked := False;
          ErrCode := PXNetTblUnlock(THandle,LockType);
          PXError := ErrCode;
          UnLocked := (PXError = PXSUCCESS);
       end;

       procedure PXObject.RenameTable(FromName,ToName : String);
       begin
          ErrCode := PXTblRename(FromName,ToName);
          PXError := ErrCode;
       end;

       procedure PXObject.AddTable(AddTableName : String);
       begin
          ErrCode := PXTblAdd(AddTableName,Name);
          PXError := ErrCode;
       end;

       procedure PXObject.CopyTable(CopyName : String);
       begin
          ErrCode := PXTblCopy(Name,CopyName);
          PXError := ErrCode;
       end;

       procedure PXObject.EmptyTable;
       begin
          ErrCode := PXTblEmpty(Name);
          PXError := ErrCode;
       end;

       procedure PXObject.EmptyRecord;
       begin
          ErrCode := PXRecBufEmpty(RHandle);
          PXError := ErrCode;
       end;

       procedure PXObject.ReadRecord;
       begin
          ErrCode := PXRecGet(THandle,RHandle);
          PXError := ErrCode;
       end;

       procedure PXObject.InsertRecord;
       begin
          ErrCode := PXRecInsert(THandle,RHandle);
          PXError := ErrCode;
       end;

       procedure PXObject.AddRecord;
       begin
          ErrCode := PXRecAppend(THandle,RHandle);
          PXError := ErrCode;
       end;

       procedure PXObject.UpdateRecord;
       begin
          ErrCode := PXRecUpdate(THandle,RHandle);
          PXError := ErrCode;
       end;

       procedure PXObject.DeleteRecord;
       begin
          ErrCode := PXRecDelete(THandle);
          PXError := ErrCode;
       end;

       procedure PXObject.NextRecord;
       begin
          ErrCode := PXRecNext(THandle);
          PXError := ErrCode;
       end;

       procedure PXObject.PrevRecord;
       begin
          ErrCode := PXRecPrev(THandle);
          PXError:= ErrCode;
       end;

       procedure PXObject.GotoRecord(R : RecordNumber);
       begin
          ErrCode:= PXRecGoto(THandle,R);
          PXError := ErrCode;
       end;

       procedure PXObject.PutField(FldName : NameString;var Variable);
       var FType : NameString;
           FirstChar : Char;
           FHandle : FieldHandle;
       begin
          FHandle := FieldNumber(FldName);
          If (PXError <> PXSUCCESS) then Exit;
          ErrCode := PXFldType(THandle,FHandle,FType);
          FirstChar := FType[1];
          case FirstChar of
          'D' : ErrCode := PXPutDate(RHandle,FHandle,TDate(Variable));
          'A' : ErrCode := PXPutAlpha(RHandle,FHandle,String(Variable));
          '$','N'
              : ErrCode := PXPutDoub(RHandle,FHandle,Double(Variable));
          'S' : ErrCode := PXPutShort(RHandle,FHandle,Integer(Variable));
          end;
          PXError := ErrCode;
       end;

       procedure PXObject.InitSearchBuf(FldName : NameString;var Variable;VarType : Byte);
       var FHandle : FieldHandle;
       begin
          FHandle := FieldNumber(FldName);
          If (PXError <> PXSUCCESS) then Exit;
          case VarType of
          VarDate  : ErrCode := PXPutDate(SearchBuf,FHandle,TDate(Variable));
          VarAlpha : ErrCode := PXPutAlpha(SearchBuf,FHandle,String(Variable));
          VarDoub  : ErrCode := PXPutDoub(SearchBuf,FHandle,Double(Variable));
          VarShort : ErrCode := PXPutShort(SearchBuf,FHandle,Integer(Variable));
          VarLong  : ErrCode := PXPutLong(SearchBuf,FHandle,Longint(Variable));
          end;
          PXError := ErrCode;
       end;

       procedure PXObject.PutLongField(FldName : NameString;var L : Longint);
       var FHandle : FieldHandle;
       begin
          FHandle := FieldNumber(FldName);
          If (PXError <> PXSUCCESS) then Exit;
          ErrCode := PXPutLong(RHandle,FHandle,L);
          PXError := ErrCode;
       end;

       procedure PXObject.GetField(FldName : NameString;var Variable);
       var FType : NameString;
           FirstChar : Char;
           FHandle : FieldHandle;
       begin
          FHandle := FieldNumber(FldName);
          If (PXError <> PXSUCCESS) then Exit;
          ErrCode := PXFldType(THandle,FHandle,FType);
          FirstChar := FType[1];
          case FirstChar of
          'D' : ErrCode := PXGetDate(RHandle,FHandle,TDate(Variable));
          'A' : ErrCode := PXGetAlpha(RHandle,FHandle,String(Variable));
          '$','N'
              : ErrCode := PXGetDoub(RHandle,FHandle,Double(Variable));
          'S' : ErrCode := PXGetShort(RHandle,FHandle,Integer(Variable));
          end;
          PXError := ErrCode;
       end;

       procedure  PXObject.GetLongField(FldName : NameString;var L : Longint);
       var FHandle : FieldHandle;
       begin
          FHandle := FieldNumber(FldName);
          If (PXError <> PXSUCCESS) then Exit;
          ErrCode := PXGetLong(RHandle,FHandle,L);
          PXError := ErrCode;
       end;

       function PXObject.GetRecordNumber : Longint;
       begin
          ErrCode := PXRecNum(THandle,RecNo);
          If (ErrCode = PXSUCCESS) then
             GetRecordNumber := RecNo;
          PXError := ErrCode;
       end;

       function PXObject.FieldNumber(FldName : NameString) : Integer;
       var FldHandle : FieldHandle;
       begin
          ErrCode := PXFldHandle(THandle,FldName,FldHandle);
          If (ErrCode = PXSUCCESS) then FieldNumber := FldHandle
          else FieldNumber := 0;
          PXError := ErrCode;
       end;

       function PXObject.IsBlank(FldName : NameString) : Boolean;
       var Blank : Boolean;
           FHandle : FieldHandle;
       begin
          FHandle := FieldNumber(FldName);
          If (ErrCode <> PXSUCCESS) then PX(PXError);
          IsBlank := False;
          ErrCode := PXFldBlank(RHandle,FHandle,Blank);
          If ErrCode = PXSUCCESS then IsBlank := Blank;
          PXError := ErrCode;
       end;

       function PXObject.TableChanged : Boolean;
       var Changed : Boolean;
       begin
          TableChanged := False;
          ErrCode := PXNetTblChanged(THandle,Changed);
          If ErrCode = PXSUCCESS then
             TableChanged := Changed;
          PXError := ErrCode;
       end;

       procedure PXObject.Refresh;
       begin
          ErrCode := PXNetTblRefresh(THandle);
          PXError := ErrCode;
       end;

       function  PXObject.FieldName(FHandle : FieldHandle) : NameString;
       var FName : NameString;
       begin
          ErrCode := PXFldName(THandle,FHandle,FName);
          If ErrCode = PXSUCCESS then
             FieldName := FName
          else
             FIeldName := '';
          PXError := ErrCode;
       end;

       procedure PXObject.SearchField(FHandle : FieldHandle;Mode : Integer);
       begin
          ErrCode := PXSrchFld(THandle,SearchBuf,FHandle,Mode);
          PXError := ErrCode;
       end;

       procedure PXObject.SearchKey(NFlds : Integer;Mode : Integer);
       begin
          ErrCode := PXSrchKey(THandle,SearchBuf,NFlds,Mode);
          PXError := ErrCode;
       end;

       function  PXObject.FieldType(FHandle : FieldHandle) : NameString;
       var FType : NameString;
       begin
          FieldType := '';
          ErrCode := PXFldType(THandle,FHandle,FType);
          If ErrCode = PXSUCCESS then FieldType := FType;
          PXError := ErrCode;
       end;

       procedure PXObject.Top;
       begin
          ErrCode := PXRecFirst(THandle);
          PXError := ErrCode;
       end;

       procedure PXObject.Bottom;
       begin
          ErrCode := PXRecLast(THandle);
          PXError := ErrCode;
       end;

       destructor PXObject.Done;
       begin
          ErrCode := PXRecBufClose(RHandle);
          ErrCode := PXRecBufClose(SearchBuf);
          ErrCode := PXTblClose(THandle);
          PXError := ErrCode;
       end;

    begin
    end.

[Back to MISC SWAG index] [Back to Main SWAG index] [Original]