Chip 2001 December/Chip_2001-12_cd1.bin/zkuste/delphi/kompon/d23456/BKQUERY.ZIP/uEQuery.pas

Pascal/Delphi Source File | 2001-10-02 | 18.8 KB | 661 lines

unit uEQuery;


(*
 TEQuery component
 Autor:Jan TUNGLI  Email:[e-mail]
                   http://www.tungli.host.sk

 TEQuery:= Wait Query + Parse Query

 PARSE Query SQL syntax  (select type) ;
 Example:
   EQuery1.SQL_Parse(EQuery1.SQL.text);    // inicialization
   (or EQuery1.Parse // self parse)
   S:=EQuery1.SQL_GetSegment('where');    //S = 'where Name>"A"'
   S:=EQuery1.SQL_GetSegment('from');     //S = 'from ANIMALS'
   S:=EQuery1.SQL_GetSegment('order');    //S = ''
   EQuery1.SQL_ChangeSegment('select Name');   //oSQL.text = 'select Name from ANIMALS where Name>"A"'
   EQuery1.SQL_AddToWhere(' Name<"z" ');           //oSQL.text = 'select Name from ANIMALS where (Name>"A") and Name<"z"'
   EQuery1.SQL_DeleteFrom Where(' Name<"z" ');    //oSQL.text = 'select Name from ANIMALS where Name>"A"'
   EQuery1.SQL_ChangeSegment('where');         //oSQL.text = 'select Name from ANIMALS'
   EQuery1.SQL_ChangeSegment('order by Name'); //oSQL.text = 'select Name from ANIMALS order by Name'
   EQuery1.SQL.text:=EQuery1.SQL_Text;  //Query1.SQL.text = 'select Name from ANIMALS order by Name'
   (or EQuery1.SQL.text:=EQuery1.SQL_New;
    or SQL_Set(EQuery1) )
   EQuery1.Open;
*)

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Db, DBTables,Clipbrd;

type  TSQLParseRec=record A,B:word; W: String; end;

  TEQuery = class(TQuery)
  private
    fS:TStringList;
    fSave,fload,fFields,fRef:boolean;
    FRoundDelay : Integer;
    FRoundCount : Integer;
    FErrorLock  : Boolean;

    oSyntax:TStringList;
    oSQL:TStringList;
    oWords:array[1..20] of TSQLParseRec;
    oOldSQL:string; // pre parse
    oOldAddToWhere:string;

    procedure SetShowDialog(pB:boolean);
    procedure SetSave(pB:boolean);
    procedure SetLoad(pB:boolean);
    procedure SetFields(pB:boolean);
    procedure WriteFields(pMode:byte);
    procedure MyExecute (FuncName : String);
    procedure SetoSQL(pS:TStringList);
    procedure SetoOldSQL(pS:String);
    procedure SetOldWhere(pS:String);
    function ABCopy(pS:String; pA,pB:longint):String;
    { Private declarations }
  protected
    { Protected declarations }
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
      procedure ExecSQL;
      procedure Open;
      procedure First;
      procedure Next;
      procedure Last;
      procedure Prior;
 //     procedure MoveBy(pM:integer);
      { Public declarations }
  published
      property RoundDelay : Integer read  FRoundDelay    //default po 1 sec. skusi vykonat query
                                    write FRoundDelay;
      property RoundCount : Integer read  FRoundCount    //default 10 krat po 1 sec skusi vykonat query
                                    write FRoundCount;
      property ErrorLock  : Boolean read  FErrorLock;
         //ak je true tak tabulku poiziva iny uzivatel (jeho query este nedobehol)

    property References:TStringList read fS write fS;
    property Dialog_Fields:boolean read fRef write SetShowDialog;
    property Exec_SaveToClipboard:boolean read fSave write SetSave;
    property Exec_LoadToClipboard:boolean read fLoad write SetLoad;
    property Exec_FieldsToClipboard:boolean read fFields write SetFields;
    property Parse_Syntax:TStringList read oSyntax write oSyntax;
    property SQL_New:TStringList read oSQL write SetoSQL;
    property SQL_Old:string read oOldSQL write SetoOldSQL;
    property SQL_LastAddToWhere : string read oOldAddToWhere write SetOldWhere;

    procedure Parse;
    procedure SQL_Parse(pS:String);   //SQL parse
    function  SQL_GetSegment(pKeyWord:string):string; // vrati segment SQL dotazu
    procedure SQL_ChangeSegment(pSegment:string);
    procedure SQL_AddToWhere(pS:String);
    procedure SQL_DeleteFromWhere(pS:String);
    function  SQL_Text:string;
    function  SQL_SelectCount(pQ:Tquery):integer;  // becasue RecordCount is very slowly
    procedure SQL_Set(pQ:TQuery);
    { Published declarations }
  end;

(*procedure Register;*)

implementation
uses uEQueryForm;
const
  cDBErrorLock = -210;

//var cMoveBy:integer;

Constructor TEQuery.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  fS:=TStringList.Create;
  FRoundDelay := 1000;
  FRoundCount := 5;
  oOldSQL:='';
  oSQL:=TStringList.Create;
  oSyntax:=TStringList.Create;
  with oSyntax do begin
    Clear;
    Add('SELECT');  // SELECT must by first keyword
    Add('FROM');
    Add('WHERE');
    Add('GROUP');
    Add('HAVING');
    Add('UNION');
    //Add('PLAN');      // Interbase
    Add('ORDER');
    Add('COMPUTE');   // for MS_SQL
    Add('FOR');       // MS_SQL: FOR BROWSE or INTERBASE: FOR UPDATE
    Add('INTO');      // for INFORMIX  (into temp)
  end;
End;

Destructor TEQuery.Destroy;
begin
  if oSyntax<>nil then begin oSyntax.Free; oSyntax:=nil; end;
  if oSQL<>nil then begin oSQL.Free; oSQL:=nil; end;
  try
    if fS<>nil then begin fS.Free; fS:=nil; end;
  except end;
  Active:=false;
  inherited Destroy;
end;

procedure TEQuery.MyExecute (FuncName : String);
var I       : Integer;
    FuncNum : Integer;
    OK      : Boolean;
begin
  FuncName := UpperCase (FuncName);

  if FuncName = 'EXECSQL'    then FuncNum := 0
  else if FuncName = 'OPEN'  then FuncNum := 1
  else if FuncName = 'FIRST' then FuncNum := 2
  else if FuncName = 'NEXT'  then FuncNum := 3
  else if FuncName = 'LAST'  then FuncNum := 4
  else if FuncName = 'PRIOR' then FuncNum := 5
//  else if FuncName = 'MOVEBY' then FuncNum := 6
  else FuncNum := -1;

  OK := false;
  I  := 1;

  while (not OK) and (I < RoundCount) do
    begin
    FErrorLock := false;
    OK         := false;
    try
      case FuncNum of
        0 : inherited ExecSQL;
        1 : inherited Open;
        2 : inherited First;
        3 : inherited Next;
        4 : inherited Last;
        5 : inherited Prior;
//        6 : inherited MoveBy(cMoveBy);
        end; // case
      OK := true;
    except
      on E:EDBEngineError do
        begin
        if E.ErrorCount >= 2 then
          if E.Errors[1].NativeError = cDbErrorLock then
            FErrorLock := true;
        if not FErrorLock then raise;
        end; // on
      else raise;
    end; // try
    Inc(I);
    if not OK then Sleep (RoundDelay);
    end; // while

  if not OK then
    begin
    try
      case FuncNum of
        0 : inherited ExecSQL;
        1 : inherited Open;
        2 : inherited First;
        3 : inherited Next;
        4 : inherited Last;
        5 : inherited Prior;
//        6 : inherited MoveBy(cMoveBy);
        end; // case
//      OK := true;
    except
      on E:EDBEngineError do
        begin
        if E.ErrorCount >= 2 then
          if E.Errors[1].NativeError = cDbErrorLock then
            FErrorLock := true;
        raise;
        end; // on
      else raise;
    end; // try
  end; // if
end;

procedure TEQuery.SetShowDialog(pB:boolean);
begin
  fRef:=pB;
  try if F_EQRef<>nil then Execute_EQClose; except end;
  if pB then Execute_EQOpen(TQuery(self),fS);
  fRef:=false;
end;

procedure TEQuery.SetSave(pB:boolean);
begin
  fSave:=pB;
  try if pB then WriteFields(1);
  finally fSave:=false; end;
end;

procedure TEQuery.SetLoad(pB:boolean);
begin
  fLoad:=pB;
  try if pB then WriteFields(2);
  finally fLoad:=false; end;
end;

procedure TEQuery.SetFields(pB:boolean);
begin
  fFields:=pB;
  try if pB then WriteFields(0);
  finally fFields:=false; end;
end;

procedure TEQuery.WriteFields(pMode:byte);
var mS,mT,mT1:String;
    i,j:integer;
    mB:Boolean;
begin
    mT:='';
    mB:=Active;
    if Active=false then begin
      try Active:=true; except end;
      if Active=false then begin
        ShowMessage(Name+' query - open error');
        exit;
      end;
    end;
    for i:=0 to FieldCount-1 do begin
      mS:='String';
      case Fields[i].DataType of
      ftString: mS:='String';
      ftSmallint, ftInteger, ftWord: mS:='Integer';
      ftFloat:mS:='Float';
      ftDate, ftTime, ftDateTime:mS:='DateTime';
      end;
      mS:='FieldByName('+#39+Fields[i].FieldName+#39+').as'+mS;
      case pMode of
      1: {Save}
        begin
          mS:=mS+':=';
          j:=fS.IndexOfName(Fields[i].FieldName);
          if j>-1 then mT1:=fS.Strings[j]+' ' else mT1:='';
          mT1:=trim(copy(mT1,Pos('=',mT1)+1,255));
          if mT1<>'' then mS:=mS+mT1+'.text';
          mS:=mS+' ;';
        end;
      2: {Load}
        begin
          mS:=':='+mS;
          j:=fS.IndexOfName(Fields[i].FieldName);
          if j>-1 then mT1:=fS.Strings[j]+' ' else mT1:='';
          mT1:=trim(copy(mT1,Pos('=',mT1)+1,255));
          if mT1<>'' then mS:=mT1+'.text'+mS;
          mS:=mS+' ;';
        end;
     end;
      mT:=mT+mS+#13#10;
      Clipboard.AsText:=mT;
    end;
    if not mB then Active:=false;
End;

procedure TEQuery.ExecSQL;
begin
  MyExecute ('ExecSQL');
end;

//********************************************************

procedure TEQuery.Open;
begin
  MyExecute ('Open');
end;

//********************************************************

procedure TEQuery.First;
begin
  MyExecute ('First');
end;

//********************************************************

procedure TEQuery.Next;
begin
  MyExecute ('Next');
end;

//********************************************************

procedure TEQuery.Last;
begin
  MyExecute ('Last');
end;

//********************************************************

procedure TEQuery.Prior;
begin
  MyExecute ('Prior');
end;

(*
procedure TEQuery.MoveBy(pM:integer);
begin
  cMoveBy:=pM;
  MyExecute ('MoveBy');
end;
*)

//********************************************************

procedure TEQuery.Parse;
begin
  SQL_parse(Self.SQL.text);
end;

function TEQuery.SQL_SelectCount(pQ:Tquery):integer;
var mQ:TQuery;
begin
  result:=-1;
  mQ:=Tquery.Create(pQ.owner);
  try
    mQ.dataBaseName:=pQ.DatabaseName;
    SQL_Parse(pQ.SQL.text);
    SQL_ChangeSegment('select Count(*) as xSelCnt');
    mQ.SQL.Clear;
    mQ.SQL.Text:=oSQL.text;
    try
      mQ.Open;
      result:=mQ.FieldByName('xSelCnt').asInteger;
      mQ.Close;
    except end;
  finally
    mQ.Free;
  end;
end;

procedure TEQuery.SQL_Parse(pS:String);   //SQL parse
var
    mS:String;
    i,j,k,mA:integer;
    mB,mC:boolean;
begin
  while Pos(#13#10#13#10,pS)>0 do system.delete(pS,Pos(#13#10#13#10,pS),2);
  while Pos(#13#13,pS)>0 do system.delete(pS,Pos(#13#13,pS),1);
  if Trim(pS)='' then begin
    oOldSQL:='';
    for i:=1 to 20 do begin oWords[i].A:=0; oWords[i].B:=0;end;
    exit;
  end;
  if (oOldSQL=pS) and (oSQL.text<>'') then exit;  // netreba vykonat uz bola vykonana
  oSQL.text:=pS;
  oOldSQL:=pS;
  for i:=oSyntax.Count-1 downto 0 do oSyntax.Strings[i]:=TRIM(AnsiUpperCase(oSyntax.Strings[i]));
  for i:=oSyntax.Count-1 downto 0 do if oSyntax.Strings[i]='' then oSyntax.delete(i);
  for i:=0 to oSyntax.Count-1 do oWords[i+1].W:=oSyntax.Strings[i];
  for i:=1 to 20 do begin oWords[i].A:=0; oWords[i].B:=0;end;
  mS:=AnsiUpperCase(pS);
  mA:=0; mB:=false; mC:=false;
  for i:=1 to length(pS)-1 do begin
    if (not (mB or mC)) and (mS[i]='(') then inc(mA);
    if (not (mB or mC)) and (mS[i]=')') then dec(mA);
    if (not mC) and (mS[i]='"') then mB:=not(mB);
    if (not mB) and (mS[i]=#39) then mC:=not(mC);
    if (mA=0) and (not mB) and (not mC) then begin
      if oWords[1].A=0 then begin
        if Length(mS)>=i+length(oWords[1].W) then begin
          if (oWords[1].W=copy(mS,i,length(oWords[1].W))) and (mS[i+length(oWords[1].W)] in [' ',#13]) then oWords[1].A:=i;
        end;
      end else begin
        for j:=2 to oSyntax.Count do begin
          if oWords[j].A=0 then begin
            if length(mS)>=i+length(oWords[j].W) then begin
              if (oWords[j].W=copy(mS,i,length(oWords[j].W))) and (mS[i+length(oWords[j].W)] in [' ',#13]) then begin
                oWords[j].A:=i;
                for k:=j-1 downto 1 do if (oWords[k].A>0) and (oWords[k].A<i) and (oWords[k].B=0) then oWords[k].B:=i-1;
                Break;
              end;
            end;
          end;
        end;
      end;
    end;
  end;
  for k:=oSyntax.Count downto 1 do if (oWords[k].A>0) and (oWords[k].A<length(mS)) and (oWords[k].B=0) then oWords[k].B:=length(pS);
End;

Function TEQuery.ABCopy(pS:String; pA,pB:longint):String;
begin
  Result:='';
  if pB<pA then Exit;
  if Length(pS)<=pA then Exit;
  Result:=copy(pS,pA,pB-pA+1);
End;

function TEQuery.SQL_GetSegment(pKeyWord:string):string; // vrati segment SQL dotazu

  Function Spaces2To1(pS:string):String;
  begin
    while Pos('  ',pS)>0 do System.Delete(pS,Pos('  ',pS),1);
    Result:=pS;
  End;

  function Normal(pT:String):String;
  var h:integer;
  begin
    Result:=Spaces2To1(pT);
    h:=Pos(#13#10,pT);
    while h>0 do begin
      system.delete(pT,h,2);
      h:=Pos(#13#10,pT);
    end;
  end;

  var i:integer;
      mKey:byte;
begin
  Result:=''; mKey:=0;
  pKeyWord:=Trim(AnsiUpperCase(pKeyWord));
  for i:=1 to oSyntax.Count do begin
    if Trim(oWords[i].W)=pKeyWord then begin mKey:=i;Break; end;
  end;
  if mKey=0 then exit;
  if oWords[mKey].A>0 then begin
    Result:=Trim(ABcopy(oSQL.text,oWords[mKey].A,oWords[mKey].B));
    Result:=Normal(Result);
  end;
end;

procedure TEQuery.SQL_ChangeSegment(pSegment:string);
  procedure AddSegment(pKeyWord,pSegment:string);
  var i,mKey:integer;
      mS:String;
  begin
    mKey:=0;
    for i:=0 to oSyntax.Count-1 do begin
      if oSyntax.Strings[i]=pKeyWord then begin mKey:=i; break; end;
    end;
    if mKey=0 then exit;
    for i:=mKey downto 1 do begin
      if (oWords[i].B)>0 then begin
        mS:=oSQL.text;
        system.insert(#13#10+pSegment+#13#10,mS,oWords[i].B+1);
        while Pos(#13#10#13#10,mS)>0 do system.delete(mS,Pos(#13#10#13#10,mS),2);
        oSQL.text:=mS;
        break;
      end;
    end;
  End;
const cD=240;
var i,j,mA,mKey,mI:integer;
    mT,mS,mKeyWord:string;
    mB,mC:boolean;
begin
  if oWords[1].W='' then SQL_Parse(oSQL.text);
  oOldSQL:='';
  pSegment:=Trim(pSegment);
  if (length(pSegment)>cD) then begin
   // rozlamanie pSegment na max. cD dlhe riadky
    mA:=0; mB:=false; mC:=false; mI:=0;
    for i:=1 to length(pSegment) do begin
      inc(mI);
      if (not (mB or mC)) and (pSegment[i]='(') then inc(mA);
      if (not (mB or mC)) and (pSegment[i]=')') then dec(mA);
      if (not mC) and (pSegment[i]='"') then mB:=not(mB);
      if (not mB) and (pSegment[i]=#39) then mC:=not(mC);
      if (mA=0) and (not mB) and (not mC) then begin
        if (mI>5) and ((pSegment[i]=' ') or (pSegment[i]=',')) then begin
          if pSegment[i]=',' then mS:=mS+','+#13#10 else mS:=mS+' '+#13#10;
          mI:=0;
        end else mS:=mS+pSegment[i];
      end else mS:=mS+pSegment[i];
    end;
    // mS je teraz uplne rozlamany
    // ideme viazat riadky do dlzky cD
    j:=Pos(#13#10,mS); mT:=''; pSegment:='';
    if j=0 then j:=length(mS)+1;
    while (j>0) and (Length(mS)>0) do begin
      if length(mT)+Length(copy(mS,1,j-1))<=cD then mT:=mT+copy(mS,1,j-1)
      else begin
        pSegment:=pSegment+mT+#13#10;
        mT:=copy(mS,1,j-1);
      end;
      system.delete(mS,1,j+1);
      j:=Pos(#13#10,mS);
      if j=0 then j:=length(mS)+1;
    end;
    pSegment:=pSegment+mT+#13#10;
  end;
  mKey:=0;
  j:=Pos(' ',pSegment); if j=0 then j:=Pos(#13,pSegment); if j>10 then j:=0;
  if j=0 then mKeyWord:=Trim(AnsiUpperCase(pSegment)) else mKeyWord:=Trim(AnsiUpperCase(copy(pSegment,1,j)));
  for i:=1 to oSyntax.Count do begin
    if Trim(oWords[i].W)=mKeyWord then begin mKey:=i;Break; end;
  end;
  if mKey=0 then exit;  // neexistujuci segment error
  if j=0 then begin   // treba segment vymazat
    if oWords[mKey].A>0 then begin // ak segment exituje tak odstranime
      mS:=oSQL.Text;
      system.delete(mS,oWords[mKey].A,oWords[mKey].B -oWords[mKey].A+1);
      while Pos(#13#10#13#10,mS)>0 do system.delete(mS,Pos(#13#10#13#10,mS),2);
      oSQL.text:=mS;
    end;
  end else begin
    if oWords[mKey].A=0 then AddSegment(mKeyWord,pSegment) // treba segment pridat
    else begin
      mS:=oSQL.Text;   // treba segment prepisat
      if oWords[mKey].A-1>1 then mT:=copy(mS,1,oWords[mKey].A-1) else mT:='';
      mS:=copy(mS,oWords[mKey].B+1,length(oSQL.text));
      if mT<>'' then mT:=mT+#13#10;
      mS:=mT+pSegment+#13#10+mS;
      while Pos(#13#10#13#10,mS)>0 do system.delete(mS,Pos(#13#10#13#10,mS),2);
      oSQL.Text:=mS;
    end;
  end;
  SQL_Parse(oSQL.text);
End;

procedure TEQuery.SQL_AddToWhere(pS:String);
var mS:String;
    i:integer;
begin
  oOldAddToWhere:=pS;
  if trim(pS)='' then exit;
  mS:=TrimLeft(SQL_GetSegment('where'));
  if Trim(mS)<>'' then begin
    i:=Pos(' ',mS); if (i=0) or (i>6) then i:=6;
    system.insert('(',mS,i+1);
    mS:=mS+') and '+pS
  end else mS:='where '+ pS;
  SQL_ChangeSegment(mS);
end;

procedure TEQuery.SQL_DeleteFromWhere(pS:String);
// tato procedura je urcena iba pre odstanenie casi Where segmentu
//ktora bola pridana AddToWhere procedurou  -  remove AddToWhere
var mS:String;
    i:integer;
begin
  if trim(pS)='' then exit;
  mS:=Trim(SQL_GetSegment('where'));
  system.delete(mS,1,5);
  mS:=trim(mS);
  pS:=Trim(pS);
  i:=Pos(pS,mS); if i=0 then exit;
  system.delete(mS,i,Length(pS));
  mS:=trim(mS);
  if length(mS)>3 then begin
    if AnsiUpperCase(Copy(mS,Length(mS)-2,3))='AND' then begin
      system.delete(mS,Length(mS)-2,3);
      mS:=trim(mS);
      if length(mS)>1 then begin
        if (mS[1]='(') and (mS[length(mS)]=')') then begin
          system.delete(mS,1,1); system.delete(mS,Length(mS),1);
          mS:=trim(mS);
        end;
      end;
    end;
  end;
  mS:=Trim('where '+mS);
  SQL_ChangeSegment(mS);
end;

function TEQuery.SQL_Text:string;
begin;
  result:=oSQL.text;
end;

procedure TEQuery.SetoSQL(pS:TStringList);
begin
  oSQL.Clear;
  oSQL.text:=pS.text;
  SQL_Parse(pS.text);
end;

procedure TEQuery.SetoOldSQL(pS:String);
begin
  // read only
 // su tu iba preto aby bolo ich vidiet v object inspectoru
end;

procedure TEQuery.SetOldWhere(pS:String);
begin
 //read only
 // su tu iba preto aby bolo ich vidiet v object inspectoru
end;

procedure TEQuery.SQL_Set(pQ:TQuery);
var Q:TQuery;
    a,b:boolean;
    s:string;
begin
  s:=SQL_Text;
  if pQ.SQL.Text=s then exit;
  b:=pQ.ParamCount>0;
  if b then begin
    Q:=TQuery.Create(nil);
    Q.SQL.text:=pQ.sql.text;
    Q.Params:=pQ.Params;
    Q.SQL.text:=pQ.SQL.Text;
  end;
  pQ.DisableControls;
  pQ.close;
  pQ.SQL.Text:=s;
  try
    if b then pQ.Params:=Q.params;
   finally
    pQ.EnableControls;
    if b then Q.Free;
  end;
end;

(*
procedure Register;
begin
  RegisterComponents('Edge', [TEQuery]);
end;
*)

end.