dbutilseh.pas

EhLib 4.2.16 中文汉化版 （Faceker.com 修改版） 1. DataServiceEhLibADO.pas 第40行

{*******************************************************}
{                                                       }
{                       EhLib v4.2                      }
{       Utilities to sort, filter data in DataSet       }
{                      Build 4.2.28                     }
{                                                       }
{      Copyright (c) 2002-2004 by Dmitry V. Bolshakov   }
{                                                       }
{*******************************************************}

{$I EhLib.Inc}

{$IFDEF EH_LIB_VCL}
unit DbUtilsEh {$IFDEF CIL} platform {$ENDIF};
{$ELSE}
unit QDbUtilsEh;
{$ENDIF}

interface

{$IFDEF EH_LIB_VCL}
uses
{$IFDEF EH_LIB_6} Variants, {$ENDIF}

{$IFDEF CIL}
  EhLibVCLNET,
  System.Runtime.InteropServices, System.Reflection,
{$ELSE}
  EhLibVCL,
{$ENDIF}

  DBGridEh, Db, SysUtils, Classes, TypInfo, Windows, Messages, ToolCtrlsEh;

{$ELSE}
uses
  Variants, QDBGridEh, Db, SysUtils, Classes, TypInfo;
{$ENDIF}

type

  TDateValueToSQLStringProcEh = function(DataSet: TDataSet; Value: Variant): String;

var

  STFilterOperatorsStrMapEh: array[TSTFilterOperatorEh] of String =
  ('', '=', '<>',
    '>', '<', '>=', '<=',
    '~', '!~',
    'In', '!In',
    {=}'Null', {<>}'Null',
    'AND', 'OR',
    '');

const

  STFldTypeMapEh: array[TFieldType] of TSTOperandTypeEh = (
    botNon, botString, botNumber, botNumber, botNumber,
    botBoolean, botNumber, botNumber, botNumber, botDateTime, botDateTime, botDateTime,
    botNon, botNon, botNumber, botNon, botString, botNon, botString,
    botNon, botNon, botNon, botNon, botString, botString,
    botNumber, botNon, botNon, botNon, botNon
{$IFDEF EH_LIB_5}
    ,botNon, botNon, botNon, botNon, botNon, botString
{$ENDIF}
{$IFDEF EH_LIB_6}, botDateTime, botNumber{$ENDIF}
{$IFDEF EH_LIB_10}
    ,botString, botString, botNon, botString
{$ENDIF}
    );

  STFilterOperatorsSQLStrMapEh: array[TSTFilterOperatorEh] of String =
  ('', '=', '<>',
    '>', '<', '>=', '<=',
    'LIKE', 'NOT LIKE',
    'IN', 'NOT IN',
    'IS NULL', 'IS NOT NULL',
    'AND', 'OR',
    '');

procedure InitSTFilterOperatorsStrMap;

{ FilterExpression }

function ParseSTFilterExpressionEh(Exp: String; var FExpression: TSTFilterExpressionEh): Boolean;
procedure ClearSTFilterExpression(var FExpression: TSTFilterExpressionEh);

type
  TOneExpressionFilterStringProcEh = function(O: TSTFilterOperatorEh; v: Variant;
    FieldName: String; DataSet: TDataSet;
    DateValueToSQLStringProc: TDateValueToSQLStringProcEh;
    SupportsLike: Boolean): String;

{ Useful routines to form filter string for dataset }

function GetExpressionAsFilterString(AGrid: TCustomDBGridEh;
  OneExpressionProc: TOneExpressionFilterStringProcEh;
  DateValueToSQLStringProc: TDateValueToSQLStringProcEh;
  UseFieldOrigin: Boolean = False;
  SupportsLocalLike: Boolean = False): String;

function GetOneExpressionAsLocalFilterString(O: TSTFilterOperatorEh;
  v: Variant; FieldName: String; DataSet: TDataSet;
  DateValueToSQLStringProc: TDateValueToSQLStringProcEh;
  SupportsLike: Boolean): String;

function GetOneExpressionAsSQLWhereString(O: TSTFilterOperatorEh; v: Variant;
  FieldName: String; DataSet: TDataSet;
  DateValueToSQLStringProc: TDateValueToSQLStringProcEh; SupportsLike: Boolean): String;

function DateValueToDataBaseSQLString(DataBaseName: String; v: Variant): String;

procedure ApplyFilterSQLBasedDataSet(Grid: TCustomDBGridEh;
  DateValueToSQLString: TDateValueToSQLStringProcEh; IsReopen: Boolean;
  SQLPropName: String);

{ DatasetFeatures }

type

  TDataSetClass = class of TDataSet;

  TDatasetFeaturesEh = class
  private
    FDataSetClass: TDataSetClass;
  public
    constructor Create; virtual;
    function LocateText(AGrid: TCustomDBGridEh; const FieldName: string;
      const Text: String; AOptions: TLocateTextOptionsEh; Direction: TLocateTextDirectionEh;
      Matching: TLocateTextMatchingEh; TreeFindRange: TLocateTextTreeFindRangeEh): Boolean; virtual;
    function MoveRecords(Sender: TObject; BookmarkList: TStrings; ToRecNo: Longint; CheckOnly: Boolean): Boolean; virtual;
    procedure ApplySorting(Sender: TObject; DataSet: TDataSet; IsReopen: Boolean); virtual;
    procedure ApplyFilter(Sender: TObject; DataSet: TDataSet; IsReopen: Boolean); virtual;
    procedure ExecuteFindDialog(Sender: TObject; Text, FieldName: String; Modal: Boolean); virtual;
  end;

  TSQLDatasetFeaturesEh = class(TDatasetFeaturesEh)
  private
    FSortUsingFieldName: Boolean;
    FSQLPropName: String;
    FDateValueToSQLString: TDateValueToSQLStringProcEh;
    FSupportsLocalLike: Boolean;
  public
    constructor Create; override;
    procedure ApplySorting(Sender: TObject; DataSet: TDataSet; IsReopen: Boolean); override;
    property SortUsingFieldName: Boolean read FSortUsingFieldName write FSortUsingFieldName;
    procedure ApplyFilter(Sender: TObject; DataSet: TDataSet; IsReopen: Boolean); override;
    property SQLPropName: String read FSQLPropName  write FSQLPropName;
    property DateValueToSQLString: TDateValueToSQLStringProcEh read
      FDateValueToSQLString write FDateValueToSQLString;
    property SupportsLocalLike: Boolean read FSupportsLocalLike write FSupportsLocalLike;
  end;

  TCommandTextDatasetFeaturesEh = class(TSQLDatasetFeaturesEh)
  public
    constructor Create; override;
  end;

  TDatasetFeaturesEhClass = class of TDatasetFeaturesEh;

{ Register/Unregister DatasetFeatures }

procedure RegisterDatasetFeaturesEh(DatasetFeaturesClass: TDatasetFeaturesEhClass;
  DataSetClass: TDataSetClass);
procedure UnregisterDatasetFeaturesEh(DataSetClass: TDataSetClass);
function GetDatasetFeaturesForDataSet(DataSet: TDataSet): TDatasetFeaturesEh;
function GetDatasetFeaturesForDataSetClass(DataSetClass: TClass): TDatasetFeaturesEh;


function IsSQLBasedDataSet(DataSet: TDataSet; var SQL: TStrings): Boolean;
function IsDataSetHaveSQLLikeProp(DataSet: TDataSet; SQLPropName: String; var SQLPropValue: WideString): Boolean;

procedure ApplySortingForSQLBasedDataSet(Grid: TCustomDBGridEh; DataSet: TDataSet;
  UseFieldName: Boolean; IsReopen: Boolean; SQLPropName: String);

function LocateDatasetTextEh(AGrid: TCustomDBGridEh;
  const FieldName, Text: String; AOptions: TLocateTextOptionsEh;
  Direction: TLocateTextDirectionEh; Matching: TLocateTextMatchingEh;
  TreeFindRange: TLocateTextTreeFindRangeEh): Boolean;

var
  SQLFilterMarker: String = '/*FILTER*/';

resourcestring

  // Filter expression operators
  SNotOperatorEh = 'Not';
  SAndOperatorEh = 'AND';
  SOrOperatorEh = 'OR';
  SLikePredicatEh = ''; // 'Like sign' //Use default sign '~'
  SInPredicatEh = 'In';
  SNullConstEh = 'Null';

  // Error message
  SQuoteIsAbsentEh = 'Quote is absent: ';
  SLeftBracketExpectedEh = '''('' expected: ';
  SRightBracketExpectedEh = ''')'' expected: ';
  SErrorInExpressionEh = 'Error in expression: ';
  SUnexpectedExpressionBeforeNullEh = 'Unexpected expression before Null: ';
  SUnexpectedExpressionAfterOperatorEh = 'Unexpected expression after operator: ';
  SIncorrectExpressionEh = 'Incorrect expression: ';
  SUnexpectedANDorOREh = 'Unexpected AND or OR: ';

implementation

uses
  DBConsts, DBGridEhFindDlgs, Contnrs;
  
procedure SetDataSetSQLLikeProp(DataSet: TDataSet; SQLPropName: String; SQLPropValue: WideString);
var
  FPropInfo: PPropInfo;
begin
  FPropInfo := GetPropInfo(DataSet.ClassInfo, SQLPropName);
  if FPropInfo = nil then Exit;
  if PropType_getKind(PropInfo_getPropType(FPropInfo)) = tkString then
    SetStrProp(DataSet, FPropInfo, SQLPropValue)
{$IFDEF EH_LIB_6}
  else if PropType_getKind(PropInfo_getPropType(FPropInfo)) = tkWString then
    SetWideStrProp(DataSet, FPropInfo, SQLPropValue)
{$ELSE}
  else if PropType_getKind(PropInfo_getPropType(FPropInfo)) = tkWString then
    SetStrProp(DataSet, FPropInfo, SQLPropValue)
{$ENDIF}
  else if PropType_getKind(PropInfo_getPropType(FPropInfo)) = tkClass then
    if (TObject(GetOrdProp(DataSet, FPropInfo)) as TStrings) <> nil then
      (TObject(GetOrdProp(DataSet, FPropInfo)) as TStrings).Text := SQLPropValue;
end;

procedure ClearSTFilterExpression(var FExpression: TSTFilterExpressionEh);
begin
  FExpression.Operator1 := foNon;
  FExpression.Operand1 := Null;
  FExpression.Relation := foNon;
  FExpression.Operator2 := foNon;
  FExpression.Operand2 := Null;
end;

procedure InitSTFilterOperatorsStrMap;
var
  NotOperator: String;
begin
  if SNotOperatorEh <> ''
    then NotOperator := SNotOperatorEh + ' '
    else NotOperator := 'Not ';
  if SLikePredicatEh <> '' then
  begin
    STFilterOperatorsStrMapEh[foLike] := SLikePredicatEh;
    STFilterOperatorsStrMapEh[foNotLike] := NotOperator + SLikePredicatEh;
  end;
  if SInPredicatEh <> '' then
  begin
    STFilterOperatorsStrMapEh[foIn] := SInPredicatEh;
    STFilterOperatorsStrMapEh[foNotIn] := NotOperator + SInPredicatEh;
  end;
  if SNullConstEh <> '' then
  begin
    STFilterOperatorsStrMapEh[foNull] := SNullConstEh;
    STFilterOperatorsStrMapEh[foNotNull] := SNullConstEh;
  end;
  if SAndOperatorEh <> '' then
    STFilterOperatorsStrMapEh[foAND] := SAndOperatorEh;
  if SOrOperatorEh <> '' then
    STFilterOperatorsStrMapEh[foOR] := SOrOperatorEh;
end;

{$IFNDEF EH_LIB_6}
function StrCharLength(const Str: PChar): Integer;
begin
  if SysLocale.FarEast then
    Result := Integer(CharNext(Str)) - Integer(Str)
  else
    Result := 1;
end;

function NextCharIndex(const S: string; Index: Integer): Integer;
begin
  Result := Index + 1;
  assert((Index > 0) and (Index <= Length(S)));
  if SysLocale.FarEast and (S[Index] in LeadBytes) then
    Result := Index + StrCharLength(PChar(S) + Index - 1);
end;
{$ENDIF}

{ ParseSTFilterExpression }

type
  TOperator = (
    opNon, opEqual, opNotEqual,
    opGreaterThan, opLessThan, opGreaterOrEqual, opLessOrEqual,
    opLike,
    opIn,
    opAND, opOR,
    opValue,
    opNot, opComma, opOpenBracket, opCloseBracket, opQuote, opNullConst);

const
  OperatorAdvFilterOperatorMap: array[TOperator] of TSTFilterOperatorEh = (
    foNon, foEqual, foNotEqual,
    foGreaterThan, foLessThan, foGreaterOrEqual, foLessOrEqual,
    foLike,
    foIn,
    foAND, foOR,
    foValue,
    foNon, foNon, foNon, foNon, foNon, foNull);


function GetLexeme(S: String; var Pos: Integer; var Operator: TSTFilterOperatorEh;
  PreferCommaForList: Boolean): Variant; forward;

function GetOperatorByWord(TheWord: String): TOperator;
begin
  Result := opNon;
  TheWord := AnsiUpperCase(TheWord);
  if (TheWord = 'NOT') or
     ((SNotOperatorEh <> '') and (TheWord = AnsiUpperCase(SNotOperatorEh))) then
    Result := opNot
  else if (TheWord = 'AND') or
          ((SAndOperatorEh <> '') and (TheWord = AnsiUpperCase(SAndOperatorEh))) then
    Result := opAND
  else if (TheWord = 'OR') or
          ((SOrOperatorEh <> '') and (TheWord = AnsiUpperCase(SOrOperatorEh))) then
    Result := opOR
  else if (TheWord = 'LIKE') or
          ((SLikePredicatEh <> '') and (TheWord = AnsiUpperCase(SLikePredicatEh))) then
    Result := opLIKE
  else if (TheWord = 'IN') or
          ((SInPredicatEh <> '') and (TheWord = AnsiUpperCase(SInPredicatEh))) then
    Result := opIN
  else if (TheWord = 'NULL') or
          ((SNullConstEh <> '') and (TheWord = AnsiUpperCase(SNullConstEh))) then
    Result := opNullConst;
end;

procedure ConvertVarStrValues(var v: Variant; ot: TSTOperandTypeEh);
var
  i: Integer;
begin
  if ot = botNumber then
  begin
    if not VarIsNull(v) then
      if VarIsArray(v) then
        for i := VarArrayLowBound(v, 1) to VarArrayHighBound(v, 1) do
          v[i] := StrToFloat(v[i])
      else
        v := StrToFloat(v);
  end
  else if ot = botDateTime then
  begin
    if not VarIsNull(v) then
      if VarIsArray(v) then
        for i := VarArrayLowBound(v, 1) to VarArrayHighBound(v, 1) do
          v[i] := StrToDateTime(v[i])
      else
        v := StrToDateTime(v);
  end;
end;

function SkipBlanks(s: String; Pos: Integer): Integer;
var
  i: Integer;
begin
  Result := Pos;
  for i := Pos to Length(s) do
    if s[i] <> ' ' then
    begin
      Result := i;
      Break;
    end
end;

procedure SetOperatorPos(var Pos: Integer; Increment: Integer; var Op: TOperator; NewOp: TOperator);
begin
  Inc(Pos, Increment);
  Op := NewOp;
end;

function CharAtPos(S: String; Pos: Integer): Char;
begin
  if Length(S) < Pos then
    Result := #0
  else
    Result := S[Pos];
end;

function ReadValue(S: String; var Pos: Integer; PreferCommaForList: Boolean): Variant;

  function CheckForOperand(S: String; Pos: Integer): Boolean;
  var
    Operator: TSTFilterOperatorEh;
  begin
    GetLexeme(S, Pos, Operator, PreferCommaForList);
    if Operator in [foEqual..foOR] then
      Result := True
    else
      Result := False;
  end;

var
  i: Integer;
begin
  Result := Null;
  if Pos > Length(S) then
    Exit;
  if S[Pos] = '''' then