{------------------------------------------------------------------------------}
{
   Unit Name: sqlcom
   Purpose  : To give function to handle database tables
   Author   : Vesa Lappalainen
   Date     : -99
   Changed  : 18.7.2000/vl
    + DoChange to change field types in existing table

   ToDo     :
} 
{------------------------------------------------------------------------------}

unit sqlcom;
{$define SQLDebug}  // Define this to monitor SQL-sentences

interface
uses DBTables,db;

function ExecSQL(q:TQuery;s:string):boolean;
function OpenSQL(q:TQuery;s:string):boolean;
function SelectSQL(q:TQuery;s:string;field:integer):boolean;
function FindSQLValue(q:TQuery;s:string;field:integer):string;
function JustFind(q:TQuery;s:string):boolean;
function JustFindNext(q:TQuery;s:string):boolean;
function RefreshAndFind(q:TQuery;s:string):boolean;
function UpdateQuery(q:TQuery):boolean;
function JustRefresh(q:TQuery):boolean;
function AddClipboardToDB(Query:TDataSet; const sep:string = #9):string;
function CopyDBToClipboard(Query:TDataSet; const sep:string = #9):string;
function SaveDBAsTextFile(Query:TDataSet; const name:string; const sep:string=#8) : string;
procedure DoIndex(const t,ind:string);
procedure DoExec(const s:string);
procedure DoChange(const tabname,fieldname,fieldtype,fieldsize:string);
function FilterStr(const s:string):string; overload;
function FilterStr(const f:TField):string; overload;

implementation
uses clipbrd,SysUtils, classes,bde
{$ifdef SQLDebug}
  ,kErrors
{$endif}
;

{$ifdef SQLDebug}
var ceSQLDebug:TCommError;
{$endif}


function FilterStr(const s:string):string;
begin
  Result := #39+s+#39;
end;

function FilterStr(const f:TField):string;
begin
  Result := #39+f.AsString+#39;
end;

function ExecSQL(q:TQuery;s:string):boolean;
begin
  Result := True;
  q.Close;
  q.SQL.Clear;
  q.SQL.Add(s);
{$ifdef SQLDebug}
  ceSQLDebug.Add(s);
{$endif}
  q.ExecSQL;
end;

function OpenSQL(q:TQuery;s:string):boolean;
begin
  Result := True;
  q.Close;
  q.SQL.Clear;
  q.SQL.Add(s);
{$ifdef SQLDebug}
  ceSQLDebug.Add(s);
{$endif}
  q.Open;
end;

function SelectSQL(q:TQuery;s:string;field:integer):boolean;
begin
  q.Close;
  q.SQL.Clear;
  q.SQL.Add(s);
{$ifdef SQLDebug}
  ceSQLDebug.Add(s+' '+IntToStr(field));
{$endif}
  q.Open;
//  Result := q.RecordCount > 0;
  Result := q.Fields[field].AsString <> '';
end;

function FindSQLValue(q:TQuery;s:string;field:integer):string;
begin
  Result := '';
  if ( not SelectSQL(q,s,field) ) then exit;
  Result := q.Fields[field].AsString;
  q.Close;
end;

function JustFind(q:TQuery;s:string):boolean;
begin
  q.Filter := s;
  Result := q.FindFirst;
end;

function JustFindNext(q:TQuery;s:string):boolean;
begin
  q.Filter := s;
  Result := q.FindNext;
end;

function RefreshAndFind(q:TQuery;s:string):boolean;
begin
  if not ( q.State in [dsInactive] ) then q.Close;
  q.Open;
  Result := JustFind(q,s);
end;

function JustRefresh(q:TQuery):boolean;
//var oldln : TBookmark;
begin
  Result := false;
  q.Refresh;
(*
// Hukkaa editointitilan?
  try
  oldln := nil;
  if not ( q.State in [dsInactive] ) then begin
    q.DisableControls;
    oldln := q.GetBookmark;
    q.Close;
  end;
  q.Open;
  if ( Assigned(oldln) ) then begin
    q.GotoBookmark(oldln);
    q.FreeBookmark(oldln);
  end;
  Result := true;
  finally
  if ( Assigned(oldln) ) then q.FreeBookmark(oldln);
  q.EnableControls;
  end;
*)
end;

function UpdateQuery(q:TQuery):boolean;
var n : LongInt;
begin
  Result := true;
  if q.CanModify then begin q.Refresh; exit; end;
  n := q.RecNo;
  q.DisableControls;
  q.Close; q.Open;
  q.RecNo := n;
  q.EnableControls;
end;

function CopyDBToClipboard(Query:TDataSet; const sep:string):string;
var i,c,rn,n:integer;  tsep,line:string;
begin
  Result := '';
  n := Query.RecordCount;
  rn := Query.RecNo;
  if ( n > 400 ) then n := 400;
  Clipboard.Open;
  Clipboard.Clear;
  line := '';
  Query.First;
  tsep := '';
 try
  Query.DisableControls;
  for c:=0 to Query.Fields.Count-1 do begin
    line := line + tsep + Query.Fields[c].FieldName;
    tsep := sep;
  end;
  line := line + #13#10;
  for i:=0 to n-1 do begin
    tsep := '';
    for c:=0 to Query.Fields.Count-1 do begin
      line := line + tsep + Query.Fields[c].DisplayText;
      tsep := sep;
    end;
    line := line + #13#10;
    Query.Next;
  end;
  Clipboard.AsText := line;
 finally
  Query.RecNo := rn;
  Query.EnableControls;
  Clipboard.Close;
end;
end;

function AppendOneLine(Query:TDataSet;s,sep:string):string;
var i,n,p,l:integer; field:string;
begin
  Result :='';
  l := Length(sep);
  try
  Query.Insert;
  except
  end;
  n := Query.FieldCount;
  for i:=0 to n-1 do begin
     p := Pos(sep,s);
     if ( p > 0 ) then begin
        field := Copy(s,1,p-1);
        Delete(s,1,p+l-1);
     end
     else begin
       field := s;
       s := '';
     end;
     Query.Fields[i].AsString := field;
  end;
end;


function AddClipboardToDB(Query:TDataSet; const sep:string):string;
var st : TStringList; i:integer;
begin
  Result :='';
  Clipboard.Open;
  st := TStringList.Create;
  st.SetText(PChar(Clipboard.AsText));
  Clipboard.Close;
  for i:=0 to st.Count-1 do begin
    AppendOneLine(Query,st[i],sep);
  end;
  st.Free;
  try
    Query.Post;
  except
    Query.Cancel;
  end;
end;


function SaveDBAsTextFile(Query:TDataSet; const name,sep:string) : string;
var i,c,rn,n:integer;  tsep,line:string; f:TextFile;
begin
  Result := '';
  n := Query.RecordCount;
  rn := Query.RecNo;
  line := '';
  AssignFile(f,name);
{$i-}
  Rewrite(f);
  if ( IoResult <> 0 ) then begin
    Result := 'Can not open file ' + name;
    Exit;
  end;
{$i+}
 try
  Query.DisableControls;
  Query.First;
  tsep := '';
  line := '';
  for c:=0 to Query.Fields.Count-1 do begin
    line := line + tsep + Query.Fields[c].FieldName;
    tsep := sep;
  end;
  writeln(f,line);
  for i:=0 to n-1 do begin
    tsep := '';
    line := '';
    for c:=0 to Query.Fields.Count-1 do begin
      line := line + tsep + Query.Fields[c].DisplayText;
      tsep := sep;
    end;
    writeln(f,line);
    Query.Next;
  end;
  Clipboard.AsText := line;
 finally
  CloseFile(f);
  Query.RecNo := rn;
  Query.EnableControls;
end;
end;

procedure DoFileExec(q:TQuery;const filename:string);
var f:TextFile; s:string;
begin
  Assign(f,filename);
  try
    Reset(f);
  except
    Exit;
  end;

  try
    while (not Eof(f) ) do begin
      readln(f,s);
      if ( s = '' ) then exit;
      q.SQL.Clear;
      q.SQL.Add(s);
      try q.ExecSQL; except end;
    end;
  finally
    CloseFile(f);
  end;
end;

procedure DoExec(const s:string);
var q : TQuery;
begin
  q := nil;
  try
    q := TQuery.Create(nil);
    if ( Pos('file:',s) = 1 ) then begin DoFileExec(q,Copy(s,6,200)); exit; end;
    q.SQL.Add(s);
    q.ExecSQL;
  finally
    q.Free;
  end;
end;

procedure DoIndex(const t,ind:string);
var table : TTable;
    px : string;
begin
  px := ChangeFileExt(t,'.px');
  DeleteFile(px);
  table := TTable.Create(nil);
  table.Exclusive := true;
  table.TableName := t;
  table.Open;
  table.AddIndex('', ind, [ixPrimary]);
  table.Free;
end;


//-----------------------------------------------------------------------------
// Functions to change field type
//-----------------------------------------------------------------------------

type

  ChangeRec = packed record
    szName: DBINAME;
    iType: Word;
    iSubType: Word;
    iLength: Word;
    iPrecision: Byte;
    end;

procedure ChangeField(Table: TTable; Field: TField; Rec: ChangeRec);

var
  Props: CURProps;
  hDb: hDBIDb;
  TableDesc: CRTblDesc;
  pFields: pFLDDesc;
  pOp: pCROpType;
  B: Byte;
begin
  // Initialize the pointers...
  pFields := nil; if ( pFields <> nil ) then exit;
  pOp := nil;     if ( pOp <> nil ) then exit;
  // Make sure the table is open exclusively so we can get the db handle...
  if not Table.Active then
    raise EDatabaseError.Create('Table must be opened to restructure');
  if not Table.Exclusive then
    raise EDatabaseError.Create('Table must be opened exclusively' +

      'to restructure');
  Check(DbiSetProp(hDBIObj(Table.Handle), curxltMODE, Integer(xltNONE)));
  // Get the table properties to determine table type...
  Check(DbiGetCursorProps(Table.Handle, Props));
  // Make sure the table is either Paradox or dBASE...
  if (Props.szTableType <> szPARADOX) and (Props.szTableType <> szDBASE) then
    raise EDatabaseError.Create('Field altering can only occur on Paradox' +
      ' or dBASE tables');

  // Allocate memory for the field descriptor...
  pFields := AllocMem(Table.FieldCount * sizeof(FLDDesc));
  // Allocate memory for the operation descriptor...
  pOp := AllocMem(Table.FieldCount * sizeof(CROpType));
  try
    // Set the pointer to the index in the operation descriptor to put
    // crMODIFY (This means a modification to the record is going to happen)...
    Inc(pOp, Field.Index);
    pOp^ := crMODIFY;
    Dec(pOp, Field.Index);
    // Fill the field descriptor with the existing field information...

    Check(DbiGetFieldDescs(Table.Handle, pFields));
    // Set the pointer to the index in the field descriptor to make the
    // midifications to the field
    Inc(pFields, Field.Index);
    // If the szName portion of the ChangeRec has something in it, change it...
    if (Length(Rec.szName) > 0) then
      pFields^.szName := Rec.szName;
    // If the iType portion of the ChangeRec has something in it, change it...
    if (Rec.iType > 0) then

      pFields^.iFldType := Rec.iType;
    // If the iSubType portion of the ChangeRec has something in it, change it...
    if (Rec.iSubType > 0) then
      pFields^.iSubType := Rec.iSubType;
    // If the iLength portion of the ChangeRec has something in it, change it...
    if (Rec.iLength > 0) then
      pFields^.iUnits1 := Rec.iLength;
    // If the iPrecision portion of the ChangeRec has something
    // in it, change it...
    if (Rec.iPrecision > 0) then

      pFields^.iUnits2 := Rec.iPrecision;
    Dec(pFields, Field.Index);
    for B := 1 to Table.FieldCount do begin
      pFields^.iFldNum := B;
      Inc(pFields, 1);
    end;
    Dec(pFields, Table.FieldCount);

    // Blank out the structure...
    FillChar(TableDesc, sizeof(TableDesc), #0);
    //  Get the database handle from the table's cursor handle...
    Check(DbiGetObjFromObj(hDBIObj(Table.Handle), objDATABASE, hDBIObj(hDb)));

    // Put the table name in the table descriptor...
    StrPCopy(TableDesc.szTblName, Table.TableName);
    // Put the table type in the table descriptor...
    StrPCopy(TableDesc.szTblType, Props.szTableType);
    // The following three lines are necessary when doing any field restructure
    // operations on a table...

    // Set the field count for the table
    TableDesc.iFldCount := Table.FieldCount;
    // Link the operation descriptor to the table descriptor...

    TableDesc.pecrFldOp := pOp;
    // Link the field descriptor to the table descriptor...
    TableDesc.pFldDesc := pFields;
    // Close the table so the restructure can complete...
    Table.Close;
    // Call DbiDoRestructure...
    Check(DbiDoRestructure(hDb, 1, @TableDesc, nil, nil, nil, False));
  finally
    if (pFields <> nil) then
      FreeMem(pFields);
    if (pOp <> nil) then

      FreeMem(pOp);
  end;
end;

function IndexOfType(fieldtype:string):integer;
begin
  Result := 0;
  if fieldtype = '' then exit;
  case fieldtype[1] of
  'A' : Result := fldZSTRING	;
  'I' : Result := fldINT32	;
  'S' : Result := fldINT16	;
  'N' : Result := fldFLOAT      ;
  'D' : Result := fldDATE       ;
  'T' : Result := fldTIME       ;
  '@' : Result := fldTIMESTAMP  ;
  '+' : Result := fldstAUTOINC  ;
  '#' : Result := fldBCD        ;
  end;
end;

procedure DoChange(const tabname,fieldname,fieldtype,fieldsize:string);
var table : TTable; field : TField; cr : ChangeRec;
begin
  table := nil;
  try
    table := TTable.Create(nil);
    table.Exclusive := true;
    table.TableName := tabname;
    table.Open;
    field := table.FieldByName(fieldname);
  with cr do begin
    StrCopy(szName,PChar(field.FullName));
    iType := IndexOfType(fieldtype);
    iSubType := 0;
    iLength := StrToInt(fieldsize);
    iPrecision := 0;
  end;
  ChangeField(table, field, cr);


//    ShowMessage(field.FullName);
  finally
    table.Free;
  end;
end;

initialization begin
{$ifdef SQLDebug}
  RegisterError(ceSQLDebug,'sql','SQL debug',False,True,True);
{$endif}
end;


end.