home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / tpw / owldemos / pxaccess.pas < prev    next >
Pascal/Delphi Source File  |  1991-05-20  |  7KB  |  279 lines
  1. {************************************************}
  2. {                                                }
  3. {   Turbo Pascal for Windows                     }
  4. {   Paradox Engine demo access unit              }
  5. {   Copyright (c) 1991 by Borland International  }
  6. {                                                }
  7. {************************************************}
  8.  
  9. unit PXAccess;
  10.  
  11. interface
  12.  
  13. {$N+}
  14.  
  15. uses WObjects, PXEngine;
  16.  
  17. type
  18.   PFieldArray = ^TFieldArray;
  19.   TFieldArray = array[1..256] of PChar;
  20.  
  21. type
  22.   PPXTable = ^TPXTable;
  23.   TPXTable = object(TObject)
  24.     Status: Integer;
  25.     constructor Init(TableName: PChar);
  26.     destructor Done; virtual;
  27.     procedure ClearError;
  28.     function FieldName(Field: Integer): PChar;
  29.     function FieldType(Field: Integer): PChar;
  30.     function FieldWidth(Field: Integer): Integer;
  31.     function GetField(Rec, Fld: Integer): PChar;
  32.     function NumRecords: LongInt;
  33.     function NumFields: Integer;
  34.     procedure PXError(Error: Integer); virtual;
  35.   private
  36.     CurRecord: Integer;
  37.     TblHandle: TableHandle;
  38.     RecHandle: RecordHandle;
  39.     NumFlds: Integer;
  40.     NumRecs: LongInt;
  41.     FieldNames: PFieldArray;
  42.     FieldTypes: PFieldArray;
  43.     Cache: Pointer;
  44.     function CheckError(Code: Integer): Boolean;
  45.   end;
  46.  
  47. implementation
  48.  
  49. uses WinTypes, WinProcs, Strings;
  50.  
  51. type
  52.   PCache = ^TCache;
  53.   TCache = object(TCollection)
  54.     constructor Init(CacheSize: Integer);
  55.     procedure Add(Index: LongInt; P: PChar);
  56.     function Get(Index: LongInt): PChar;
  57.     procedure FreeItem(P: Pointer); virtual;
  58.   end;
  59.  
  60. type
  61.   PCacheElement = ^TCacheElement;
  62.   TCacheElement = record
  63.     Index: LongInt;
  64.     Item: PChar;
  65.   end;
  66.  
  67. constructor TCache.Init(CacheSize: Integer);
  68. begin
  69.   TCollection.Init(CacheSize, 0);
  70. end;
  71.  
  72. procedure TCache.Add(Index: LongInt; P: PChar);
  73. var
  74.   CE: PCacheElement;
  75. begin
  76.   New(CE);
  77.   CE^.Index := Index;
  78.   CE^.Item := P;
  79.   if Count = Limit then AtFree(Count - 1);
  80.   AtInsert(0, CE);
  81. end;
  82.  
  83. function TCache.Get(Index: LongInt): PChar;
  84. var
  85.   P: PCacheElement;
  86.  
  87.   function ItemWithIndex(P: PCacheElement): Boolean; far;
  88.   begin
  89.     ItemWithIndex := P^.Index = Index;
  90.   end;
  91.  
  92. begin
  93.   Get := nil;
  94.   P := FirstThat(@ItemWithIndex);
  95.   if P <> nil then Get := P^.Item;
  96. end;
  97.  
  98. procedure TCache.FreeItem(P: Pointer);
  99. begin
  100.   StrDispose(PCacheElement(P)^.Item);
  101.   Dispose(P);
  102. end;
  103.  
  104. { TPXTable }
  105.  
  106. constructor TPXTable.Init(TableName: PChar);
  107. var
  108.   Temp: array[0..25] of Char;
  109.   I: Integer;
  110. begin
  111.   FieldTypes := nil;
  112.   FieldNames := nil;
  113.   Status := 0;
  114.   CurRecord := -1;
  115.   if CheckError(PXTblOpen(TableName, TblHandle, 0, True)) and
  116.      CheckError(PXRecBufOpen(TblHandle, RecHandle)) and
  117.      CheckError(PXRecBufOpen(tblHandle, recHandle)) and
  118.      CheckError(PXRecNFlds(tblHandle, NumFlds)) and
  119.      CheckError(PXTblNRecs(tblHandle, NumRecs)) then
  120.   begin
  121.     GetMem(FieldTypes, NumFields * SizeOf(PChar));
  122.     GetMem(FieldNames, NumFields * SizeOf(PChar));
  123.     for I := 1 to NumFields do
  124.     begin
  125.       CheckError(PXFldName(TblHandle, I, SizeOf(Temp), Temp));
  126.       FieldNames^[I] := StrNew(Temp);
  127.       CheckError(PXFldType(TblHandle, I, SizeOf(Temp), Temp));
  128.       FieldTypes^[I] := StrNew(Temp);
  129.     end;
  130.     Cache := New(PCache, Init(300));
  131.   end;
  132. end;
  133.  
  134. destructor TPXTable.Done;
  135. var
  136.   I: Integer;
  137. begin
  138.   TObject.Done;
  139.   PXRecBufClose(RecHandle);
  140.   PXTblClose(TblHandle);
  141.   if (FieldTypes <> nil) and (FieldNames <> nil) then
  142.     for I := 1 to NumFields do
  143.     begin
  144.       StrDispose(FieldNames^[I]);
  145.       StrDispose(FieldTypes^[I]);
  146.     end;
  147.   if FieldTypes <> nil then FreeMem(FieldTypes, NumFields * SizeOf(PChar));
  148.   if FieldNames <> nil then FreeMem(FieldNames, NumFields * SizeOf(PChar));
  149. end;
  150.  
  151. function TPXTable.CheckError(Code: Integer): Boolean;
  152. begin
  153.   if Status = 0 then
  154.   begin
  155.     if Code <> 0 then PXError(Code);
  156.     Status := Code;
  157.   end;
  158.   CheckError := Status = 0;
  159. end;
  160.  
  161. procedure TPXTable.ClearError;
  162. begin
  163.   Status := 0;
  164. end;
  165.  
  166. function TPXTable.FieldName(Field: Integer): PChar;
  167. begin
  168.   FieldName := FieldNames^[Field];
  169. end;
  170.  
  171. function TPXTable.FieldType(Field: Integer): PChar;
  172. begin
  173.   FieldType := FieldTypes^[Field];
  174. end;
  175.  
  176. function TPXTable.FieldWidth(Field: Integer): Integer;
  177. var
  178.   Width, Code: Integer;
  179. begin
  180.   case FieldTypes^[Field][0] of
  181.     'N',
  182.     '$': FieldWidth := 14;
  183.     'A':
  184.       begin
  185.     Val(PChar(@FieldTypes^[Field][1]), Width, Code);
  186.     FieldWidth := Width
  187.       end;
  188.     'D': FieldWidth := 12;
  189.     'S': FieldWidth := 8;
  190.   else
  191.     FieldWidth := 0;
  192.   end;
  193. end;
  194.  
  195. function TPXTable.GetField(Rec, Fld: Integer): PChar;
  196. const
  197.   TheData: array[0..255] of Char = '';
  198. var
  199.   Tmp: array[0..255] of Char;
  200.   N: Double;
  201.   I: Integer;
  202.   L: LongInt;
  203.   ArgList: array[0..2] of Integer;
  204.   Index: LongInt;
  205.   P: PChar;
  206. begin
  207.   TheData[0] := #0;
  208.   GetField := TheData;
  209.   if Status <> 0 then Exit;
  210.   if (Rec < 1) or (Rec > NumRecords) then Exit;
  211.   if (Fld < 1) or (Fld > NumFields) then Exit;
  212.   Index := Rec * NumFields + Fld;
  213.   P := PCache(Cache)^.Get(Index);
  214.   if P = nil then
  215.   begin
  216.     if Rec <> CurRecord then
  217.     begin
  218.       CheckError(PXRecGoto(TblHandle, Rec));
  219.       CheckError(PXRecGet(TblHandle, RecHandle));
  220.       CurRecord := Rec;
  221.     end;
  222.     FillChar(TheData, SizeOf(TheData), ' ');
  223.     Tmp[0] := #0;
  224.     case FieldTypes^[Fld][0] of
  225.       'A':
  226.     CheckError(PXGetAlpha(RecHandle, Fld, SizeOf(Tmp), Tmp));
  227.       'N':
  228.     begin
  229.       CheckError(PXGetDoub(RecHandle, Fld, N));
  230.       if not IsBlankDouble(N) then
  231.         Str(N:12:4, Tmp);
  232.     end;
  233.       '$':
  234.     begin
  235.       CheckError(PXGetDoub(RecHandle, Fld, N));
  236.       if not IsBlankDouble(N) then
  237.         Str(N:12:2, Tmp);
  238.     end;
  239.       'S':
  240.     begin
  241.       CheckError(PXGetShort(RecHandle, Fld, I));
  242.       if not IsBlankShort(i) then
  243.         Str(I:6, Tmp)
  244.     end;
  245.       'D':
  246.     begin
  247.       CheckError(PXGetDate(RecHandle, Fld, L));
  248.       if Not IsBlankDate(L) then
  249.       begin
  250.         CheckError(PXDateDecode(L, ArgList[0], ArgList[1], ArgList[2]));
  251.         wvSprintf(Tmp, '%2d/%2d/%4d', ArgList);
  252.       end;
  253.     end;
  254.     end;
  255.     StrMove(TheData, Tmp, StrLen(Tmp));
  256.     TheData[FieldWidth(Fld)] := #0;
  257.     PCache(Cache)^.Add(Index, StrNew(TheData));
  258.   end
  259.   else
  260.     GetField := P;
  261. end;
  262.  
  263. function TPXTable.NumRecords: LongInt;
  264. begin
  265.   NumRecords := NumRecs;
  266. end;
  267.  
  268. function TPXTable.NumFields: Integer;
  269. begin
  270.   NumFields := NumFlds;
  271. end;
  272.  
  273. procedure TPXTable.PXError(Error: Integer);
  274. begin
  275.   MessageBox(GetFocus, PXErrMsg(Error), 'PXAccess', mb_OK)
  276. end;
  277.  
  278. end.
  279.