1{ 2 This file is part of the Free Component Library (FCL) 3 Copyright (c) 1999-2007 by the Free Pascal development team 4 5 See the file COPYING.FPC, included in this distribution, 6 for details about the copyright. 7 8 This program is distributed in the hope that it will be useful, 9 but WITHOUT ANY WARRANTY; without even the implied warranty of 10 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 11 12 **********************************************************************} 13{$mode objfpc} 14{$H+} 15{ 16 TParadox : Dataset wich can handle paradox files, based on PXLib. 17 pxlib is an open source C library for handling paradox files. It 18 is available from sourceforge: 19 http://pxlib.sourceforge.net/ 20 it must be downloaded and installed separately. The header translations 21 for version 0.6.2 of pxlib are available in the pxlib unit in the Free 22 Pascal Packages. 23 24 The TParadox component was implemented by Michael Van Canneyt 25} 26 27unit paradox; 28 29interface 30 31uses 32 sysutils, classes, db, pxlib, bufdataset_parser; 33 34type 35 EParadox=class(Exception); 36 37 { TParadox } 38 39 TParadox = Class(TDataSet) 40 private 41 FBlobFileName: String; 42 FFileName : String; 43 FPXLibrary : String; 44 FCurrRecNo : Integer; 45 FDoc : PPX_Doc; 46 FFilterBuffer : TRecordBuffer; 47 FOffsets : PInteger; 48 FTableName : String; 49 FInputEncoding : String; 50 FTargetEncoding : String; 51 FParser : TBufDatasetParser; 52 function GetInputEncoding: String; 53 function GetTableName: String; 54 function GetTargetEncoding: String; 55 procedure OpenBlobFile; 56 procedure PXAppendRecord(Buffer: Pointer); 57 function PXFilterRecord(Buffer: TRecordBuffer): Boolean; 58 function PXGetActiveBuffer(var Buffer: TRecordBuffer): Boolean; 59 procedure RaiseError(Fmt: String; Args: array of const); 60 procedure SetBlobFileName(const AValue: String); 61 procedure SetFileName(const AValue: String); 62 procedure SetInputEncoding(const AValue: String); 63 procedure SetOpenParams; 64 procedure SetTableName(const AValue: String); 65 procedure SetTargetEncoding(const AValue: String); 66 function GetLibStored : Boolean; 67 protected 68 // Mandatory 69 procedure SetFilterText(const Value: String); override; {virtual;} 70 procedure SetFiltered(Value: Boolean); override; {virtual;} 71 procedure ParseFilter(const AFilter: string); 72 73 function AllocRecordBuffer: TRecordBuffer; override; 74 procedure FreeRecordBuffer(var Buffer: TRecordBuffer); override; 75 procedure GetBookmarkData(Buffer: TRecordBuffer; Data: Pointer); override; 76 function GetBookmarkFlag(Buffer: TRecordBuffer): TBookmarkFlag; override; 77 function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override; 78 function GetRecord(Buffer: TRecordBuffer; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override; 79 function GetRecordSize: Word; override; 80 procedure InternalAddRecord(Buffer: Pointer; DoAppend: Boolean); override; 81 procedure InternalClose; override; 82 procedure InternalDelete; override; 83 procedure InternalFirst; override; 84 procedure InternalGotoBookmark(ABookmark: Pointer); override; 85 procedure InternalInitFieldDefs; override; 86 procedure InternalInitRecord(Buffer: TRecordBuffer); override; 87 procedure InternalLast; override; 88 procedure InternalOpen; override; 89 procedure InternalPost; override; 90 procedure InternalSetToRecord(Buffer: TRecordBuffer); override; 91 function IsCursorOpen: Boolean; override; 92 procedure SetBookmarkFlag(Buffer: TRecordBuffer; Value: TBookmarkFlag); override; 93 procedure SetBookmarkData(Buffer: TRecordBuffer; Data: Pointer); override; 94 procedure SetFieldData(Field: TField; Buffer: Pointer); override; 95 procedure DataConvert(aField: TField; aSource, aDest: Pointer; aToNative: Boolean); override; 96 function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override; 97 // Optional. 98 function GetRecordCount: Integer; override; 99 procedure SetRecNo(Value: Integer); override; 100 function GetRecNo: Integer; override; 101 // Exposed properties/procedures 102 Function GetParam(Const ParamName : String) : String; 103 Procedure SetParam(Const ParamName,ParamValue : String); 104 property Doc : PPX_Doc Read FDoc; 105 106 public 107 constructor Create(AOwner:tComponent); override; 108 destructor Destroy; override; 109 published 110 Property PXLibrary : String Read FPXLibrary Write FPXLibrary Stored GetLibStored; 111 Property FileName : String Read FFileName Write SetFileName; 112 Property BlobFileName : String Read FBlobFileName Write SetBlobFileName; 113 Property TableName : String Read GetTableName Write SetTableName; 114 Property TargetEncoding : String Read GetTargetEncoding Write SetTargetEncoding; 115 Property InputEncoding : String Read GetInputEncoding Write SetInputEncoding; 116 property filter; 117 property Filtered; 118 Property Active; 119 Property FieldDefs; 120 property BeforeOpen; 121 property AfterOpen; 122 property BeforeClose; 123 property AfterClose; 124 property BeforeInsert; 125 property AfterInsert; 126 property BeforeEdit; 127 property AfterEdit; 128 property BeforePost; 129 property AfterPost; 130 property BeforeCancel; 131 property AfterCancel; 132 property BeforeDelete; 133 property AfterDelete; 134 property BeforeScroll; 135 property AfterScroll; 136 property OnDeleteError; 137 property OnEditError; 138 property OnNewRecord; 139 property OnPostError; 140 property OnFilterRecord; 141 end; 142 143 // in front of graphic data 144 TGraphicHeader = packed record 145 Count: Word; { Always 1 } 146 HType: Word; { Always $0100 } 147 Size: Longint; { Size of actual data } 148 end; 149 150 151Function PXFieldTypeToFieldType(PXFieldType : Integer) : TFieldType; 152 153Const 154 SParamInputencoding = 'inputencoding'; 155 SParamTargetencoding = 'targetencoding'; 156 SParamTableName = 'tablename'; 157 158implementation 159 160uses ctypes; 161 162ResourceString 163 SErrFieldTypeNotSupported = 'Fieldtype of Field "%s" not supported: %d.'; 164 SErrBookMarkNotFound = 'Bookmark %d not found.'; 165 SErrNoFileName = 'Filename must not be empty.'; 166 SErrNoBlobFile = 'Blob file "%s" does not exist'; 167 SErrInvalidBlobFile = 'Blob file "%s" is invalid'; 168 SErrFailedToOpenFile = 'Failed to open file "%s" as a paradox file.'; 169 SErrParadoxNotOpen = 'Paradox file not opened'; 170 SErrGetParamFailed = 'Get of parameter %s failed.'; 171 SErrSetParamFailed = 'Set of parameter %s failed.'; 172 173Const 174 PXFieldTypes : Array[1..pxfNumTypes] of TFieldType 175 = (ftString, ftDate, ftSmallInt, ftInteger, 176 ftCurrency, ftFloat, ftUnknown { $07},ftunknown { $08}, 177 ftBoolean,ftUnknown { $0A}, ftunknown { $0B}, ftMemo, 178 ftBlob, ftFmtMemo, ftParadoxOle, ftGraphic, 179 ftUnknown { $11}, ftUnknown { $12}, ftUnknown { $13}, ftTime, 180 ftDateTime, ftAutoinc, ftBCD, ftBytes); 181 { 182 Buffer layout : 183 Bookmark : Record number 184 BookmarkFlag : Flag 185 Data : Actual data 186 } 187Type 188 PPXRecInfo = ^TPXRecInfo; 189 TPXRecInfo = packed record 190 Bookmark: Longint; 191 BookmarkFlag: TBookmarkFlag; 192 end; 193 PDateTime = ^TDateTime; 194 195Const 196 DataOffSet = SizeOf(TPXRecInfo); 197 198{ --------------------------------------------------------------------- 199 Utility functions 200 ---------------------------------------------------------------------} 201 202Function PXFieldTypeToFieldType(PXFieldType : Integer) : TFieldType; 203 204begin 205 if (PXFieldType<1) or (PXFieldType>pxfNumTypes) then 206 Result:=ftUnknown 207 else 208 Result:=PXFieldTypes[PXFieldType]; 209end; 210 211Var 212 PXLibRefcount : Integer = 0; 213 214Procedure UninitPXLib; 215 216begin 217 If (PXLibRefCount>0) then 218 begin 219 Dec(PXLibRefCount); 220 If (PXLibRefCount=0) then 221 begin 222 PX_ShutDown(); 223 FreePXLib; 224 end; 225 end; 226end; 227 228Procedure InitPXLib(LibName : String); 229 230begin 231 If (PXLibRefCount=0) then 232 begin 233 LoadPXLib(LibName); 234 PX_Boot(); 235 end; 236 Inc(PXLibRefCount); 237end; 238 239{ --------------------------------------------------------------------- 240 TParadox 241 ---------------------------------------------------------------------} 242 243 244constructor TParadox.Create(AOwner:tComponent); 245 246begin 247 inherited create(aOwner); 248 FPXLibrary:=pxlibraryname; 249end; 250 251Destructor TParadox.Destroy; 252begin 253 Close; 254 UnInitPXLib; 255 inherited Destroy; 256end; 257 258 259Procedure TParadox.RaiseError(Fmt : String; Args : Array of const); 260 261begin 262 Raise EParadox.CreateFmt(Fmt,Args); 263end; 264 265Function TParadox.GetLibStored : boolean; 266 267begin 268 Result:=(FPXLibrary<>pxlibraryname); 269end; 270 271procedure TParadox.SetBlobFileName(const AValue: String); 272begin 273 if (FBlobFileName=AValue) then 274 exit; 275 CheckInactive; 276 FBlobFileName:=AValue; 277end; 278 279function TParadox.PXFilterRecord(Buffer: TRecordBuffer): Boolean; 280 281var 282 SaveState: TDatasetState; 283 284begin 285 Result:=True; 286 if not Assigned(OnFilterRecord) and Not Filtered then 287 Exit; 288 SaveState:=SetTempState(dsFilter); 289 Try 290 FFilterBuffer:=Buffer; 291 If Assigned(OnFilterRecord) then 292 OnFilterRecord(Self,Result); 293 If Result and Filtered and (Filter<>'') then 294 Result:=Boolean((FParser.ExtractFromBuffer(FFilterBuffer))^); 295 Finally 296 RestoreState(SaveState); 297 end; 298end; 299 300{ 301 302procedure TParadox.MDSReadRecord(Buffer:TRecordBuffer;ARecNo:Integer); //Reads a Rec from Stream in Buffer 303begin 304 FStream.Position:=MDSGetRecordOffset(ARecNo); 305 FStream.ReadBuffer(Buffer^, FRecSize); 306end; 307 308procedure TParadox.MDSWriteRecord(Buffer:TRecordBuffer;ARecNo:Integer); //Writes a Rec from Buffer to Stream 309begin 310 FStream.Position:=MDSGetRecordOffset(ARecNo); 311 FStream.WriteBuffer(Buffer^, FRecSize); 312 FFileModified:=True; 313end; 314 315procedure TParadox.MDSAppendRecord(Buffer:TRecordBuffer); //Appends a Rec (from Buffer) to Stream 316begin 317 FStream.Position:=MDSGetRecordOffset(FRecCount); 318 FStream.WriteBuffer(Buffer^, FRecSize); 319 FFileModified:=True; 320end; 321} 322 323function TParadox.PXGetActiveBuffer(var Buffer: TRecordBuffer): Boolean; 324 325begin 326 case State of 327 dsBrowse: 328 if IsEmpty then 329 Buffer:=nil 330 else 331 Buffer:=ActiveBuffer; 332 dsEdit, 333 dsInsert: 334 Buffer:=ActiveBuffer; 335 dsFilter: 336 Buffer:=FFilterBuffer; 337 else 338 Buffer:=nil; 339 end; 340 Result:=(Buffer<>nil); 341end; 342 343procedure TParadox.SetFileName(const AValue: String); 344begin 345 CheckInactive; 346 FFileName:=AValue; 347end; 348 349procedure TParadox.SetInputEncoding(const AValue: String); 350begin 351 If Assigned(FDoc) then 352 SetParam(SParamInputencoding,AVAlue); 353 FInputEncoding:=AValue; 354end; 355 356procedure TParadox.SetTableName(const AValue: String); 357begin 358 If Assigned(FDoc) then 359 SetParam(SParamTableName,AVAlue); 360 FTableName:=AValue; 361end; 362 363procedure TParadox.SetTargetEncoding(const AValue: String); 364begin 365 If Assigned(FDoc) then 366 SetParam(SParamTargetEncoding,AVAlue); 367 FTargetEncoding:=AValue; 368end; 369 370procedure TParadox.SetFilterText(const Value: String); 371begin 372 if (Value<>Filter) then 373 begin 374 ParseFilter(Value); 375 inherited; 376 if IsCursorOpen and Filtered then 377 Refresh; 378 end; 379end; 380 381procedure TParadox.SetFiltered(Value: Boolean); 382begin 383 if (Value<>Filtered) then 384 begin 385 inherited; 386 if IsCursorOpen then 387 Refresh; 388 end; 389end; 390 391 392//Abstract Overrides 393function TParadox.AllocRecordBuffer: TRecordBuffer; 394begin 395 Result:=Nil; 396 GetMem(Result,SizeOf(TPXRecInfo)+GetRecordSize); 397end; 398 399procedure TParadox.FreeRecordBuffer (var Buffer: TRecordBuffer); 400begin 401 FreeMem(Buffer); 402end; 403 404procedure TParadox.InternalInitRecord(Buffer: TRecordBuffer); 405 406begin 407 fillchar((Buffer+DataOffSet)^,GetRecordSize,0); 408end; 409 410procedure TParadox.InternalDelete; 411 412begin 413 If (FCurrRecNo<>-1) then 414 PX_delete_record(FDoc,FCurrRecNo); 415end; 416 417procedure TParadox.InternalInitFieldDefs; 418 419Var 420 I, CurrOffSet, ACount : Integer; 421 FN : String; 422 FS : Integer; 423 B : Boolean; 424 FT : TFieldType; 425 pxf : Ppxfield_t; 426 427begin 428 FieldDefs.Clear; 429 pxf:=PX_get_fields(FDoc); 430 ACount:= PX_get_num_fields(FDoc); 431 ReallocMem(FOffsets,ACount*SizeOf(Integer)); 432 FillChar(FOffSets^,ACount*SizeOf(Integer),0); 433 CurrOffSet:=DataOffset; 434 For I:=0 to ACount-1 do 435 begin 436 FOffsets[I]:=CurrOffset; 437 FN:=strpas(pxf^.px_fname); 438 FT:=PXFieldTypeToFieldType(pxf^.px_ftype); 439 If (FT=ftUnKnown) then 440 RaiseError(SErrFieldTypeNotSupported,[FN,pxf^.px_ftype]); 441 If (FT in [ftString,ftBlob,ftMemo,ftFmtMemo,ftGraphic,ftParadoxOle,ftBytes]) then 442 FS:=pxf^.px_flen 443 else if (Ft=ftBCD) then 444 FS:=pxf^.px_fdc 445 else 446 FS:=0; 447 B:=False; // No way to detect required paradox fields ? 448 FieldDefs.Add(FN,ft,FS,B); 449 Inc(CurrOffset,pxf^.px_flen); 450 Inc(pxf); 451 end; 452end; 453 454procedure TParadox.InternalFirst; 455begin 456 FCurrRecNo:=-1; 457end; 458 459procedure TParadox.InternalLast; 460begin 461 FCurrRecNo:=PX_Get_num_records(FDoc); 462end; 463 464procedure TParadox.SetOpenParams; 465 466begin 467 If (FTargetEncoding<>'') then 468 SetParam(SParamTargetEncoding,FTargetEncoding); 469 If (FInputEncoding<>'') then 470 SetParam(SParamInputEncoding,FInputEncoding); 471end; 472 473procedure TParadox.OpenBlobFile; 474 475Var 476 BFN : string; 477begin 478 BFN:=FBlobFileName; 479 If (BFN<>'') then 480 if not FileExists(BFN) then 481 RaiseError(SErrNoBlobFile,[BFN]); 482 If (BFN='') then 483 begin 484 BFN:=ChangeFileExt(FFileName,'.mb'); 485 If Not FileExists(BFN) then 486 begin 487 BFN:=ChangeFileExt(FFileName,'.MB'); 488 If Not FileExists(BFN) then 489 BFN:=''; 490 end; 491 end; 492 If (BFN<>'') then 493 begin 494 //Writeln('opening blib file',bfn); 495 if PX_set_blob_file(FDoc,PChar(BFN))<>0 then 496 RaiseError(SErrInvalidBlobFile,[BFN]); 497 FBlobFileName:=BFN; 498 end; 499end; 500 501procedure TParadox.InternalOpen; 502 503Var 504 FN : String; 505 506begin 507 InitPXLib(FPXLibrary); 508 If (FFileName='') then 509 RaiseError(SErrNoFileName,[]); 510 FN:=FFileName; 511 FDoc:=PX_New(); 512 try 513 If (px_open_file(FDoc,PChar(FN))<>0) then 514 RaiseError(SErrFailedToOpenFile,[FN]); 515 SetOpenParams; 516 OpenBlobFile; 517 InternalInitFieldDefs; 518 if DefaultFields then 519 CreateFields; 520 BindFields(True); 521 FCurrRecNo:=-1; 522 except 523 If Assigned(FDoc) then 524 begin 525 PX_Delete(FDoc); 526 FDoc:=Nil; 527 end; 528 Raise; 529 end; 530 try 531 ParseFilter(Filter); 532 except 533 On E : Exception do 534 Filter:=''; 535 end; 536end; 537 538procedure TParadox.ParseFilter(const AFilter: string); 539begin 540 // parser created? 541 if Length(AFilter) > 0 then 542 begin 543 if (FParser = nil) and IsCursorOpen then 544 begin 545 FParser := TBufDatasetParser.Create(Self); 546 end; 547 // have a parser now? 548 if FParser <> nil then 549 begin 550 // set options 551 FParser.PartialMatch := not (foNoPartialCompare in FilterOptions); 552 FParser.CaseInsensitive := foCaseInsensitive in FilterOptions; 553 // parse expression 554 FParser.ParseExpression(AFilter); 555 end; 556 end; 557end; 558procedure TParadox.InternalClose; 559 560begin 561 BindFields(False); 562 if DefaultFields then 563 DestroyFields; 564 FreeAndNil(FParser); 565 FreeMem(FOffsets); 566 FOffSets:=Nil; 567 FCurrRecNo:=-1; 568 If Assigned(FDoc) then 569 begin 570 PX_close(FDoc); 571 PX_Delete(FDOc); 572 end; 573 FDoc:=Nil; 574end; 575 576procedure TParadox.InternalPost; 577begin 578 CheckActive; 579 if ((State<>dsEdit) and (State<>dsInsert)) then 580 Exit; 581 if (State=dsEdit) then 582 PX_put_recordn(FDoc,pansichar(ActiveBuffer), FCurrRecNo) 583 else 584 InternalAddRecord(ActiveBuffer,True); 585end; 586 587function TParadox.IsCursorOpen: Boolean; 588 589begin 590 Result:=(FDoc<>Nil); 591end; 592 593function TParadox.GetRecord(Buffer: TRecordBuffer; GetMode: TGetMode; DoCheck: Boolean): TGetResult; 594 595var 596 Accepted: Boolean; 597 598begin 599 Result:=grOk; 600 Accepted:=False; 601 if (GetRecordCount<1) then 602 begin 603 Result:=grEOF; 604 exit; 605 end; 606 repeat 607 case GetMode of 608 gmCurrent: 609 if (FCurrRecNo>=GetRecordCount) or (FCurrRecNo<0) then 610 Result:=grError; 611 gmNext: 612 if (FCurrRecNo<GetRecordCount-1) then 613 Inc(FCurrRecNo) 614 else 615 Result:=grEOF; 616 gmPrior: 617 if (FCurrRecNo>0) then 618 Dec(FCurrRecNo) 619 else 620 result:=grBOF; 621 end; 622 if result=grOK then 623 begin 624 PX_get_record(Doc,FCurrRecNo,pansichar(Buffer+DataOffset)); 625 PPXRecInfo(Buffer)^.Bookmark:=FCurrRecNo; 626 PPXRecInfo(Buffer)^.BookmarkFlag:=bfCurrent; 627 if (Filtered) then 628 Accepted:=PXFilterRecord(Buffer) //Filtering 629 else 630 Accepted:=True; 631 if (GetMode=gmCurrent) and not Accepted then 632 result:=grError; 633 end; 634 until (result<>grOK) or Accepted; 635end; 636 637function TParadox.GetFieldData(Field: TField; Buffer: Pointer): Boolean; 638 639var 640 Buf : TRecordbuffer; 641 No,pft,flen : integer; 642 pxf : PPx_field; 643 Value : Pchar; 644 D : clong; 645 longv : Clong; 646 R : Double; 647 c : Char; 648 649begin 650 No:=Field.FieldNo-1; 651 Buf:=Nil; 652 result:=(No>=0) and PXGetActiveBuffer(Buf); 653 if result and (buffer <> nil) then 654 begin 655 pxf:=PX_get_field(FDoc,No); 656 Flen:=pxf^.px_flen; // Field length 657 pft:=pxf^.px_ftype; // Field type 658 Assert(PXFieldTypes[pft]=Field.DataType,'Field types do not match'); 659 Inc(Buf,FOffsets[No]); // Move to actual field offset 660 Case pft of 661 pxfAlpha: 662 begin 663 Result:=PX_get_data_alpha(FDoc,pansichar(Buf),flen,@value)>0; 664 If result then 665 begin 666 Move(Value^,Buffer^,flen); 667 If (Flen<=Field.DataSize) then 668 Pchar(Buffer)[flen]:=#0; 669 FDoc^.free(FDoc,value); 670 end; 671 end; 672 pxfDate: 673 begin 674 Result:=PX_get_data_long(FDoc,pansichar(Buf),flen,@longv)>0; 675 If Result then 676 begin 677 // 1721425 is the number of the days between the start of the 678 // julian calendar (4714 BC) and jan-00-0000 (Paradox base date) 679 // 2415019 is the number of the days between the start of the 680 // julian calendar (4714 BC) and dec-30-1899 (TDateTime base date) 681 PDateTime(Buffer)^:=Longv+1721425-2415019; 682 end; 683 end; 684 pxfShort: 685 begin 686 Result:=PX_get_data_short(FDoc,pansichar(Buf), flen, @D)>0; 687 If result then 688 PSmallInt(Buffer)^:=D; 689 end; 690 pxfAutoInc, 691 pxfLong: 692 begin 693 Result:=(PX_get_data_long(FDoc,pansichar(buf),flen,@longv)>0); 694 If Result then 695 PInteger(Buffer)^:=Longv; 696 end; 697 pxfCurrency, 698 pxfNumber: 699 begin 700 Result:=(PX_get_data_double(FDoc,pansichar(Buf),Flen,@R)>0); 701 If Result then 702 PDouble(Buffer)^:=R; 703 end; 704 pxfLogical: 705 begin 706 Result:=(PX_get_data_byte(FDoc,pansichar(Buf),flen,@C)>0); 707 If result then 708 PWordBool(Buffer)^:=(C<>#0); 709 end; 710 pxfBytes: 711 begin 712 Result:=PX_get_data_bytes(FDoc,pansichar(Buf),FLen,@Value)>0; 713 If Result then 714 begin 715 Move(Value^,Buffer^,FLen); 716 FDoc^.free(FDoc,value); 717 end; 718 end; 719 pxfMemoBLOb, 720 pxfBLOb, 721 pxfFmtMemoBLOb, 722 pxfOLE, 723 pxfGraphic: 724 begin 725 Result:=True; 726 Move(Buf^,Buffer^,FLen); 727 end; 728 pxfTime: 729 begin 730 Result:=(PX_get_data_long(FDoc,pansichar(Buf),flen,@longv)>0); 731 If result then 732 PDateTime(Buffer)^:=longv/MSecsPerDay; 733 end; 734 pxfTimestamp: 735 begin 736 Result:=(PX_get_data_double(FDoc,pansichar(buf),flen,@R)>0); 737 if Result then 738 begin 739 longv:=trunc(R /86400000); 740 D:=Longv+1721425-2415019; 741 longv:=(Trunc(r) mod 86400000); 742 PDateTime(Buffer)^:=D+(Longv/MSecsPerday); 743 end; 744 end; 745 pxfBCD: 746 begin 747 Result:=(PX_get_data_bcd(FDoc,pcuchar(Buf),pxf^.px_fdc,@Value)>0); 748 if Result then 749 begin 750 PCurrency(Buffer)^:=StrToCurr(StrPas(value)); 751 FDoc^.free(FDoc,value); 752 end; 753 end; 754 else 755 RaiseError('Unknown type (%d) (%d)',[pxf^.px_ftype, pxf^.px_flen]); 756 end; 757 end; 758end; 759 760procedure TParadox.SetFieldData(Field: TField; Buffer: Pointer); 761 762var 763 DestBuffer: TRecordBuffer; 764 I: integer; 765 766begin 767 DestBuffer:=Nil; 768 I:=Field.FieldNo-1; 769 if (I >= 0) and PXGetActiveBuffer(DestBuffer) then 770 begin 771 dataevent(deFieldChange,ptrint(field)); 772 end; 773end; 774 775procedure TParadox.DataConvert(aField: TField; aSource, aDest: Pointer; 776 aToNative: Boolean); 777begin 778 If AField.DataType in [ftDate,ftTime,ftDateTime] then 779 PDateTime(aDest)^:=PDateTime(aSource)^ 780 else 781 inherited DataConvert(aField, aSource, aDest, aToNative); 782end; 783 784 785function TParadox.CreateBlobStream(Field: TField; Mode: TBlobStreamMode 786 ): TStream; 787 788TYpe 789 PGraphicHeader = ^TGraphicHeader; 790Var 791 FBuf,Value,V2 : Pchar; 792 FLen,Res : Integer; 793 M,D : Cint; 794 H : PGraphicHeader; 795 796begin 797 Result:=Nil; 798 FLen:=Field.Size; 799 If Mode=bmRead then 800 begin 801 FBuf:=GetMem(FLen); 802 Try 803 If Not Field.GetData(FBuf,True) then 804 exit; 805 if (Field.DataType=ftGraphic) then 806 Res:=PX_get_data_graphic(FDoc,FBuf,FLen,@M,@D,@Value) 807 else 808 Res:=PX_get_data_blob(FDoc,FBuf,FLen,@M,@D,@Value); 809 If (Res>0) and (Value<>Nil) then 810 begin 811 Result:=TMemoryStream.Create; 812 V2:=Value; 813 if (Field.DataType=ftGraphic) then 814 begin 815 Result.WriteAnsiString('bmp'); 816 Result.WriteBuffer(V2^,D-SizeOf(TGraphicHeader)); 817 end 818 else 819 Result.WriteBuffer(V2^,D); 820 Result.Position:=0; 821 FDoc^.free(FDoc,Value); 822 end; 823 Finally 824 FreeMem(FBuf); 825 end; 826 end 827 else 828 Result:=TMemoryStream.Create; 829end; 830 831function TParadox.GetRecordSize: Word; 832 833begin 834 Result:=PX_Get_RecordSize(FDoc); 835end; 836 837procedure TParadox.InternalGotoBookmark(ABookmark: Pointer); 838 839var 840 ReqBookmark: integer; 841 842begin 843 ReqBookmark:=PInteger(ABookmark)^; 844 if (ReqBookmark>=0) and (ReqBookmark<GetRecordCount) then 845 FCurrRecNo:=ReqBookmark 846 else 847 RaiseError(SErrBookMarkNotFound,[ReqBookmark]); 848end; 849 850procedure TParadox.InternalSetToRecord(Buffer: TRecordBuffer); 851 852var 853 ReqBookmark: integer; 854 855begin 856 ReqBookmark:=PPXRecInfo(Buffer)^.Bookmark; 857 InternalGotoBookmark (@ReqBookmark); 858end; 859 860function TParadox.GetBookmarkFlag(Buffer: TRecordBuffer): TBookmarkFlag; 861 862begin 863 Result:=PPXRecInfo(Buffer)^.BookmarkFlag; 864end; 865 866procedure TParadox.SetBookmarkFlag(Buffer: TRecordBuffer; Value: TBookmarkFlag); 867 868begin 869 PPXRecInfo(Buffer)^.BookmarkFlag := Value; 870end; 871 872procedure TParadox.GetBookmarkData(Buffer: TRecordBuffer; Data: Pointer); 873 874begin 875 if Data<>nil then 876 PInteger(Data)^:=PPXRecInfo(Buffer)^.Bookmark; 877end; 878 879procedure TParadox.SetBookmarkData(Buffer: TRecordBuffer; Data: Pointer); 880 881begin 882 if Data<>nil then 883 PPXRecInfo(Buffer)^.Bookmark:=PInteger(Data)^ 884 else 885 PPXRecInfo(Buffer)^.Bookmark:=0; 886end; 887 888procedure TParadox.InternalAddRecord(Buffer: Pointer; DoAppend: Boolean); 889 890begin 891 PXAppendRecord(ActiveBuffer); 892 InternalLast; 893end; 894 895procedure TParadox.PXAppendRecord(Buffer : Pointer); 896 897begin 898end; 899 900function TParadox.GetInputEncoding: String; 901begin 902 If Assigned(FDoc) then 903 Result:=GetParam('inputencoding') 904 else 905 Result:=FInputEncoding; 906end; 907 908function TParadox.GetTableName: String; 909begin 910 If Assigned(FDoc) then 911 Result:=GetParam('tablename') 912 else 913 Result:=FInputEncoding; 914end; 915 916function TParadox.GetTargetEncoding: String; 917begin 918 If Assigned(FDoc) then 919 Result:=GetParam('targetencoding') 920 else 921 Result:=FTargetEncoding; 922end; 923 924procedure TParadox.SetRecNo(Value: Integer); 925begin 926 CheckBrowseMode; 927 if (Value>=1) and (Value<=GetRecordCount) then 928 begin 929 FCurrRecNo:=Value-1; 930 Resync([]); 931 end; 932end; 933 934Function TParadox.GetRecNo: Longint; 935 936begin 937 UpdateCursorPos; 938 if (FCurrRecNo<0) then 939 Result:=1 940 else 941 Result:=FCurrRecNo+1; 942end; 943 944function TParadox.GetParam(const ParamName: String): String; 945 946Var 947 V : Pchar; 948 949begin 950 If Not Assigned(FDoc) then 951 RaiseError(SErrParadoxNotOpen,[]); 952 if (PX_Get_parameter(FDoc,Pchar(ParamName),@V)<>0) then 953 RaiseError(SErrGetParamFailed,[ParamName]); 954 If (V<>Nil) then 955 Result:=strpas(V); 956end; 957 958procedure TParadox.SetParam(const ParamName, ParamValue: String); 959begin 960 If Not Assigned(FDoc) then 961 RaiseError(SErrParadoxNotOpen,[]); 962 if (PX_Set_parameter(FDoc,Pchar(ParamName),PChar(ParamValue))<>0) then 963 RaiseError(SErrSetParamFailed,[ParamName]); 964end; 965 966Function TParadox.GetRecordCount: Longint; 967 968begin 969 If Assigned(FDoc) then 970 Result:=PX_Get_num_records(FDoc) 971 else 972 Result:=0; 973end; 974 975 976end. 977