sdcommon.pas

SQLDirect Component Library is a light-weight Borland Database Engine replacement for Borland Delphi

procedure SetFieldBlobData(RecBuf: TSDRecordBuffer; ABlobCacheOffs, AFieldOffset: Integer; Value: TSDBlobData);
procedure SetFieldInfoStruct(Buffer: TSDPtr; Offset: Integer; Value: TSDFieldInfo);

function HelperLoadLibrary(ALibFileName: string): HMODULE;

function HelperMemReadByte(const Ptr: TSDPtr; Offset: Integer): Byte;
function HelperMemReadInt16(const Ptr: TSDPtr; Offset: Integer): Smallint;
function HelperMemReadInt32(const Ptr: TSDPtr; Offset: Integer): Integer;
function HelperMemReadInt64(const Ptr: TSDPtr; Offset: Integer): TInt64;
function HelperMemReadDateTimeRec(const Ptr: TSDPtr; Offset: Integer): TDateTimeRec;
function HelperMemReadDouble(const Ptr: TSDPtr; Offset: Integer): Double;
function HelperMemReadPtr(const Ptr: TSDPtr; Offset: Integer): TSDPtr;
function HelperMemReadSingle(const Ptr: TSDPtr; Offset: Integer): Single;
procedure HelperMemWriteByte(const Ptr: TSDPtr; Offset: Integer; Value: Byte);
procedure HelperMemWriteInt16(const Ptr: TSDPtr; Offset: Integer; Value: Smallint);
procedure HelperMemWriteInt32(const Ptr: TSDPtr; Offset, Value: Integer);
procedure HelperMemWriteInt64(const Ptr: TSDPtr; Offset: Integer; Value: TInt64);
procedure HelperMemWriteDateTimeRec(const Ptr: TSDPtr; Offset: Integer; Value: TDateTimeRec);
procedure HelperMemWriteDouble(const Ptr: TSDPtr; Offset: Integer; Value: Double);
procedure HelperMemWriteGuid(const Ptr: TSDPtr; Offset: Integer; Value: TGUID);
procedure HelperMemWritePtr(const Ptr: TSDPtr; Offset: Integer; Value: TSDPtr);
procedure HelperMemWriteString(const Ptr: TSDPtr; Offset: Integer; Value: string; Count: Integer);
function HelperPtrToString(const Ptr: TSDPtr; Len: Integer = -1): string;
procedure HelperAssignParamValue(AParam: TSDHelperParam; Value: TDateTimeRec);
function HelperCurrToBCD(Curr: Currency; BCDPtr: TSDPtr; Precision: Integer = 32; Decimals: Integer = 4): Boolean;

function HelperCompareStr(const S1, S2: string): Integer;
function HelperCompareText(const S1, S2: string): Integer;

function IncPtr(const ptr: TSDPtr; Delta: Integer): TSDPtr;
function SafeReallocMem(const OldPtr: TSDPtr; Size: Integer): TSDPtr;
procedure SafeCopyMem(Src, Dest: TSDPtr; Count: Integer);
procedure SafeInitMem(Buffer: TSDPtr; Count: Integer; InitByte: Byte);


implementation


const
  DateTimeTypes		= [ftDate, ftTime, ftDateTime];
  NumericTypes		= [ftSmallInt, ftInteger, ftWord, ftFloat, ftCurrency,
                                ftBCD, ftAutoInc {$IFDEF SD_VCL4}, ftLargeInt{$ENDIF}];
  { Field types with changable size (require size defining) }
  RequiredSizeTypes	= [{ftBCD,} ftBytes, ftVarBytes, ftString, ftParadoxOle, ftDBaseOle,
                                ftTypedBinary];
  {   in DB.pas : TBlobType = ftBlob..ftTypedBinary; (D3-4, CB3-4),
                  TBlobType = ftBlob..ftOraClob (D5) includes not valid blob types (for example, ftCursor)  }
  BlobTypes		=
  	[ftBlob..ftTypedBinary] {$IFDEF SD_VCL5} + [ftOraBlob, ftOraClob] {$ENDIF};
  SupportedBlobTypes	=
        [ftBlob, ftMemo {$IFDEF SD_VCL5}, ftOraBlob, ftOraClob{$ENDIF}];

const
  Delimiters = [' ', #$0A, #$0D];

// If AParamName is prefixed with OldPrefix
function IsOldPrefixExists(const AParamName, OldPrefix: string): Boolean;
begin
        // exclude case, when a parameter name is equal 'OLD_' or other OldPrefix value
  Result := (CompareText( AParamName, OldPrefix ) <> 0) and
            (CompareText( Copy(AParamName, 1, Length(OldPrefix)), OldPrefix ) = 0);
end;

function IsSelectQuery(const SQL: string): Boolean;
var
  i, s: Integer;
  substr: string;
begin
  Result := False;
  s := 1;
  while (s <= Length(SQL)) and (AnsiChar(SQL[s]) in Delimiters) do
    Inc(s);
  substr := SQL_TOKEN_Select;
  for i:=0 to Length(substr)-1 do begin
    if ((s+i) > Length(SQL)) or (UpCase(SQL[s+i]) <> substr[i+1]) then
      Break;
      	// end of cycle
    if i = (Length(substr)-1) then
      Result := True;
  end;
end;

{ query must be a single table(which is returned as the result) SELECT statement
w/o aggregate SQL functions, <group by> and <union> clauses. When the query is not live, function returns an empty string }
function IsLiveQuery(const SQL: string): string;
{$IFNDEF SD_VCL5}
begin
  Result := '';
end;
{$ELSE}
const
  SInnerJoin = 'INNER JOIN ';       { do not localize }
  SOuterJoin = 'OUTER JOIN ';       { do not localize }

  ForbiddenSQLTokens = [stGroupBy, stUnion, stPlan];

  function IsGroupSQLFunc(const Str: string): Boolean;
  var
    s: string;
    i: Integer;
  begin
    Result := False;
    s := UpperCase(Str);
    i := Pos('(', s);   // to exclude recognition, for example, COUNT or COUNTRY column name as COUNT(*) function (which has to written without a space before '(' first bracket)
    if i > 0 then
      SetLength(s, i-1)
    else
      Exit;
    s := Trim(s);
    Result :=
    	(Pos('AVG', s) = 1) or
    	(Pos('COUNT', s) = 1) or
    	(Pos('MAX', s) = 1) or
    	(Pos('STDDEV', s) = 1) or   	// Oracle function
    	(Pos('SUM', s) = 1);
  end;
	// if a table separator exists in FROM section
  function NextTableExists(const Str: AnsiString): Boolean;
  var
    i: Integer;
  begin
    i := 1;
    while (i <= Length(Str)) and (Str[i] in Delimiters) do
      Inc(i);
    Result := (i <= Length(Str)) and (Str[i] = ',');
  end;

  function NextSQLTokenEx(const SQL: string; var p: Integer; out Token: string; CurSection: TSQLToken): TSQLToken;
{$IFDEF SD_CLR}
  begin
    Result := NextSQLToken(SQL, p, Token, CurSection);
{$ELSE}
  var
    pCur, pStart: PChar;
  begin
    pStart := PChar(SQL);
    pCur := pStart + p - 1;
    Result := NextSQLToken(pCur, Token, CurSection);
    p := pCur - pStart + 1;
{$ENDIF}
  end;

var
  Start: Integer;
  sTable, Token, sTemp: string;
  SQLToken, CurSection: TSQLToken;
  bFirstFromSect: Boolean;
begin
  Result := '';
  	// in case of non-SELECT statement (for example, procedure call)
  if not IsSelectQuery(SQL) then
    Exit;

  sTable := '';
  Start := 1;
  CurSection := stUnknown;
  	// locate first FROM section
  repeat
    SQLToken := NextSQLTokenEx(SQL, Start, Token, CurSection);
    if SQLToken in SQLSections then CurSection := SQLToken;
    if SQLToken in ForbiddenSQLTokens then
      Break;
    if (CurSection = stSelect) and (SQLToken = stFieldName) and IsGroupSQLFunc(Token) then
      Break;
  until SQLToken in [stEnd, stFrom];
  if SQLToken = stFrom then
    bFirstFromSect := True
  else
    Exit;

  repeat
    SQLToken := NextSQLTokenEx(SQL, Start, Token, CurSection);
	// SQL section is changed, Token is equal, for example, 'select', 'from' and other
    if SQLToken in SQLSections then begin
        // if the first FROM section ends
      if bFirstFromSect and (CurSection = stFrom) and (CurSection <> SQLToken) then
        bFirstFromSect := False;
      CurSection := SQLToken
    end else if (CurSection = stFrom) and (SQLToken in [stTableName, stValue]) and bFirstFromSect then begin
    	// stValue is returned if TableNames contain quote chars
      if sTable = '' then	// to exclude an alias adding (for example, TABLE1 as ALIAS1) or table adding from nested subqueries ('..WHERE EXISTS()')
        sTable := Token;
      	// if owner name is present, then add that
      while (SQL[Start] = '.') and not (SQLToken in [stEnd]) do begin
        SQLToken := NextSqlTokenEx(SQL, Start, Token, CurSection);
        sTable := sTable + '.' + Token;
      end;
      sTemp := Copy(SQL, Start, Length(SQL)-Start+1);
      	// if the next table exists in the FROM list
      if NextTableExists( sTemp ) then
        Break;
	// check inner/outer join clauses
      if (Pos(sTemp, SInnerJoin) > 0) or
         (Pos(sTemp, SOuterJoin) > 0)
      then
        Break;
    end;
  until (SQLToken in [stEnd] + ForbiddenSQLTokens);
	// if forbidden SQL tokens are not found
  if SQLToken in [stEnd] then
    Result := Trim(sTable);
end;
{$ENDIF}

procedure MoveString(SrcStr: string; SrcPos: Integer; var DestStr: string; DestPos, Count : Integer);
var
  i, DestLen: Integer;
begin
  DestLen := Length(DestStr);
  if DestLen < (DestPos + Count - 1) then
    SetLength(DestStr, DestPos + Count - 1);
  for i:=0 to Count-1 do
    DestStr[DestPos+i] := SrcStr[SrcPos+i];
end;

{ Parse SQL-statement and create instances of TSDParam }
procedure CreateParamsFromSQL(List: TSDHelperParams; const SQL: string; ParamPrefix: Char);
var
  CurPos, StartPos, Len: Integer;
  CurChar: Char;
  Literal: Char;	// #0, when the current character is not quoted, else it's equal the last significant quote
  EmbeddedLiteral: Boolean;
  s, sName: string;
begin
  S := SQL;
  Len := Length(S);
  if Len = 0 then
    Exit;
  CurPos := 1;
  Literal := #0;	// #0 - not inside a quoted string
  EmbeddedLiteral := False;
  repeat
    CurChar := S[CurPos];
    	// Is it parameter name ?
    if (CurChar = ParamPrefix) and not Boolean(Literal) and
       (CurPos < Len) and (S[CurPos + 1] <> ParamPrefix)
    then begin
      StartPos := CurPos;
        // locate end of parameter name
      while (CurChar <> #0) and (CurPos <= Len) and
            (Boolean(Literal) or not IsNameDelimiter(CurChar))
      do begin
        Inc(CurPos);
        if CurPos > Len then
          Break;
        CurChar := S[CurPos];
        if IsLiteral(CurChar) then begin
		// To process a quote, which is inside a parameter name like :"param's name"
          if not Boolean(Literal) then
            Literal := CurChar
          else if Literal = CurChar then	// the quoted string has to be finished by the same quote character
            Literal := #0;
            	// if a parameter name is quoted
          if CurPos = StartPos + 1 then EmbeddedLiteral := True;
        end;
      end;

      if EmbeddedLiteral then begin
        sName := StripLiterals( Copy(S, StartPos + 1, CurPos - StartPos - 1) );
        EmbeddedLiteral := False;
      end else
        sName := Copy(S, StartPos + 1, CurPos - StartPos - 1);
      if Assigned(List) then begin
{$IFDEF SD_VCL4}
        TParam(List.Add).Name := sName;
        List.ParamByName(sName).ParamType := ptInput;
{$ELSE}
        List.CreateParam(ftUnknown, sName, ptInput);
{$ENDIF}
      end;
    end else if (CurChar = ParamPrefix) and not Boolean(Literal) and (CurPos < Len) and (S[CurPos + 1] = ParamPrefix) then
        // remove one colon (ParamPrefix), which happens twice
      Delete(S, CurPos, 1)
    else if IsLiteral(CurChar) then begin
	// To process a quote, which is inside a quoted string like "param's :name"
      if not Boolean(Literal) then
        Literal := CurChar
      else if Literal = CurChar then
        Literal := #0;
    end;

    Inc(CurPos);
  until (CurChar = #0) or (CurPos > Len);
end;

// AFieldInfo = "FieldAlias=[Owner.]Table.Column"
function ExtractColumnName(const AFieldInfo: string): string;
var
  i: Integer;
begin
  Result := AFieldInfo;
  for i:=Length(Result) downto 1 do
    if Result[i] = '.' then begin
      Result := Copy(Result, i+1, Length(Result)-i);
      Break;
    end;
end;

{$IFDEF SD_VCL4}
{ TO-DO: Generates SELECT statement, when UpdateStatus=usUnmodified
  Function will return an empty string, if all modified values are equal it's old value.
FieldInfo.Strings[i] = "FieldAlias=[Owner.]Table.Column"
}
function GenerateSQL(UpdateStatus: TUpdateStatus; UpdateMode: TUpdateMode;
	const TableName: string; FieldInfo: TStrings; Fields: TFields; QuoteIdent: Boolean): string;
const
	// SQL tokens
  stSelectFmt	= 'select %s from %s';
  stInsertFmt	= 'insert into %s(%s) values(%s)';
  stDeleteFmt	= 'delete from %s %s';
  stUpdateFmt	= 'update %s set %s %s';
  stWhere	= 'where ';
  stAndOp 	= ' and';
  SetIndent	= '  ';
  vt_decimal    = $0E;  // it is unknown type for Delphi variant
var
  bIsModified: Boolean;
  sFields, sRealField, sKeys, sTable: string;
  i: Integer;
begin
  Result := '';
  sFields := '';
  sKeys := '';

  for i:=0 to Fields.Count-1 do begin
  	// only physical fields can be added in SQL statement
    if Fields[i].FieldKind <> fkData then
      Continue;
  	// update only modified fields.
        //Blobs are tested separately VarIsEqual(CompareString) can work incorrectly witn binaries, for example, in Wine.
        //However this code can't define, when blob was modified and new value is equal old one.
    if Fields[i] is TBlobField then
      bIsModified := TBlobField( Fields[i] ).Modified or (Fields[i].NewValue <> Fields[i].OldValue)
    else begin
{$IFNDEF SD_CLR}        // varUnknown - Indeclared identifier in D8 
      if (Fields[i].DataType = ftLargeInt) and
         ((VarType( Fields[i].NewValue ) in [varUnknown, vt_decimal]) or
          (VarType( Fields[i].OldValue ) in [varUnknown, vt_decimal])
         )
      then      // in this case, impossible to get a variant('Unknown type: 14') value
        bIsModified := True
      else
{$ENDIF}
        bIsModified := not VarIsEqual(Fields[i].NewValue, Fields[i].OldValue, False, False, True);
    end;
    sRealField := ExtractColumnName( FieldInfo.Values[Fields[i].FieldName] );