paradoxqbecomponent

{Here is a component that will work with paradox style QBE:}

Unit UTqbe; { Small DBdataset derived class and TREMOTEQBE }

{ David Berneda
100115,1155@compuserve.com }

{
NEW !!! TRemoteQBE to execute qbe queries remotely
(needs REMOQUE.EXE on the remote machine)

NEW !!! Function GetUserName:String (returns IDAPI user name or Paradox)
}

{ NEW !!! AnswerType property allows to PARADOX,DBASE and ASCII answer table types }
{ NEW !!! Query params can be defined (see demo.pas) }

interface

Uses Classes,DBTables,DB,SysUtils,DBConsts,LibConst,dbiProcs,dbiTypes,
DsgnIntf;

{ WARNING: READ CAREFULLY AND GOOD LUCK USING TQBE }
(*
Answer table name can be specified with or without alias.
Eg: :dbdemos:void.db

Assumed answer table Driver: PARADOX
The new property: AnswerType allows to PARADOX,DBASE and ASCII answer table types

If the answer table exists, an atempt to delete it is made before copying
the result cursor.
The phisical answer table must be opened in exclusive mode and all related
family files are erased together with the table.

Other functions in this unit:

** Function GetAliasPath(Const Alias:String):String;
Returns the path for the "alias" or a empty string if not found.
Eg: ('dbdemos') returns 'c:\delphi\demos\data'

** Function GetDBTablePath(Const TableName:String):String;
Returns the TableName with path instead of alias (if it has an alias).
Eg: (':dbdemos:customer.db') returns 'c:\delphi\demos\data\customer.db'

Const MaxParam = 5; { max number of query parameters }
MaxParamLen=30; { max length of a substituted param }

Type TQBE=Class(TDBDataSet)
     private
       FAnswerTable:String;
       FAnswerType:TTableType;
       FBlankasZero,
       FAuxTables,
       FRequestLive:Boolean;
     protected
       function CreateHandle: HDBICur; override;
       procedure GenerateAnswer(Var p:HDbiCur);
       Function CreateSubstituted:TStrings;
     public
       FQBE: TStrings;
       NumParam:Integer;
       Param,Subst:Array[0..MaxParam] of String[MaxParamLen];
       procedure SetQBE(QBE: TStrings);
       Constructor Create(AOwner:TComponent); override;
       destructor Destroy; override;
       Procedure AddParam(Const tmpParam,tmpSubst:String);
       Function ReplaceString(s:String):String;
       Procedure ClearParams;
     published
       property QBE: TStrings read FQBE write SetQBE;
       property AnswerTable: String read FAnswerTable write FAnswerTable;
       property BlankasZero: Boolean read FBlankasZero write FBlankAsZero;
       property AuxTables: Boolean read FAuxTables write FAuxTables;
       property AnswerType:TTableType read FAnswerType write FAnswerType;
       property RequestLive: Boolean read FRequestLive write FRequestLive;
     End;

     TRemoteStatus=( rsStart,
                     rsWaitingBegin,
                     rsWaitingExecution,
                     rsOK,
                     rsError,
                     rsTimeout,
                     rsIdle,
                     rsCancel
                     );

TNotifyRemote=procedure(Sender:TObject; what:TRemoteStatus) of object;

     TRemoteQBE=Class(TQBE)
     Private
       FCancel:Boolean;
       FOnWaiting:TNotifyRemote;
       FSecondsTimeout:Longint;
       FDoRemote:Boolean;
       Procedure Notify(what:TRemoteStatus);
     protected
       function CreateHandle: HDBICur; override;
     public
       Constructor Create(AOwner:TComponent); override;
     published
       property OnWaiting:TNotifyRemote read FOnWaiting write FOnWaiting;
       property SecondsTimeout:Longint read FSecondsTimeout write FSecondsTimeout default 60;
       property DoRemote:Boolean read FDoRemote write FDoRemote default TRUE;
       property Cancel:Boolean read FCancel write FCancel;
     End;

Function GetAliasPath(Const Alias:String):String;
Function GetDBTablePath(Const TableName:String):String;
Procedure Register;

implementation

Uses WinProcs,IniFiles,Dialogs,dbiErrs,Forms;

Constructor TQBE.Create(AOwner:TComponent);
Begin
inherited Create(AOwner);
FQBE := TStringList.Create;
NumParam:=0;
FAnswerType:=ttParadox; { by default, Paradox answer tables }
end;

destructor TQBE.Destroy;
Begin
FQBE.Free;
inherited Destroy;
End;

Procedure TQBE.ClearParams;
Begin
NumParam:=0; { reset params to zero (no params) }
End;

Procedure TQBE.AddParam(Const tmpParam,tmpSubst:String);
Begin
if (tmpParam<>'') and (tmpParam<>tmpSubst) then
Begin
    if NumParam<MaxParam then
    Begin
      Inc(NumParam);
      Param[NumParam]:=tmpParam;
      Subst[NumParam]:=tmpSubst;
    End
    Else Raise Exception.Create('Max number of query parameters achieved');
End;
End;

Function TQBE.ReplaceString(s:String):String;
Var t,i:Integer;
Begin
for t:=1 to NumParam do
Repeat
i:=Pos(Param[t],s);
if i>0 then s:=Copy(s,1,i-1)+Subst[t]+Copy(s,i+Length(Param[t]),255);
Until i=0;
result:=s;
End;

Function TQBE.CreateSubstituted:TStrings;
Var NewQBE:TStrings;
    t:Integer;
Begin
NewQBE:=TStringList.Create;
if Assigned(NewQBE) then
Begin
    With FQBE do
    for t:=0 to Count-1 do NewQBE.Add(ReplaceString(Strings[t]));
End;
result:=NewQBE;
End;

function TQBE.CreateHandle: HDBICur;
Var p:HDbiCur;
    Stmt:hDBIStmt;
    NewQBE:TStrings;
Begin
NewQBE:=CreateSubstituted;
try
    Check(dbiQPrepare(DBHandle,qryLangQBE,NewQBE.GetText,Stmt));
    if FRequestLive then Check(dbiSetProp(hDBIObj(Stmt),stmtLIVENESS,Longint(wantLive)))
                    Else Check(dbiSetProp(hDBIObj(Stmt),stmtLIVENESS,Longint(wantDefault)));
    if FBlankAsZero then Check(dbiSetProp(hDBIObj(Stmt),stmtBLANKS,1));
    if FAuxTables then Check(dbiSetProp(hDBIObj(Stmt),stmtAUXTBLS,1));
    Check(dbiQExec(Stmt,@p));
    Check(dbiQFree(Stmt));
    GenerateAnswer(p);
finally
    NewQBE.Free;
end;
Result:=p;
End;

procedure TQBE.GenerateAnswer(Var p:HDbiCur);
Var aBatTblDesc:BATTblDesc;
    tmpType:String;
    r:Longint;
    dbiErr:DBIRESULT;
Begin
if (FAnswerTable<>'') And Assigned(p) then
try
    Check(DbiSetToBegin(p));
    With aBatTblDesc do
    Begin
      hDB:=DBHandle;
      StrPCopy(szTblName,GetDBTablePath(FAnswerTable));
      Case FAnswerType of
        ttParadox: tmpType:=szParadox;
        ttDbase : tmpType:=szDbase;
        ttAscii : tmpType:=szAscii;
      end;
      StrPCopy(szTblType,tmpType);
      szUsername[0]:=#0;
      szPassword[0]:=#0;
    End;
    r:=0;
    dbiErr:=dbiDeleteTable(DBHandle,aBatTblDesc.szTblName,aBatTblDesc.szTblType);
    if dbiErr<>DBIERR_NOSUCHTABLE then Check(dbiErr);
    Check(DbiBatchMove(nil,p,@aBatTblDesc,nil,batchCOPY,0,
                            nil, nil, nil, 0, nil, nil,
                            nil, nil, nil, nil, TRUE, TRUE,
                            r, TRUE));
    Check(dbiCloseCursor(p));
    Check(DbiOpenTable(DBHandle, aBatTblDesc.szTblName, aBatTblDesc.szTblType,
                       nil, nil, 0,
                       dbiReadWrite,
                       dbiOpenShared,
                       xltField,
                       False,
                       nil,
                       p));
finally
End;
end;

procedure TQBE.SetQBE(QBE: TStrings);
begin
FQBE.Assign(QBE);
end;

Function HasAlias(Const TableName:String):Boolean;
Begin
Result:=Pos(':',TableName)>0;
End;

Function GetAliasPath(Const Alias:String):String;
Var AliasList:TStringList;
    i:Longint;
    DBPath:String;
Begin
Result:='';
AliasList:=TStringList.Create;
try
    Session.GetAliasNames(AliasList);
    i:=AliasList.IndexOf(Alias);
    if i<0 then raise EDatabaseError.Create('Alias '+Alias+' doesnt exist')
    else
    Begin
      Session.GetAliasParams(Alias,AliasList);
      DBPath := AliasList.Values['PATH'];
      if DBPath='' then raise EDatabaseError.Create('Alias path from '+Alias+' invalid')
                   else Result:=DBPath;
    end;
finally
    AliasList.Free;
end;
End;

Procedure SplitTableName(Const TableName:String; Var Alias,Name:String);
Var p1,p2:Integer;
Begin
Name:=TableName;
Alias:='';
p1:=Pos(':',TableName);
if p1>0 then
Begin
    p2:=Pos(':',Copy(TableName,p1+1,255));
    if p2>0 then
    Begin
      Alias:=Copy(TableName,p1+1,p2-1);
      Name:=Copy(TableName,p1+p2+1,255);
    End;
End;
End;

Function GetDBTablePath(Const TableName:String):String;
Var Alias,Name:String;
Begin
if not HasAlias(TableName) then Result:=TableName
else
Begin
    SplitTableName(TableName,Alias,Name);
    if Alias<>'' then Result:=GetAliasPath(Alias)+'\'+Name
                 else Result:=TableName;
End;
End;

Type TString=Array[0..255] of char;

Function GetUserName:String;
Var St:TString;
Begin
result:='Unknown';
if DbiGetNetUserName(St)=DBIERR_NONE then
     result:=StrPas(St)
else
With TIniFile.Create('win.ini') do
try
    result:=ReadString('PDOXWIN','USERNAME','UNKNOWN');
finally
    Free;
End;
end;

{ TREMOTE QBE }

Constructor TRemoteQBE.Create(AOwner:TComponent);
Begin
inherited Create(AOwner);
FSecondsTimeout:=60;
FDoRemote:=TRUE;
FCancel:=FALSE;
End;

Procedure TRemoteQBE.Notify(what:TRemoteStatus);
Begin
if Assigned(FOnWaiting) then
try
FOnWaiting(Self,what);
except
on Exception do ;
end;
End;

function TRemoteQBE.CreateHandle: HDBICur;

    Function WaitServer(Table:TTable; NumQuery:Longint; Const WaitFor:String):String;
    Var Timeout:Longint;
    Begin
      result:='';
      Timeout:=GetTickCount+SecondsTimeout*1000;
      Repeat
        Notify(rsIdle);
        Table.Refresh;
        Application.ProcessMessages;
        if Table.FindKey([NumQuery]) then
           result:=Table.FieldByName('Estado').AsString
        else
           result:='';
      Until (Pos(result,WaitFor)>0) or
            (GetTickCount>Timeout) or
            FCancel or
            Application.Terminated;
      if FCancel then result:='C'; { canceled }
    End;

Var Status:String;
    SAnswer:TString;
    t:TTable;
    NewQBE:TStrings;
    NumQuery:Longint;
Begin
FCancel:=False;
if not FDoRemote then
Begin
    result:=Inherited CreateHandle;
    exit;
end;
result:=nil;
Notify(rsStart);
t:=TTable.Create(Self);
with t do
try
    DatabaseName:='REMOQUE';
    TableName:='remoque.db';
    IndexFieldNames:='NumeroConsulta';
    Open;
    Append;
    FieldByName('Fecha').AsDateTime:=SysUtils.Date;
    FieldByName('Hora').AsDateTime:=Now;
    FieldByName('Cliente').AsString:='DELPHI';
    FieldByName('Cliente').AsString:='DELPHI';
    FieldByName('Usuario').AsString:=GetUserName;
    FieldByName('TipoConsulta').AsString:='Q';
    NewQBE:=CreateSubstituted;
    try
      FieldByName('Consulta').Assign(NewQBE);
    finally
      NewQBE.Free;
    end;
    FieldByName('Estado').AsString:='P';
    FieldByName('Error').AsString:='';
    Post;
    NumQuery:=FieldByName('NumeroConsulta').AsInteger;
    Notify(rsWaitingBegin);
    Status:=WaitServer(t,NumQuery,'EOM');
    if Status='E' then
    Begin
      Notify(rsWaitingExecution);
      Status:=WaitServer(t,NumQuery,'OM');
    end;
    if Status='O' then
    Begin
      Notify(rsOK);
      StrPCopy(SAnswer,GetAliasPath('REMOQUE')+'\PERSONAL\'+FieldByName('NumeroConsulta').AsString);
      Check(DbiOpenTable(DBHandle, SAnswer, szParadox,
                                       nil, nil, 0,
                                       dbiReadWrite,
                                       dbiOpenShared,
                                       xltField,
                                       False,
                                       nil,
                                       Result));
      GenerateAnswer(result);
    end
    else
    if Status='M' then
    Begin
      Notify(rsError);
      raise Exception.Create(FieldByName('Error').AsString);
    end
    else
    if Status='P' then
    Begin
      Notify(rsTimeout);
      if FindKey([NumQuery]) then
      try
        Edit;
        FieldByName('Estado').AsString:='T';
        FieldByName('Error').AsString:='Timeout';
        Post;
      finally
        raise Exception.Create('Timeout while waiting RemoQUE Server');
      end;
    end
    else
    if Status='C' then { cancelled query }
    try
      Notify(rsCancel);
      if FindKey([NumQuery]) then
      try
        Edit;
        FieldByName('Estado').AsString:='C';
        FieldByName('Error').AsString:='Canceled';
        Post;
      finally
      end;
    finally
      SysUtils.Abort;
    End;
finally
    Free;
end;
End;

Procedure Register;
Begin
RegisterComponents(LoadStr(srDAccess),[TQBE,TRemoteQBE]);
End;

end.