home *** CD-ROM | disk | FTP | other *** search
/ PC Plus SuperCD (UK) 2000 March / pcp161b.iso / full / delphi / RUNIMAGE / DELPHI30 / SOURCE / VCL / DBCOMMON.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-08-03  |  26.5 KB  |  974 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Delphi Visual Component Library                 }
  5. {       Additional BDE dependent Classes                }
  6. {                                                       }
  7. {       Copyright (c) 1995,96 Borland International     }
  8. {                                                       }
  9. {*******************************************************}
  10.  
  11. unit DBCommon;
  12.  
  13. interface
  14.  
  15. uses Windows, Classes, DB, BDE;
  16.  
  17. { FieldType Mappings }
  18.  
  19. const
  20.   FldTypeMap: array[TFieldType] of Byte = (
  21.     fldUNKNOWN, fldZSTRING, fldINT16, fldINT32, fldUINT16, fldBOOL,
  22.     fldFLOAT, fldFLOAT, fldBCD, fldDATE, fldTIME, fldTIMESTAMP, fldBYTES,
  23.     fldVARBYTES, fldINT32, fldBLOB, fldBLOB, fldBLOB, fldBLOB, fldBLOB,
  24.     fldBLOB, fldBLOB, fldCURSOR);
  25.  
  26.   FldSubTypeMap: array[TFieldType] of Word = (
  27.     0, 0, 0, 0, 0, 0, 0, fldstMONEY, 0, 0, 0, 0, 0, 0, fldstAUTOINC,
  28.     fldstBINARY, fldstMEMO, fldstGRAPHIC, fldstFMTMEMO, fldstOLEOBJ,
  29.     fldstDBSOLEOBJ, fldstTYPEDBINARY, 0);
  30.  
  31.   DataTypeMap: array[0..MAXLOGFLDTYPES - 1] of TFieldType = (
  32.     ftUnknown, ftString, ftDate, ftBlob, ftBoolean, ftSmallint,
  33.     ftInteger, ftFloat, ftBCD, ftBytes, ftTime, ftDateTime,
  34.     ftWord, ftInteger, ftUnknown, ftVarBytes, ftUnknown, ftUnknown);
  35.  
  36.   BlobTypeMap: array[fldstMEMO..fldstTYPEDBINARY] of TFieldType = (
  37.     ftMemo, ftBlob, ftFmtMemo, ftParadoxOle, ftGraphic,
  38.     ftDBaseOle, ftTypedBinary);
  39.  
  40. { TFilterExpr }
  41.  
  42. type
  43.  
  44.   TExprNodeKind = (enField, enConst, enOperator);
  45.  
  46.   PExprNode = ^TExprNode;
  47.   TExprNode = record
  48.     FNext: PExprNode;
  49.     FKind: TExprNodeKind;
  50.     FPartial: Boolean;
  51.     FOperator: CanOp;
  52.     FData: Variant;
  53.     FLeft: PExprNode;
  54.     FRight: PExprNode;
  55.   end;
  56.  
  57.   TFilterExpr = class
  58.   private
  59.     FDataSet: TDataSet;
  60.     FOptions: TFilterOptions;
  61.     FNodes: PExprNode;
  62.     FExprBuffer: PCANExpr;
  63.     FExprBufSize: Integer;
  64.     FExprNodeSize: Integer;
  65.     FExprDataSize: Integer;
  66.     function FieldFromNode(Node: PExprNode): TField;
  67.     function GetExprData(Pos, Size: Integer): PChar;
  68.     function PutCompareNode(Node: PExprNode): Integer;
  69.     function PutConstBCD(const Value: Variant; Decimals: Integer): Integer;
  70.     function PutConstBool(const Value: Variant): Integer;
  71.     function PutConstDate(const Value: Variant): Integer;
  72.     function PutConstDateTime(const Value: Variant): Integer;
  73.     function PutConstFloat(const Value: Variant): Integer;
  74.     function PutConstInt(DataType: Integer; const Value: Variant): Integer;
  75.     function PutConstNode(DataType: Integer; Data: PChar;
  76.       Size: Integer): Integer;
  77.     function PutConstStr(const Value: string): Integer;
  78.     function PutConstTime(const Value: Variant): Integer;
  79.     function PutData(Data: PChar; Size: Integer): Integer;
  80.     function PutExprNode(Node: PExprNode): Integer;
  81.     function PutFieldNode(Field: TField): Integer;
  82.     function PutNode(NodeType: NodeClass; OpType: CanOp;
  83.       OpCount: Integer): Integer;
  84.     procedure SetNodeOp(Node, Index, Data: Integer);
  85.   public
  86.     constructor Create(DataSet: TDataSet; Options: TFilterOptions);
  87.     destructor Destroy; override;
  88.     function NewCompareNode(Field: TField; Operator: CanOp;
  89.       const Value: Variant): PExprNode;
  90.     function NewNode(Kind: TExprNodeKind; Operator: CanOp;
  91.       const Data: Variant; Left, Right: PExprNode): PExprNode;
  92.     function GetFilterData(Root: PExprNode): PCANExpr;
  93.   end;
  94.  
  95. { TExprParser }
  96.  
  97.   TExprToken = (etEnd, etSymbol, etName, etLiteral, etLParen, etRParen,
  98.     etEQ, etNE, etGE, etLE, etGT, etLT);
  99.  
  100.   TExprParser = class
  101.   private
  102.     FFilter: TFilterExpr;
  103.     FText: string;
  104.     FSourcePtr: PChar;
  105.     FTokenPtr: PChar;
  106.     FTokenString: string;
  107.     FStrTrue: string;
  108.     FStrFalse: string;
  109.     FToken: TExprToken;
  110.     FFilterData: PCANExpr;
  111.     FDataSize: Integer;
  112.     procedure NextToken;
  113.     function ParseExpr: PExprNode;
  114.     function ParseExpr2: PExprNode;
  115.     function ParseExpr3: PExprNode;
  116.     function ParseExpr4: PExprNode;
  117.     function ParseExpr5: PExprNode;
  118.     function TokenName: string;
  119.     function TokenSymbolIs(const S: string): Boolean;
  120.   public
  121.     constructor Create(DataSet: TDataSet; const Text: string;
  122.       Options: TFilterOptions);
  123.     destructor Destroy; override;
  124.     property FilterData: PCANExpr read FFilterData;
  125.     property DataSize: Integer read FDataSize;
  126.   end;
  127.  
  128. { TMasterDataLink }
  129.  
  130.   TMasterDataLink = class(TDataLink)
  131.   private
  132.     FDataSet: TDataSet;
  133.     FFieldNames: string;
  134.     FFields: TList;
  135.     FOnMasterChange: TNotifyEvent;
  136.     FOnMasterDisable: TNotifyEvent;
  137.     procedure SetFieldNames(const Value: string);
  138.   protected
  139.     procedure ActiveChanged; override;
  140.     procedure CheckBrowseMode; override;
  141.     procedure LayoutChanged; override;
  142.     procedure RecordChanged(Field: TField); override;
  143.   public
  144.     constructor Create(DataSet: TDataSet);
  145.     destructor Destroy; override;
  146.     property FieldNames: string read FFieldNames write SetFieldNames;
  147.     property Fields: TList read FFields;
  148.     property OnMasterChange: TNotifyEvent read FOnMasterChange write FOnMasterChange;
  149.     property OnMasterDisable: TNotifyEvent read FOnMasterDisable write FOnMasterDisable;
  150.   end;
  151.  
  152. function FMTBCDToCurr(const BCD: FMTBcd; var Curr: Currency): Boolean;
  153. function CurrToFMTBCD(Curr: Currency; var BCD: FMTBcd; Precision,
  154.   Decimals: Integer): Boolean;
  155. function SafeArrayToVariant(SafeArray: PVarArray): Variant;
  156.  
  157. implementation
  158.  
  159. uses SysUtils, DBConsts;
  160.  
  161. function SafeArrayToVariant(SafeArray: PVarArray): Variant;
  162. begin
  163.   if Assigned(SafeArray) then
  164.   begin
  165.     VarClear(Result);
  166.     TVarData(Result).VType := varByte or varArray;
  167.     TVarData(Result).VArray := SafeArray;
  168.   end else
  169.     Result := NULL;
  170. end;
  171.  
  172. function FMTBCDToCurr(const BCD: FMTBcd; var Curr: Currency): Boolean;
  173. const
  174.   FConst10: Single = 10;
  175.   CWNear: Word = $133F;
  176. var
  177.   CtrlWord: Word;
  178.   Temp: Integer;
  179.   Digits: array[0..63] of Byte;
  180. asm
  181.         PUSH    EBX
  182.         PUSH    ESI
  183.         MOV     EBX,EAX
  184.         MOV     ESI,EDX
  185.         MOV     AL,0
  186.         MOVZX   EDX,[EBX].FMTBcd.iPrecision
  187.         OR      EDX,EDX
  188.         JE      @@8
  189.         LEA     ECX,[EDX+1]
  190.         SHR     ECX,1
  191. @@1:    MOV     AL,[EBX].FMTBcd.iFraction.Byte[ECX-1]
  192.         MOV     AH,AL
  193.         SHR     AL,4
  194.         AND     AH,0FH
  195.         MOV     Digits.Word[ECX*2-2],AX
  196.         DEC     ECX
  197.         JNE     @@1
  198.         XOR     EAX,EAX
  199. @@2:    MOV     AL,Digits.Byte[ECX]
  200.         OR      AL,AL
  201.         JNE     @@3
  202.         INC     ECX
  203.         CMP     ECX,EDX
  204.         JNE     @@2
  205.         FLDZ
  206.         JMP     @@7
  207. @@3:    MOV     Temp,EAX
  208.         FILD    Temp
  209. @@4:    INC     ECX
  210.         CMP     ECX,EDX
  211.         JE      @@5
  212.         FMUL    FConst10
  213.         MOV     AL,Digits.Byte[ECX]
  214.         MOV     Temp,EAX
  215.         FIADD   Temp
  216.         JMP     @@4
  217. @@5:    MOV     AL,[EBX].FMTBcd.iSignSpecialPlaces
  218.         OR      AL,AL
  219.         JNS     @@6
  220.         FCHS
  221. @@6:    AND     EAX,3FH
  222.         SUB     EAX,4
  223.         NEG     EAX
  224.         CALL    FPower10
  225. @@7:    FSTCW   CtrlWord
  226.         FLDCW   CWNear
  227.         FISTP   [ESI].Currency
  228.         FSTSW   AX
  229.         NOT     AL
  230.         AND     AL,1
  231.         FCLEX
  232.         FLDCW   CtrlWord
  233.         FWAIT
  234. @@8:    POP     ESI
  235.         POP     EBX
  236. end;
  237.  
  238. function CurrToFMTBCD(Curr: Currency; var BCD: FMTBcd; Precision,
  239.   Decimals: Integer): Boolean;
  240. const
  241.   Power10: array[0..3] of Single = (10000, 1000, 100, 10);
  242. var
  243.   Digits: array[0..63] of Byte;
  244. asm
  245.         PUSH    EBX
  246.         PUSH    ESI
  247.         PUSH    EDI
  248.         MOV     ESI,EAX
  249.         XCHG    ECX,EDX
  250.         MOV     [ESI].FMTBcd.iPrecision,CL
  251.         MOV     [ESI].FMTBcd.iSignSpecialPlaces,DL
  252. @@1:    SUB     EDX,4
  253.         JE      @@3
  254.         JA      @@2
  255.         FILD    Curr
  256.         FDIV    Power10.Single[EDX*4+16]
  257.         FISTP   Curr
  258.         JMP     @@3
  259. @@2:    DEC     ECX
  260.         MOV     Digits.Byte[ECX],0
  261.         DEC     EDX
  262.         JNE     @@2
  263. @@3:    MOV     EAX,Curr.Integer[0]
  264.         MOV     EBX,Curr.Integer[4]
  265.         OR      EBX,EBX
  266.         JNS     @@4
  267.         NEG     EBX
  268.         NEG     EAX
  269.         SBB     EBX,0
  270.         OR      [ESI].FMTBcd.iSignSpecialPlaces,80H
  271. @@4:    MOV     EDI,10
  272. @@5:    MOV     EDX,EAX
  273.         OR      EDX,EBX
  274.         JE      @@7
  275.         XOR     EDX,EDX
  276.         OR      EBX,EBX
  277.         JE      @@6
  278.         XCHG    EAX,EBX
  279.         DIV     EDI
  280.         XCHG    EAX,EBX
  281. @@6:    DIV     EDI
  282. @@7:    MOV     Digits.Byte[ECX-1],DL
  283.         DEC     ECX
  284.         JNE     @@5
  285.         OR      EAX,EBX
  286.         MOV     AL,0
  287.         JNE     @@9
  288.         MOV     CL,[ESI].FMTBcd.iPrecision
  289.         INC     ECX
  290.         SHR     ECX,1
  291. @@8:    MOV     AX,Digits.Word[ECX*2-2]
  292.         SHL     AL,4
  293.         OR      AL,AH
  294.         MOV     [ESI].FMTBcd.iFraction.Byte[ECX-1],AL
  295.         DEC     ECX
  296.         JNE     @@8
  297.         MOV     AL,1
  298. @@9:    POP     EDI
  299.         POP     ESI
  300.         POP     EBX
  301. end;
  302.  
  303. { TFilterExpr }
  304.  
  305. constructor TFilterExpr.Create(DataSet: TDataSet; Options: TFilterOptions);
  306. begin
  307.   FDataSet := DataSet;
  308.   FOptions := Options;
  309. end;
  310.  
  311. destructor TFilterExpr.Destroy;
  312. var
  313.   Node: PExprNode;
  314. begin
  315.   FreeMem(FExprBuffer, FExprBufSize);
  316.   while FNodes <> nil do
  317.   begin
  318.     Node := FNodes;
  319.     FNodes := Node^.FNext;
  320.     Dispose(Node);
  321.   end;
  322. end;
  323.  
  324. function TFilterExpr.FieldFromNode(Node: PExprNode): TField;
  325. begin
  326.   Result := FDataSet.FieldByName(Node^.FData);
  327.   if not (Result.FieldKind in [fkData, fkInternalCalc]) then
  328.     DatabaseErrorFmt(SExprBadField, [Result.FieldName]);
  329. end;
  330.  
  331. function TFilterExpr.GetExprData(Pos, Size: Integer): PChar;
  332. begin
  333.   ReallocMem(FExprBuffer, FExprBufSize + Size);
  334.   Move(PChar(FExprBuffer)[Pos], PChar(FExprBuffer)[Pos + Size],
  335.     FExprBufSize - Pos);
  336.   Inc(FExprBufSize, Size);
  337.   Result := PChar(FExprBuffer) + Pos;
  338. end;
  339.  
  340. function TFilterExpr.GetFilterData(Root: PExprNode): PCANExpr;
  341. begin
  342.   FExprBufSize := SizeOf(CANExpr);
  343.   GetMem(FExprBuffer, FExprBufSize);
  344.   PutExprNode(Root);
  345.   with FExprBuffer^ do
  346.   begin
  347.     iVer := CANEXPRVERSION;
  348.     iTotalSize := FExprBufSize;
  349.     iNodes := $FFFF;
  350.     iNodeStart := SizeOf(CANExpr);
  351.     iLiteralStart := FExprNodeSize + SizeOf(CANExpr);
  352.   end;
  353.   Result := FExprBuffer;
  354. end;
  355.  
  356. function TFilterExpr.NewCompareNode(Field: TField; Operator: CanOp;
  357.   const Value: Variant): PExprNode;
  358. begin
  359.   Result := NewNode(enOperator, Operator, Unassigned,
  360.     NewNode(enField, canNOTDEFINED, Field.FieldName, nil, nil),
  361.     NewNode(enConst, canNOTDEFINED, Value, nil, nil));
  362. end;
  363.  
  364. function TFilterExpr.NewNode(Kind: TExprNodeKind; Operator: CanOp;
  365.   const Data: Variant; Left, Right: PExprNode): PExprNode;
  366. begin
  367.   New(Result);
  368.   with Result^ do
  369.   begin
  370.     FNext := FNodes;
  371.     FKind := Kind;
  372.     FPartial := False;
  373.     FOperator := Operator;
  374.     FData := Data;
  375.     FLeft := Left;
  376.     FRight := Right;
  377.   end;
  378.   FNodes := Result;
  379. end;
  380.  
  381. function TFilterExpr.PutCompareNode(Node: PExprNode): Integer;
  382. const
  383.   ReverseOperator: array[canEQ..canLE] of CanOp = (
  384.     canEQ, canNE, canLT, canGT, canLE, canGE);
  385. var
  386.   Operator: CanOp;
  387.   Left, Right, Temp: PExprNode;
  388.   Field: TField;
  389.   FieldPos, ConstPos, CaseInsensitive, PartialLength, L: Integer;
  390.   S: string;
  391. begin
  392.   Operator := Node^.FOperator;
  393.   Left := Node^.FLeft;
  394.   Right := Node^.FRight;
  395.   if (Right^.FKind = enField) and (Left^.FKind <> enField) then
  396.   begin
  397.     Temp := Left;
  398.     Left := Right;
  399.     Right := Temp;
  400.     Operator := ReverseOperator[Operator];
  401.   end;
  402.   Field := FieldFromNode(Left);
  403.   if (Right^.FKind = enField) then
  404.   begin
  405.     Result := PutNode(nodeBINARY, Operator, 2);
  406.     SetNodeOp(Result, 0, PutFieldNode(Field));
  407.     SetNodeOp(Result, 1, PutFieldNode(FieldFromNode(Right)));
  408.   end
  409.   else if VarIsNull(Right^.FData) then
  410.   begin
  411.     case Operator of
  412.       canEQ: Operator := canISBLANK;
  413.       canNE: Operator := canNOTBLANK;
  414.     else
  415.       DatabaseError(SExprBadNullTest);
  416.     end;
  417.     Result := PutNode(nodeUNARY, Operator, 1);
  418.     SetNodeOp(Result, 0, PutFieldNode(Field));
  419.   end else
  420.   begin
  421.     if ((Operator = canEQ) or (Operator = canNE)) and
  422.       (Field.DataType = ftString) then
  423.     begin
  424.       S := Right^.FData;
  425.       L := Length(S);
  426.       if L <> 0 then
  427.       begin
  428.         CaseInsensitive := 0;
  429.         PartialLength := 0;
  430.         if foCaseInsensitive in FOptions then CaseInsensitive := 1;
  431.         if Node^.FPartial then PartialLength := L else
  432.           if not (foNoPartialCompare in FOptions) and (L > 1) and
  433.             (S[L] = '*') then
  434.           begin
  435.             Delete(S, L, 1);
  436.             PartialLength := L - 1;
  437.           end;
  438.         if (CaseInsensitive <> 0) or (PartialLength <> 0) then
  439.         begin
  440.           Result := PutNode(nodeCOMPARE, Operator, 4);
  441.           SetNodeOp(Result, 0, CaseInsensitive);
  442.           SetNodeOp(Result, 1, PartialLength);
  443.           SetNodeOp(Result, 2, PutFieldNode(Field));
  444.           SetNodeOp(Result, 3, PutConstStr(S));
  445.           Exit;
  446.         end;
  447.       end;
  448.     end;
  449.     Result := PutNode(nodeBINARY, Operator, 2);
  450.     FieldPos := PutFieldNode(Field);
  451.     case Field.DataType of
  452.       ftString:
  453.         ConstPos := PutConstStr(Right^.FData);
  454.       ftSmallint:
  455.         ConstPos := PutConstInt(fldINT16, Right^.FData);
  456.       ftInteger, ftAutoInc:
  457.         ConstPos := PutConstInt(fldINT32, Right^.FData);
  458.       ftWord:
  459.         ConstPos := PutConstInt(fldUINT16, Right^.FData);
  460.       ftFloat, ftCurrency:
  461.         ConstPos := PutConstFloat(Right^.FData);
  462.       ftBCD:
  463.         ConstPos := PutConstBCD(Right^.FData, Field.Size);
  464.       ftDate:
  465.         ConstPos := PutConstDate(Right^.FData);
  466.       ftTime:
  467.         ConstPos := PutConstTime(Right^.FData);
  468.       ftDateTime:
  469.         ConstPos := PutConstDateTime(Right^.FData);
  470.       ftBoolean:
  471.         ConstPos := PutConstBool(Right^.FData);
  472.     else
  473.       DatabaseErrorFmt(SExprBadField, [Field.FieldName]);
  474.       ConstPos := 0;
  475.     end;
  476.     SetNodeOp(Result, 0, FieldPos);
  477.     SetNodeOp(Result, 1, ConstPos);
  478.   end;
  479. end;
  480.  
  481. function TFilterExpr.PutConstBCD(const Value: Variant;
  482.   Decimals: Integer): Integer;
  483. var
  484.   C: Currency;
  485.   BCD: FMTBcd;
  486. begin
  487.   if VarType(Value) = varString then
  488.     C := StrToCurr(string(TVarData(Value).VString)) else
  489.     C := Value;
  490.   CurrToFMTBCD(C, BCD, 32, Decimals);
  491.   Result := PutConstNode(fldBCD, @BCD, 18);
  492. end;
  493.  
  494. function TFilterExpr.PutConstBool(const Value: Variant): Integer;
  495. var
  496.   B: WordBool;
  497. begin
  498.   B := Value;
  499.   Result := PutConstNode(fldBOOL, @B, SizeOf(WordBool));
  500. end;
  501.  
  502. function TFilterExpr.PutConstDate(const Value: Variant): Integer;
  503. var
  504.   DateTime: TDateTime;
  505.   TimeStamp: TTimeStamp;
  506. begin
  507.   if VarType(Value) = varString then
  508.     DateTime := StrToDate(string(TVarData(Value).VString)) else
  509.     DateTime := VarToDateTime(Value);
  510.   TimeStamp := DateTimeToTimeStamp(DateTime);
  511.   Result := PutConstNode(fldDATE, @TimeStamp.Date, 4);
  512. end;
  513.  
  514. function TFilterExpr.PutConstDateTime(const Value: Variant): Integer;
  515. var
  516.   DateTime: TDateTime;
  517.   DateData: Double;
  518. begin
  519.   if VarType(Value) = varString then
  520.     DateTime := StrToDateTime(string(TVarData(Value).VString)) else
  521.     DateTime := VarToDateTime(Value);
  522.   DateData := TimeStampToMSecs(DateTimeToTimeStamp(DateTime));
  523.   Result := PutConstNode(fldTIMESTAMP, @DateData, 8);
  524. end;
  525.  
  526. function TFilterExpr.PutConstFloat(const Value: Variant): Integer;
  527. var
  528.   F: Double;
  529. begin
  530.   if VarType(Value) = varString then
  531.     F := StrToFloat(string(TVarData(Value).VString)) else
  532.     F := Value;
  533.   Result := PutConstNode(fldFLOAT, @F, SizeOf(Double));
  534. end;
  535.  
  536. function TFilterExpr.PutConstInt(DataType: Integer;
  537.   const Value: Variant): Integer;
  538. var
  539.   I, Size: Integer;
  540. begin
  541.   if VarType(Value) = varString then
  542.     I := StrToInt(string(TVarData(Value).VString)) else
  543.     I := Value;
  544.   Size := 2;
  545.   case DataType of
  546.     fldINT16:
  547.       if (I < -32768) or (I > 32767) then DatabaseError(SExprRangeError);
  548.     fldUINT16:
  549.       if (I < 0) or (I > 65535) then DatabaseError(SExprRangeError);
  550.   else
  551.     Size := 4;
  552.   end;
  553.   Result := PutConstNode(DataType, @I, Size);
  554. end;
  555.  
  556. function TFilterExpr.PutConstNode(DataType: Integer; Data: PChar;
  557.   Size: Integer): Integer;
  558. begin
  559.   Result := PutNode(nodeCONST, canCONST2, 3);
  560.   SetNodeOp(Result, 0, DataType);
  561.   SetNodeOp(Result, 1, Size);
  562.   SetNodeOp(Result, 2, PutData(Data, Size));
  563. end;
  564.  
  565. function TFilterExpr.PutConstStr(const Value: string): Integer;
  566. var
  567.   Str: string;
  568.   Buffer: array[0..255] of Char;
  569. begin
  570.   if Length(Value) >= SizeOf(Buffer) then
  571.     Str := Copy(Value, 1, SizeOf(Buffer) - 1) else
  572.     Str := Value;
  573.   FDataSet.Translate(PChar(Str), Buffer, True);
  574.   Result := PutConstNode(fldZSTRING, Buffer, Length(Str) + 1);
  575. end;
  576.  
  577. function TFilterExpr.PutConstTime(const Value: Variant): Integer;
  578. var
  579.   DateTime: TDateTime;
  580.   TimeStamp: TTimeStamp;
  581. begin
  582.   if VarType(Value) = varString then
  583.     DateTime := StrToTime(string(TVarData(Value).VString)) else
  584.     DateTime := VarToDateTime(Value);
  585.   TimeStamp := DateTimeToTimeStamp(DateTime);
  586.   Result := PutConstNode(fldTIME, @TimeStamp.Time, 4);
  587. end;
  588.  
  589. function TFilterExpr.PutData(Data: PChar; Size: Integer): Integer;
  590. begin
  591.   Move(Data^, GetExprData(FExprBufSize, Size)^, Size);
  592.   Result := FExprDataSize;
  593.   Inc(FExprDataSize, Size);
  594. end;
  595.  
  596. function TFilterExpr.PutExprNode(Node: PExprNode): Integer;
  597. const
  598.   BoolFalse: WordBool = False;
  599. var
  600.   Field: TField;
  601. begin
  602.   case Node^.FKind of
  603.     enField:
  604.       begin
  605.         Field := FieldFromNode(Node);
  606.         if Field.DataType <> ftBoolean then
  607.           DatabaseErrorFmt(SExprNotBoolean, [Field.FieldName]);
  608.         Result := PutNode(nodeBINARY, canNE, 2);
  609.         SetNodeOp(Result, 0, PutFieldNode(Field));
  610.         SetNodeOp(Result, 1, PutConstNode(fldBOOL, @BoolFalse,
  611.           SizeOf(WordBool)));
  612.       end;
  613.     enOperator:
  614.       case Node^.FOperator of
  615.         canEQ..canLE:
  616.           Result := PutCompareNode(Node);
  617.         canAND, canOR:
  618.           begin
  619.             Result := PutNode(nodeBINARY, Node^.FOperator, 2);
  620.             SetNodeOp(Result, 0, PutExprNode(Node^.FLeft));
  621.             SetNodeOp(Result, 1, PutExprNode(Node^.FRight));
  622.           end;
  623.       else
  624.         Result := PutNode(nodeUNARY, canNOT, 1);
  625.         SetNodeOp(Result, 0, PutExprNode(Node^.FLeft));
  626.       end;
  627.   else
  628.     DatabaseError(SExprIncorrect);
  629.     Result := 0;
  630.   end;
  631. end;
  632.  
  633. function TFilterExpr.PutFieldNode(Field: TField): Integer;
  634. var
  635.   Buffer: array[0..255] of Char;
  636. begin
  637.   FDataSet.Translate(PChar(Field.FieldName), Buffer, True);
  638.   Result := PutNode(nodeFIELD, canFIELD2, 2);
  639.   SetNodeOp(Result, 0, Field.FieldNo);
  640.   SetNodeOp(Result, 1, PutData(Buffer, StrLen(Buffer) + 1));
  641. end;
  642.  
  643. function TFilterExpr.PutNode(NodeType: NodeClass; OpType: CanOp;
  644.   OpCount: Integer): Integer;
  645. var
  646.   Size: Integer;
  647. begin
  648.   Size := SizeOf(CANHdr) + OpCount * SizeOf(Word);
  649.   with PCANHdr(GetExprData(SizeOf(CANExpr) + FExprNodeSize, Size))^ do
  650.   begin
  651.     nodeClass := NodeType;
  652.     canOp := OpType;
  653.   end;
  654.   Result := FExprNodeSize;
  655.   Inc(FExprNodeSize, Size);
  656. end;
  657.  
  658. procedure TFilterExpr.SetNodeOp(Node, Index, Data: Integer);
  659. begin
  660.   PWordArray(PChar(FExprBuffer) + (SizeOf(CANExpr) + Node +
  661.     SizeOf(CANHdr)))^[Index] := Data;
  662. end;
  663.  
  664. constructor TExprParser.Create(DataSet: TDataSet; const Text: string;
  665.   Options: TFilterOptions);
  666. var
  667.   Root: PExprNode;
  668. begin
  669.   FFilter := TFilterExpr.Create(DataSet, Options);
  670.   FStrTrue := STextTrue;
  671.   FStrFalse := STextFalse;
  672.   FText := Text;
  673.   FSourcePtr := PChar(Text);
  674.   NextToken;
  675.   Root := ParseExpr;
  676.   if FToken <> etEnd then DatabaseError(SExprTermination);
  677.   FFilterData := FFilter.GetFilterData(Root);
  678.   FDataSize := FFilter.FExprBufSize;
  679. end;
  680.  
  681. destructor TExprParser.Destroy;
  682. begin
  683.   FFilter.Free;
  684. end;
  685.  
  686. procedure TExprParser.NextToken;
  687. var
  688.   P, TokenStart: PChar;
  689.   L: Integer;
  690.   StrBuf: array[0..255] of Char;
  691.  
  692.   function IsKatakana(const Chr: Byte): Boolean;
  693.   begin
  694.     Result := (SysLocale.PriLangID = LANG_JAPANESE) and (Chr in [$A1..$DF]);
  695.   end;
  696.  
  697. begin
  698.   FTokenString := '';
  699.   P := FSourcePtr;
  700.   while (P^ <> #0) and (P^ <= ' ') do Inc(P);
  701.   FTokenPtr := P;
  702.   case P^ of
  703.     'A'..'Z', 'a'..'z', '_', #$81..#$fe:
  704.       begin
  705.         TokenStart := P;
  706.         if not SysLocale.FarEast then
  707.         begin
  708.           Inc(P);
  709.           while P^ in ['A'..'Z', 'a'..'z', '0'..'9', '_'] do Inc(P);
  710.         end
  711.         else
  712.           begin
  713.             while TRUE do
  714.             begin
  715.               if (P^ in ['A'..'Z', 'a'..'z', '0'..'9', '_']) or 
  716.                  IsKatakana(Byte(P^)) then
  717.                 Inc(P)
  718.               else
  719.                 if P^ in LeadBytes then
  720.                   Inc(P, 2)
  721.                 else
  722.                   Break;
  723.             end;
  724.           end;
  725.         SetString(FTokenString, TokenStart, P - TokenStart);
  726.         FToken := etSymbol;
  727.       end;
  728.     '[':
  729.       begin
  730.         Inc(P);
  731.         TokenStart := P;
  732.         P := AnsiStrScan(P, ']');
  733.         if P = nil then DatabaseError(SExprNameError);
  734.         SetString(FTokenString, TokenStart, P - TokenStart);
  735.         FToken := etName;
  736.         Inc(P);
  737.       end;
  738.     '''':
  739.       begin
  740.         Inc(P);
  741.         L := 0;
  742.         while True do
  743.         begin
  744.           if P^ = #0 then DatabaseError(SExprStringError);
  745.           if P^ = '''' then
  746.           begin
  747.             Inc(P);
  748.             if P^ <> '''' then Break;
  749.           end;
  750.           if L < SizeOf(StrBuf) then
  751.           begin
  752.             StrBuf[L] := P^;
  753.             Inc(L);
  754.           end;
  755.           Inc(P);
  756.         end;
  757.         SetString(FTokenString, StrBuf, L);
  758.         FToken := etLiteral;
  759.       end;
  760.     '-', '0'..'9':
  761.       begin
  762.         TokenStart := P;
  763.         Inc(P);
  764.         while P^ in ['0'..'9', '.', 'e', 'E', '+', '-'] do Inc(P);
  765.         SetString(FTokenString, TokenStart, P - TokenStart);
  766.         FToken := etLiteral;
  767.       end;
  768.     '(':
  769.       begin
  770.         Inc(P);
  771.         FToken := etLParen;
  772.       end;
  773.     ')':
  774.       begin
  775.         Inc(P);
  776.         FToken := etRParen;
  777.       end;
  778.     '<':
  779.       begin
  780.         Inc(P);
  781.         case P^ of
  782.           '=':
  783.             begin
  784.               Inc(P);
  785.               FToken := etLE;
  786.             end;
  787.           '>':
  788.             begin
  789.               Inc(P);
  790.               FToken := etNE;
  791.             end;
  792.         else
  793.           FToken := etLT;
  794.         end;
  795.       end;
  796.     '=':
  797.       begin
  798.         Inc(P);
  799.         FToken := etEQ;
  800.       end;
  801.     '>':
  802.       begin
  803.         Inc(P);
  804.         if P^ = '=' then
  805.         begin
  806.           Inc(P);
  807.           FToken := etGE;
  808.         end else
  809.           FToken := etGT;
  810.       end;
  811.     #0:
  812.       FToken := etEnd;
  813.   else
  814.     DatabaseErrorFmt(SExprInvalidChar, [P^]);
  815.   end;
  816.   FSourcePtr := P;
  817. end;
  818.  
  819. function TExprParser.ParseExpr: PExprNode;
  820. begin
  821.   Result := ParseExpr2;
  822.   while TokenSymbolIs('OR') do
  823.   begin
  824.     NextToken;
  825.     Result := FFilter.NewNode(enOperator, canOR, Unassigned,
  826.       Result, ParseExpr2);
  827.   end;
  828. end;
  829.  
  830. function TExprParser.ParseExpr2: PExprNode;
  831. begin
  832.   Result := ParseExpr3;
  833.   while TokenSymbolIs('AND') do
  834.   begin
  835.     NextToken;
  836.     Result := FFilter.NewNode(enOperator, canAND, Unassigned,
  837.       Result, ParseExpr3);
  838.   end;
  839. end;
  840.  
  841. function TExprParser.ParseExpr3: PExprNode;
  842. begin
  843.   if TokenSymbolIs('NOT') then
  844.   begin
  845.     NextToken;
  846.     Result := FFilter.NewNode(enOperator, canNOT, Unassigned,
  847.       ParseExpr4, nil);
  848.   end else
  849.     Result := ParseExpr4;
  850. end;
  851.  
  852. function TExprParser.ParseExpr4: PExprNode;
  853. const
  854.   Operators: array[etEQ..etLT] of CanOp = (
  855.     canEQ, canNE, canGE, canLE, canGT, canLT);
  856. var
  857.   Operator: CanOp;
  858. begin
  859.   Result := ParseExpr5;
  860.   if FToken in [etEQ..etLT] then
  861.   begin
  862.     Operator := Operators[FToken];
  863.     NextToken;
  864.     Result := FFilter.NewNode(enOperator, Operator, Unassigned,
  865.       Result, ParseExpr5);
  866.   end;
  867. end;
  868.  
  869. function TExprParser.ParseExpr5: PExprNode;
  870. begin
  871.   case FToken of
  872.     etSymbol:
  873.       if TokenSymbolIs('NULL') then
  874.         Result := FFilter.NewNode(enConst, canNOTDEFINED, System.Null, nil, nil)
  875.       else if TokenSymbolIs(FStrTrue) then
  876.         Result := FFilter.NewNode(enConst, canNOTDEFINED, 1, nil, nil)
  877.       else if TokenSymbolIs(FStrFalse) then
  878.         Result := FFilter.NewNode(enConst, canNOTDEFINED, 0, nil, nil)
  879.       else
  880.         Result := FFilter.NewNode(enField, canNOTDEFINED, FTokenString, nil, nil);
  881.     etName:
  882.       Result := FFilter.NewNode(enField, canNOTDEFINED, FTokenString, nil, nil);
  883.     etLiteral:
  884.       Result := FFilter.NewNode(enConst, canNOTDEFINED, FTokenString, nil, nil);
  885.     etLParen:
  886.       begin
  887.         NextToken;
  888.         Result := ParseExpr;
  889.         if FToken <> etRParen then DatabaseErrorFmt(SExprNoRParen, [TokenName]);
  890.       end;
  891.   else
  892.     DatabaseErrorFmt(SExprExpected, [TokenName]);
  893.     Result := nil;
  894.   end;
  895.   NextToken;
  896. end;
  897.  
  898. function TExprParser.TokenName: string;
  899. begin
  900.   if FSourcePtr = FTokenPtr then Result := SExprNothing else
  901.   begin
  902.     SetString(Result, FTokenPtr, FSourcePtr - FTokenPtr);
  903.     Result := '''' + Result + '''';
  904.   end;
  905. end;
  906.  
  907. function TExprParser.TokenSymbolIs(const S: string): Boolean;
  908. begin
  909.   Result := (FToken = etSymbol) and (CompareText(FTokenString, S) = 0);
  910. end;
  911.  
  912. { TMasterDataLink }
  913.  
  914. constructor TMasterDataLink.Create(DataSet: TDataSet);
  915. begin
  916.   inherited Create;
  917.   FDataSet := DataSet;
  918.   FFields := TList.Create;
  919. end;
  920.  
  921. destructor TMasterDataLink.Destroy;
  922. begin
  923.   FFields.Free;
  924.   inherited Destroy;
  925. end;
  926.  
  927. procedure TMasterDataLink.ActiveChanged;
  928. begin
  929.   FFields.Clear;
  930.   if Active then
  931.     try
  932.       DataSet.GetFieldList(FFields, FFieldNames);
  933.     except
  934.       FFields.Clear;
  935.       raise;
  936.     end;
  937.   if FDataSet.Active and not (csDestroying in FDataSet.ComponentState) then
  938.     if Active and (FFields.Count > 0) then
  939.     begin
  940.       if Assigned(FOnMasterChange) then FOnMasterChange(Self);
  941.     end else
  942.       if Assigned(FOnMasterDisable) then FOnMasterDisable(Self);
  943. end;
  944.  
  945. procedure TMasterDataLink.CheckBrowseMode;
  946. begin
  947.   if FDataSet.Active then FDataSet.CheckBrowseMode;
  948. end;
  949.  
  950. procedure TMasterDataLink.LayoutChanged;
  951. begin
  952.   ActiveChanged;
  953. end;
  954.  
  955. procedure TMasterDataLink.RecordChanged(Field: TField);
  956. begin
  957.   if (DataSource.State <> dsSetKey) and FDataSet.Active and
  958.     (FFields.Count > 0) and ((Field = nil) or
  959.     (FFields.IndexOf(Field) >= 0)) and
  960.      Assigned(FOnMasterChange) then
  961.     FOnMasterChange(Self);
  962. end;
  963.  
  964. procedure TMasterDataLink.SetFieldNames(const Value: string);
  965. begin
  966.   if FFieldNames <> Value then
  967.   begin
  968.     FFieldNames := Value;
  969.     ActiveChanged;
  970.   end;
  971. end;
  972.  
  973.  
  974. end.