ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/fbintf/IBUtils.pas
(Generate patch)
# Line 49 | Line 49
49  
50   uses Classes, SysUtils, IB;
51  
52 + {$IF not defined(LineEnding)}
53 + const
54 +  {$IFDEF WINDOWS}
55 +  LineEnding = #$0D#$0A;
56 +  {$ELSE}
57 +  LineEnding = #$0A;
58 +  {$ENDIF}
59 + {$IFEND}
60 +
61   type
62    TSQLTokens = (
63  
# Line 301 | Line 310
310    TAB  = #9;
311    NULL_TERMINATOR = #0;
312  
304  {$IFNDEF FPC}
305  LineEnding = CRLF;
306  {$ENDIF}
307
313    {SQL Reserved words in alphabetical order}
314  
315    sqlReservedWords: array [TSQLReservedWords] of string = (
# Line 615 | Line 620
620          var slNames: TStrings): AnsiString;
621    end;
622  
623 +  TOnProgressEvent = procedure (Sender: TObject; Reset: boolean; value: integer) of object;
624 +
625 +  { TSQLXMLReader - used to save and read back blob and array data in a pseudo XML format}
626 +
627 +  TSQLXMLReader = class(TSQLTokeniser)
628 +  private
629 +      type
630 +        TXMLStates =  (stNoXML, stInTag,stInTagBody,
631 +                       stAttribute,stAttributeValue,stQuotedAttributeValue,
632 +                       stInEndTag, stInEndTagBody,
633 +                       stXMLData);
634 +
635 +        TXMLTag    =   (xtNone,xtBlob,xtArray,xtElt);
636 +
637 +        TXMLTagDef = record
638 +          XMLTag: TXMLTag;
639 +          TagValue: string;
640 +        end;
641 +
642 +      const
643 +        XMLTagDefs: array [xtBlob..xtElt] of TXMLTagDef = (
644 +          (XMLTag: xtBlob;   TagValue: 'blob'),
645 +          (XMLTag: xtArray;  TagValue: 'array'),
646 +          (XMLTag: xtElt;    TagValue: 'elt')
647 +          );
648 +        MaxXMLTags = 20;
649 +        BlobLineLength = 40;
650 +
651 +    public
652 +      const
653 +        ibx_blob = 'IBX_BLOB';
654 +        ibx_array = 'IBX_ARRAY';
655 +
656 +      type
657 +        TBlobData = record
658 +          BlobIntf: IBlob;
659 +          SubType: cardinal;
660 +        end;
661 +
662 +        TArrayData = record
663 +          ArrayIntf: IArray;
664 +          SQLType: cardinal;
665 +          relationName: string;
666 +          columnName: string;
667 +          dim: cardinal;
668 +          Size: cardinal;
669 +          Scale: integer;
670 +          CharSet: string;
671 +          bounds: TArrayBounds;
672 +          CurrentRow: integer;
673 +          Index: array of integer;
674 +        end;
675 +
676 +  private
677 +    FOnProgressEvent: TOnProgressEvent;
678 +    FXMLState: TXMLStates;
679 +    FXMLTagStack: array [1..MaxXMLTags] of TXMLTag;
680 +    FXMLTagIndex: integer;
681 +    FAttributeName: string;
682 +    FBlobData: array of TBlobData;
683 +    FCurrentBlob: integer;
684 +    FBlobBuffer: PByte;
685 +    FArrayData: array of TArrayData;
686 +    FCurrentArray: integer;
687 +    FXMLString: string;
688 +    function FindTag(tag: string; var xmlTag: TXMLTag): boolean;
689 +    function GetArrayData(index: integer): TArrayData;
690 +    function GetArrayDataCount: integer;
691 +    function GetBlobData(index: integer): TBlobData;
692 +    function GetBlobDataCount: integer;
693 +    function GetTagName(xmltag: TXMLTag): string;
694 +    procedure ProcessAttributeValue(attrValue: string);
695 +    procedure ProcessBoundsList(boundsList: string);
696 +    procedure ProcessTagValue(tagValue: string);
697 +    procedure XMLTagInit(xmltag: TXMLTag);
698 +    function XMLTagEnd(var xmltag: TXMLTag): boolean;
699 +    procedure XMLTagEnter;
700 +  protected
701 +    function GetAttachment: IAttachment; virtual; abstract;
702 +    function GetTransaction: ITransaction; virtual; abstract;
703 +    function GetErrorPrefix: string; virtual; abstract;
704 +    function TokenFound(var token: TSQLTokens): boolean; override;
705 +    procedure Reset; override;
706 +    procedure ShowError(msg: string; params: array of const); overload; virtual;
707 +    procedure ShowError(msg: string); overload;
708 +  public
709 +    constructor Create;
710 +    procedure FreeDataObjects;
711 +    class function FormatBlob(Field: ISQLData): string; overload;
712 +    class function FormatBlob(contents: string; subtype:integer): string; overload;
713 +    class function FormatArray(ar: IArray): string;
714 +    property BlobData[index: integer]: TBlobData read GetBlobData;
715 +    property BlobDataCount: integer read GetBlobDataCount;
716 +    property ArrayData[index: integer]: TArrayData read GetArrayData;
717 +    property ArrayDataCount: integer read GetArrayDataCount;
718 +    property Attachment: IAttachment read GetAttachment;
719 +    property Transaction: ITransaction read GetTransaction;
720 +    property OnProgressEvent: TOnProgressEvent read FOnProgressEvent write FOnProgressEvent; {Progress Bar Support}
721 + end;
722 +
723 + TJnlEntryType = (jeTransStart, jeTransCommit, jeTransCommitRet, jeTransRollback,
724 +                   jeTransRollbackRet, jeTransEnd, jeQuery,jeUnknown);
725 +
726 + TJnlEntry = record
727 +   JnlEntryType: TJnlEntryType;
728 +   Timestamp: TDateTime;
729 +   SessionID: integer;
730 +   TransactionID: integer;
731 +   OldTransactionID: integer;
732 +   TransactionName: AnsiString;
733 +   TPB: ITPB;
734 +   DefaultCompletion: TTransactionCompletion;
735 +   QueryText: AnsiString;
736 + end;
737 +
738 + TOnNextJournalEntry = procedure(JnlEntry: TJnlEntry) of object;
739 +
740 + { TJournalProcessor - used to parse a client side journal}
741 +
742 +   TJournalProcessor = class(TSQLTokeniser)
743 +    private
744 +      type TLineState = (lsInit, lsJnlFound, lsGotTimestamp, lsGotJnlType,  lsGotSessionID,
745 +                          lsGotTransactionID,  lsGotOldTransactionID, lsGotText1Length,
746 +                          lsGotText1, lsGotText2Length, lsGotText2);
747 +    private
748 +      FOnNextJournalEntry: TOnNextJournalEntry;
749 +      FInStream: TStream;
750 +      FFirebirdClientAPI: IFirebirdAPI;
751 +      procedure DoExecute;
752 +      function IdentifyJnlEntry(aTokenText: AnsiString): TJnlEntryType;
753 +    protected
754 +      function GetChar: AnsiChar; override;
755 +      property OnNextJournalEntry: TOnNextJournalEntry read FOnNextJournalEntry write FOnNextJournalEntry;
756 +    public
757 +      destructor Destroy; override;
758 +      class procedure Execute( aFileName: string; api: IFirebirdAPI; aOnNextJournalEntry: TOnNextJournalEntry);
759 +      class function JnlEntryText(je: TJnlEntryType): string;
760 +    end;
761 +
762  
763   function Max(n1, n2: Integer): Integer;
764   function Min(n1, n2: Integer): Integer;
# Line 651 | Line 795
795   function StripLeadingZeros(Value: AnsiString): AnsiString;
796   function TryStrToNumeric(S: Ansistring; out Value: int64; out scale: integer): boolean;
797   function NumericToDouble(aValue: Int64; aScale: integer): double;
798 + function StringToHex(octetString: string; MaxLineLength: integer=0): string; overload;
799 + procedure StringToHex(octetString: string; TextOut: TStrings; MaxLineLength: integer=0); overload;
800  
801  
802   implementation
# Line 665 | Line 811
811   {$IFEND}
812   {$ENDIF};
813  
814 + resourcestring
815 +  sXMLStackUnderflow = 'XML Stack Underflow';
816 +  sInvalidEndTag = 'XML End Tag Mismatch - %s';
817 +  sBadEndTagClosing = 'XML End Tag incorrectly closed';
818 +  sXMLStackOverFlow = 'XML Stack Overflow';
819 +  sXMLAttributeError = 'Unexpected attribute - "%s" = "%s"';
820 +  sInvalidBoundsList = 'Invalid array bounds list - "%s"';
821 +  sBinaryBlockMustbeEven = 'Binary block must have an even number of characters';
822 +  sArrayIndexError = 'Array Index Error (%d)';
823 +  sBlobIndexError = 'Blob Index Error (%d)';
824 +  sNoDatabase = 'Missing database for xml tag import';
825 +  sNoTransaction = 'Missing transaction for xml tag import';
826 +
827  
828   function Max(n1, n2: Integer): Integer;
829   begin
# Line 1458 | Line 1617
1617    Result := FLastChar;
1618    for i := 2 to NumOfChars do
1619    begin
1620 <    if GetNext = sqltEOF then break;
1620 >    if GetNext = sqltEOF then Exit;
1621      Result := Result + FLastChar;
1622    end;
1623 +  GetNext;
1624   end;
1625  
1626   function TSQLTokeniser.GetNextToken: TSQLTokens;
# Line 1929 | Line 2089
2089    Result := aValue * IntPower(10,aScale)
2090   end;
2091  
2092 +
2093 + function StringToHex(octetString: string; MaxLineLength: integer): string; overload;
2094 +
2095 +  function ToHex(aValue: byte): string;
2096 +  const
2097 +    HexChars: array [0..15] of char = '0123456789ABCDEF';
2098 +  begin
2099 +    Result := HexChars[aValue shr 4] +
2100 +               HexChars[(aValue and $0F)];
2101 +  end;
2102 +
2103 + var i, j: integer;
2104 + begin
2105 +  i := 1;
2106 +  Result := '';
2107 +  if MaxLineLength = 0 then
2108 +  while i <= Length(octetString) do
2109 +  begin
2110 +    Result := Result +  ToHex(byte(octetString[i]));
2111 +    Inc(i);
2112 +  end
2113 +  else
2114 +  while i <= Length(octetString) do
2115 +  begin
2116 +      for j := 1 to MaxLineLength do
2117 +      begin
2118 +        if i > Length(octetString) then
2119 +          Exit
2120 +        else
2121 +          Result := Result + ToHex(byte(octetString[i]));
2122 +        inc(i);
2123 +      end;
2124 +      Result := Result + LineEnding;
2125 +  end;
2126 + end;
2127 +
2128 + procedure StringToHex(octetString: string; TextOut: TStrings; MaxLineLength: integer); overload;
2129 + begin
2130 +    TextOut.Add(StringToHex(octetString,MaxLineLength));
2131 + end;
2132 +
2133 + { TSQLXMLReader }
2134 +
2135 + function TSQLXMLReader.FindTag(tag: string; var xmlTag: TXMLTag): boolean;
2136 + var i: TXMLTag;
2137 + begin
2138 +  Result := false;
2139 +  for i := xtBlob to xtElt do
2140 +    if XMLTagDefs[i].TagValue = tag then
2141 +    begin
2142 +      xmlTag := XMLTagDefs[i].XMLTag;
2143 +      Result := true;
2144 +      break;
2145 +    end;
2146 + end;
2147 +
2148 + function TSQLXMLReader.GetArrayData(index: integer): TArrayData;
2149 + begin
2150 +  if (index < 0) or (index > ArrayDataCount) then
2151 +    ShowError(sArrayIndexError,[index]);
2152 +  Result := FArrayData[index];
2153 + end;
2154 +
2155 + function TSQLXMLReader.GetArrayDataCount: integer;
2156 + begin
2157 +  Result := Length(FArrayData);
2158 + end;
2159 +
2160 + function TSQLXMLReader.GetBlobData(index: integer): TBlobData;
2161 + begin
2162 +  if (index < 0) or (index > BlobDataCount) then
2163 +    ShowError(sBlobIndexError,[index]);
2164 +  Result := FBlobData[index];
2165 + end;
2166 +
2167 + function TSQLXMLReader.GetBlobDataCount: integer;
2168 + begin
2169 +  Result := Length(FBlobData);
2170 + end;
2171 +
2172 + function TSQLXMLReader.GetTagName(xmltag: TXMLTag): string;
2173 + var i: TXMLTag;
2174 + begin
2175 +  Result := 'unknown';
2176 +  for i := xtBlob to xtElt do
2177 +    if XMLTagDefs[i].XMLTag = xmltag then
2178 +    begin
2179 +      Result := XMLTagDefs[i].TagValue;
2180 +      Exit;
2181 +    end;
2182 + end;
2183 +
2184 + procedure TSQLXMLReader.ProcessAttributeValue(attrValue: string);
2185 + begin
2186 +  case FXMLTagStack[FXMLTagIndex] of
2187 +  xtBlob:
2188 +    if FAttributeName = 'subtype' then
2189 +      FBlobData[FCurrentBlob].SubType := StrToInt(attrValue)
2190 +    else
2191 +      ShowError(sXMLAttributeError,[FAttributeName,attrValue]);
2192 +
2193 +  xtArray:
2194 +    if FAttributeName = 'sqltype' then
2195 +      FArrayData[FCurrentArray].SQLType := StrToInt(attrValue)
2196 +    else
2197 +    if FAttributeName = 'relation_name' then
2198 +      FArrayData[FCurrentArray].relationName := attrValue
2199 +    else
2200 +    if FAttributeName = 'column_name' then
2201 +      FArrayData[FCurrentArray].columnName := attrValue
2202 +    else
2203 +    if FAttributeName = 'dim' then
2204 +      FArrayData[FCurrentArray].Dim := StrToInt(attrValue)
2205 +    else
2206 +    if FAttributeName = 'length' then
2207 +      FArrayData[FCurrentArray].Size := StrToInt(attrValue)
2208 +    else
2209 +    if FAttributeName = 'scale' then
2210 +      FArrayData[FCurrentArray].Scale := StrToInt(attrValue)
2211 +    else
2212 +    if FAttributeName = 'charset' then
2213 +      FArrayData[FCurrentArray].CharSet := attrValue
2214 +    else
2215 +    if FAttributeName = 'bounds' then
2216 +      ProcessBoundsList(attrValue)
2217 +    else
2218 +      ShowError(sXMLAttributeError,[FAttributeName,attrValue]);
2219 +
2220 +  xtElt:
2221 +    if FAttributeName = 'ix' then
2222 +      with FArrayData[FCurrentArray] do
2223 +        Index[CurrentRow] :=  StrToInt(attrValue)
2224 +     else
2225 +        ShowError(sXMLAttributeError,[FAttributeName,attrValue]);
2226 +  end;
2227 + end;
2228 +
2229 + procedure TSQLXMLReader.ProcessBoundsList(boundsList: string);
2230 + var list: TStringList;
2231 +    i,j: integer;
2232 + begin
2233 +  list := TStringList.Create;
2234 +  try
2235 +    list.Delimiter := ',';
2236 +    list.DelimitedText := boundsList;
2237 +    with FArrayData[FCurrentArray] do
2238 +    begin
2239 +      if dim <> list.Count then
2240 +        ShowError(sInvalidBoundsList,[boundsList]);
2241 +      SetLength(bounds,dim);
2242 +      for i := 0 to list.Count - 1 do
2243 +      begin
2244 +        j := Pos(':',list[i]);
2245 +        if j = 0 then
2246 +          raise Exception.CreateFmt(sInvalidBoundsList,[boundsList]);
2247 +        bounds[i].LowerBound := StrToInt(system.copy(list[i],1,j-1));
2248 +        bounds[i].UpperBound := StrToInt(system.copy(list[i],j+1,length(list[i])-j));
2249 +      end;
2250 +    end;
2251 +  finally
2252 +    list.Free;
2253 +  end;
2254 + end;
2255 +
2256 + procedure TSQLXMLReader.ProcessTagValue(tagValue: string);
2257 +
2258 +  function nibble(hex: char): byte;
2259 +  begin
2260 +    case hex of
2261 +    '0': Result := 0;
2262 +    '1': Result := 1;
2263 +    '2': Result := 2;
2264 +    '3': Result := 3;
2265 +    '4': Result := 4;
2266 +    '5': Result := 5;
2267 +    '6': Result := 6;
2268 +    '7': Result := 7;
2269 +    '8': Result := 8;
2270 +    '9': Result := 9;
2271 +    'a','A': Result := 10;
2272 +    'b','B': Result := 11;
2273 +    'c','C': Result := 12;
2274 +    'd','D': Result := 13;
2275 +    'e','E': Result := 14;
2276 +    'f','F': Result := 15;
2277 +    end;
2278 +  end;
2279 +
2280 +  procedure RemoveWhiteSpace(var hexData: string);
2281 +  var i: integer;
2282 +  begin
2283 +    {Remove White Space}
2284 +    i := 1;
2285 +    while i <= length(hexData) do
2286 +    begin
2287 +      case hexData[i] of
2288 +      ' ',#9,#10,#13:
2289 +        begin
2290 +          if i < Length(hexData) then
2291 +            Move(hexData[i+1],hexData[i],Length(hexData)-i);
2292 +          SetLength(hexData,Length(hexData)-1);
2293 +        end;
2294 +      else
2295 +        Inc(i);
2296 +      end;
2297 +    end;
2298 +  end;
2299 +
2300 +  procedure WriteToBlob(hexData: string);
2301 +  var i,j : integer;
2302 +      blength: integer;
2303 +      P: PByte;
2304 +  begin
2305 +    RemoveWhiteSpace(hexData);
2306 +    if odd(length(hexData)) then
2307 +      ShowError(sBinaryBlockMustbeEven,[nil]);
2308 +    blength := Length(hexData) div 2;
2309 +    ReallocMem(FBlobBuffer,blength);
2310 +    j := 1;
2311 +    P := FBlobBuffer;
2312 +    for i := 1 to blength do
2313 +    begin
2314 +      P^ := (nibble(hexData[j]) shl 4) or nibble(hexdata[j+1]);
2315 +      Inc(j,2);
2316 +      Inc(P);
2317 +    end;
2318 +    FBlobData[FCurrentBlob].BlobIntf.Write(FBlobBuffer^,blength);
2319 +  end;
2320 +
2321 + begin
2322 +  if tagValue = '' then Exit;
2323 +  case FXMLTagStack[FXMLTagIndex] of
2324 +  xtBlob:
2325 +    WriteToBlob(tagValue);
2326 +
2327 +  xtElt:
2328 +    with FArrayData[FCurrentArray] do
2329 +      ArrayIntf.SetAsString(index,tagValue);
2330 +
2331 +  end;
2332 + end;
2333 +
2334 + procedure TSQLXMLReader.XMLTagInit(xmltag: TXMLTag);
2335 + begin
2336 +  if FXMLTagIndex > MaxXMLTags then
2337 +    ShowError(sXMLStackOverFlow,[nil]);
2338 +  Inc(FXMLTagIndex);
2339 +  FXMLTagStack[FXMLTagIndex] := xmltag;
2340 +  FXMLString := '';
2341 +
2342 +  case xmltag of
2343 +  xtBlob:
2344 +    begin
2345 +      Inc(FCurrentBlob);
2346 +      SetLength(FBlobData,FCurrentBlob+1);
2347 +      FBlobData[FCurrentBlob].BlobIntf := nil;
2348 +      FBlobData[FCurrentBlob].SubType := 0;
2349 +    end;
2350 +
2351 +  xtArray:
2352 +    begin
2353 +      Inc(FCurrentArray);
2354 +      SetLength(FArrayData,FCurrentArray+1);
2355 +      with FArrayData[FCurrentArray] do
2356 +      begin
2357 +        ArrayIntf := nil;
2358 +        SQLType := 0;
2359 +        dim := 0;
2360 +        Size := 0;
2361 +        Scale := 0;
2362 +        CharSet := 'NONE';
2363 +        SetLength(Index,0);
2364 +        CurrentRow := -1;
2365 +      end;
2366 +    end;
2367 +
2368 +  xtElt:
2369 +      with FArrayData[FCurrentArray] do
2370 +        Inc(CurrentRow)
2371 +  end;
2372 + end;
2373 +
2374 + function TSQLXMLReader.XMLTagEnd(var xmltag: TXMLTag): boolean;
2375 + begin
2376 +  if FXMLTagIndex = 0 then
2377 +    ShowError(sXMLStackUnderflow,[nil]);
2378 +
2379 +  xmlTag := FXMLTagStack[FXMLTagIndex];
2380 +  case FXMLTagStack[FXMLTagIndex] of
2381 +  xtBlob:
2382 +    FBlobData[FCurrentBlob].BlobIntf.Close;
2383 +
2384 +  xtArray:
2385 +    FArrayData[FCurrentArray].ArrayIntf.SaveChanges;
2386 +
2387 +  xtElt:
2388 +    Dec(FArrayData[FCurrentArray].CurrentRow);
2389 +  end;
2390 +  Dec(FXMLTagIndex);
2391 +  Result := FXMLTagIndex = 0;
2392 + end;
2393 +
2394 + procedure TSQLXMLReader.XMLTagEnter;
2395 + var aCharSetID: integer;
2396 + begin
2397 +  if (Attachment = nil) or not Attachment.IsConnected then
2398 +    ShowError(sNoDatabase);
2399 +  if Transaction = nil then
2400 +    ShowError(sNoTransaction);
2401 +  case FXMLTagStack[FXMLTagIndex] of
2402 +  xtBlob:
2403 +    begin
2404 +      if not Transaction.InTransaction then
2405 +        Transaction.Start;
2406 +      FBlobData[FCurrentBlob].BlobIntf := Attachment.CreateBlob(
2407 +        Transaction,FBlobData[FCurrentBlob].SubType);
2408 +    end;
2409 +
2410 +  xtArray:
2411 +    with FArrayData[FCurrentArray] do
2412 +    begin
2413 +      if not Transaction.InTransaction then
2414 +        Transaction.Start;
2415 +      Attachment.CharSetName2CharSetID(CharSet,aCharSetID);
2416 +      SetLength(Index,dim);
2417 +      ArrayIntf := Attachment.CreateArray(
2418 +                     Transaction,
2419 +                     Attachment.CreateArrayMetaData(SQLType,
2420 +                       relationName,columnName,Scale,Size,
2421 +                       aCharSetID,dim,bounds)
2422 +                     );
2423 +    end;
2424 +  end;
2425 + end;
2426 +
2427 + {This is where the XML tags are identified and the token stream modified in
2428 + consequence}
2429 +
2430 + function TSQLXMLReader.TokenFound(var token: TSQLTokens): boolean;
2431 +
2432 + procedure NotAnXMLTag;
2433 + begin
2434 +   begin
2435 +     if FXMLTagIndex = 0 then
2436 +     {nothing to do with XML so go back to processing SQL}
2437 +     begin
2438 +       QueueToken(token);
2439 +       ReleaseQueue(token);
2440 +       FXMLState := stNoXML
2441 +     end
2442 +     else
2443 +     begin
2444 +       {Not an XML tag, so just push back to XML Data}
2445 +       FXMLState := stXMLData;
2446 +       FXMLString := FXMLString + GetQueuedText;
2447 +       ResetQueue;
2448 +     end;
2449 +   end;
2450 + end;
2451 +
2452 + var XMLTag: TXMLTag;
2453 + begin
2454 +  Result := inherited TokenFound(token);
2455 +  if not Result then Exit;
2456 +
2457 +  case FXMLState of
2458 +  stNoXML:
2459 +    if token = sqltLT then
2460 +    begin
2461 +      ResetQueue;
2462 +      QueueToken(token); {save in case this is not XML}
2463 +      FXMLState := stInTag;
2464 +    end;
2465 +
2466 +  stInTag:
2467 +    {Opening '<' found, now looking for tag name or end tag marker}
2468 +    case token of
2469 +    sqltIdentifier:
2470 +      begin
2471 +        if FindTag(TokenText,XMLTag) then
2472 +        begin
2473 +          XMLTagInit(XMLTag);
2474 +          QueueToken(token);
2475 +          FXMLState := stInTagBody;
2476 +        end
2477 +        else
2478 +          NotAnXMLTag;
2479 +      end;
2480 +
2481 +    sqltForwardSlash:
2482 +      FXMLState := stInEndTag;
2483 +
2484 +    else
2485 +      NotAnXMLTag;
2486 +    end {case token};
2487 +
2488 +  stInTagBody:
2489 +    {Tag name found. Now looking for attribute or closing '>'}
2490 +    case token of
2491 +    sqltIdentifier:
2492 +      begin
2493 +        FAttributeName := TokenText;
2494 +        QueueToken(token);
2495 +        FXMLState := stAttribute;
2496 +      end;
2497 +
2498 +    sqltGT:
2499 +      begin
2500 +        ResetQueue;
2501 +        XMLTagEnter;
2502 +        FXMLState := stXMLData;
2503 +      end;
2504 +
2505 +    sqltSpace,
2506 +    sqltEOL:
2507 +      QueueToken(token);
2508 +
2509 +    else
2510 +      NotAnXMLTag;
2511 +    end {case token};
2512 +
2513 +  stAttribute:
2514 +    {Attribute name found. Must be followed by an '=', a '>' or another tag name}
2515 +    case token of
2516 +      sqltEquals:
2517 +      begin
2518 +        QueueToken(token);
2519 +        FXMLState := stAttributeValue;
2520 +      end;
2521 +
2522 +      sqltSpace,
2523 +      sqltEOL:
2524 +        QueueToken(token);
2525 +
2526 +      sqltIdentifier:
2527 +        begin
2528 +          ProcessAttributeValue('');
2529 +          FAttributeName := TokenText;
2530 +          QueueToken(token);
2531 +          FXMLState := stAttribute;
2532 +        end;
2533 +
2534 +      sqltGT:
2535 +        begin
2536 +          ProcessAttributeValue('');
2537 +          ResetQueue;
2538 +          XMLTagEnter;
2539 +          FXMLState := stXMLData;
2540 +        end;
2541 +
2542 +      else
2543 +        NotAnXMLTag;
2544 +    end; {case token}
2545 +
2546 +  stAttributeValue:
2547 +    {Looking for attribute value as a single identifier or a double quoted value}
2548 +    case token of
2549 +    sqltIdentifier,sqltIdentifierInDoubleQuotes:
2550 +      begin
2551 +        ProcessAttributeValue(TokenText);
2552 +        QueueToken(token);
2553 +        FXMLState := stInTagBody;
2554 +      end;
2555 +
2556 +    sqltSpace,
2557 +    sqltEOL:
2558 +      QueueToken(token);
2559 +
2560 +    else
2561 +      NotAnXMLTag;
2562 +    end; {case token}
2563 +
2564 +  stXMLData:
2565 +    if token = sqltLT then
2566 +    begin
2567 +      QueueToken(token); {save in case this is not XML}
2568 +      FXMLState := stInTag;
2569 +    end
2570 +    else
2571 +      FXMLString := FXMLString + TokenText;
2572 +
2573 +  stInEndTag:
2574 +    {Opening '</' found, now looking for tag name}
2575 +    case token of
2576 +    sqltIdentifier:
2577 +      begin
2578 +        if FindTag(TokenText,XMLTag) and (XMLTag = FXMLTagStack[FXMLTagIndex]) then
2579 +        begin
2580 +          QueueToken(token);
2581 +          FXMLState := stInEndTagBody;
2582 +        end
2583 +        else
2584 +          ShowError(sInvalidEndTag,[TokenText]);
2585 +      end;
2586 +    else
2587 +      NotAnXMLTag;
2588 +    end {case token};
2589 +
2590 +  stInEndTagBody:
2591 +  {End tag name found, now looping for closing '>'}
2592 +    case Token of
2593 +    sqltGT:
2594 +      begin
2595 +        ProcessTagValue(FXMLString);
2596 +        if XMLTagEnd(XMLTag) then
2597 +        begin
2598 +          ResetQueue;
2599 +          QueueToken(sqltColon,':');
2600 +          case XMLTag of
2601 +            xtBlob:
2602 +              QueueToken(sqltIdentifier,Format(ibx_blob+'%d',[FCurrentBlob]));
2603 +
2604 +            xtArray:
2605 +              QueueToken(sqltIdentifier, Format(ibx_array+'%d',[FCurrentArray]));
2606 +          end;
2607 +          ReleaseQueue(token);
2608 +          FXMLState := stNoXML;
2609 +       end
2610 +       else
2611 +         FXMLState := stXMLData;
2612 +      end;
2613 +
2614 +    sqltSpace,
2615 +    sqltEOL:
2616 +      QueueToken(token);
2617 +
2618 +    else
2619 +      ShowError(sBadEndTagClosing);
2620 +    end; {case token}
2621 +
2622 +  end {Case FState};
2623 +
2624 +  {Only allow token to be returned if not processing an XML tag}
2625 +
2626 +  Result := FXMLState = stNoXML;
2627 + end;
2628 +
2629 + procedure TSQLXMLReader.ShowError(msg: string; params: array of const);
2630 + begin
2631 +  raise EIBClientError.CreateFmt(GetErrorPrefix + msg,params);
2632 + end;
2633 +
2634 + procedure TSQLXMLReader.ShowError(msg: string);
2635 + begin
2636 +  ShowError(msg,[nil]);
2637 + end;
2638 +
2639 + constructor TSQLXMLReader.Create;
2640 + begin
2641 +  inherited;
2642 +  FXMLState := stNoXML;
2643 + end;
2644 +
2645 + procedure TSQLXMLReader.FreeDataObjects;
2646 + begin
2647 +  FXMLTagIndex := 0;
2648 +  SetLength(FBlobData,0);
2649 +  FCurrentBlob := -1;
2650 +  SetLength(FArrayData,0);
2651 +  FCurrentArray := -1;
2652 + end;
2653 +
2654 + class function TSQLXMLReader.FormatBlob(Field: ISQLData): string;
2655 + begin
2656 +  Result := FormatBlob(Field.AsString,Field.getSubtype);
2657 + end;
2658 +
2659 + class function TSQLXMLReader.FormatBlob(contents: string; subtype: integer
2660 +  ): string;
2661 + var TextOut: TStrings;
2662 + begin
2663 +  TextOut := TStringList.Create;
2664 +  try
2665 +    TextOut.Add(Format('<blob subtype="%d">',[subtype]));
2666 +    StringToHex(contents,TextOut,BlobLineLength);
2667 +    TextOut.Add('</blob>');
2668 +    Result := TextOut.Text;
2669 +  finally
2670 +    TextOut.Free;
2671 +  end;
2672 + end;
2673 +
2674 +
2675 + class function TSQLXMLReader.FormatArray(ar: IArray
2676 +  ): string;
2677 + var index: array of integer;
2678 +    TextOut: TStrings;
2679 +
2680 +    procedure AddElements(dim: integer; indent:string = ' ');
2681 +    var i: integer;
2682 +        recurse: boolean;
2683 +    begin
2684 +      SetLength(index,dim+1);
2685 +      recurse := dim < ar.GetDimensions - 1;
2686 +      with ar.GetBounds[dim] do
2687 +      for i := LowerBound to UpperBound do
2688 +      begin
2689 +        index[dim] := i;
2690 +        if recurse then
2691 +        begin
2692 +          TextOut.Add(Format('%s<elt id="%d">',[indent,i]));
2693 +          AddElements(dim+1,indent + ' ');
2694 +          TextOut.Add('</elt>');
2695 +        end
2696 +        else
2697 +        if ((ar.GetSQLType = SQL_TEXT) or (ar.GetSQLType = SQL_VARYING)) and
2698 +           (ar.GetCharSetID = 1) then
2699 +           TextOut.Add(Format('%s<elt ix="%d">%s</elt>',[indent,i,StringToHex(ar.GetAsString(index))]))
2700 +        else
2701 +          TextOut.Add(Format('%s<elt ix="%d">%s</elt>',[indent,i,ar.GetAsString(index)]));
2702 +      end;
2703 +    end;
2704 +
2705 + var
2706 +    s: string;
2707 +    bounds: TArrayBounds;
2708 +    i: integer;
2709 +    boundsList: string;
2710 + begin
2711 +  TextOut := TStringList.Create;
2712 +  try
2713 +    if ar.GetCharSetWidth = 0 then
2714 +      s := Format('<array dim = "%d" sqltype = "%d" length = "%d" relation_name = "%s" column_name = "%s"',
2715 +                              [ar.GetDimensions,ar.GetSQLType,ar.GetSize,
2716 +                               ar.GetTableName,ar.GetColumnName])
2717 +    else
2718 +      s := Format('<array dim = "%d" sqltype = "%d" length = "%d" relation_name = "%s" column_name = "%s"',
2719 +                                [ar.GetDimensions,ar.GetSQLType,ar.GetSize div ar.GetCharSetWidth,
2720 +                                 ar.GetTableName,ar.GetColumnName]);
2721 +    case ar.GetSQLType of
2722 +    SQL_DOUBLE, SQL_FLOAT, SQL_LONG, SQL_SHORT, SQL_D_FLOAT, SQL_INT64:
2723 +       s := s + Format(' scale = "%d"',[ ar.GetScale]);
2724 +    SQL_TEXT,
2725 +    SQL_VARYING:
2726 +      s := s + Format(' charset = "%s"',[ar.GetAttachment.GetCharsetName(ar.GetCharSetID)]);
2727 +    end;
2728 +    bounds := ar.GetBounds;
2729 +    boundsList := '';
2730 +    for i := 0 to length(bounds) - 1 do
2731 +    begin
2732 +      if i <> 0 then boundsList := boundsList + ',';
2733 +      boundsList := boundsList + Format('%d:%d',[bounds[i].LowerBound,bounds[i].UpperBound]);
2734 +    end;
2735 +    s := s + Format(' bounds="%s"',[boundsList]);
2736 +    s := s + '>';
2737 +    TextOut.Add(s);
2738 +
2739 +    SetLength(index,0);
2740 +    AddElements(0);
2741 +    TextOut.Add('</array>');
2742 +    Result := TextOut.Text;
2743 +  finally
2744 +    TextOut.Free;
2745 +  end;
2746 + end;
2747 +
2748 + procedure TSQLXMLReader.Reset;
2749 + begin
2750 +  inherited Reset;
2751 +  FreeDataObjects;
2752 +  FXMLString := '';
2753 +  FreeMem(FBlobBuffer);
2754 + end;
2755 +
2756 + { TJournalProcessor }
2757 +
2758 + procedure TJournalProcessor.DoExecute;
2759 + var token: TSQLTokens;
2760 +    LineState: TLineState;
2761 +    JnlEntry: TJnlEntry;
2762 +    Len: integer;
2763 +    tz: AnsiString;
2764 +
2765 +  procedure ClearJnlEntry;
2766 +  begin
2767 +    with JnlEntry do
2768 +    begin
2769 +      TransactionName := '';
2770 +      TPB := nil;
2771 +      QueryText :='';
2772 +      JnlEntryType := jeUnknown;
2773 +      SessionID := 0;
2774 +      TransactionID := 0;
2775 +      DefaultCompletion := taCommit;
2776 +    end;
2777 +  end;
2778 +
2779 +  function CreateTPB(TPBText: AnsiString): ITPB;
2780 +  var index: integer;
2781 +  begin
2782 +    Result := nil;
2783 +    if Length(TPBText) = 0 then
2784 +      Exit;
2785 +    Result := FFirebirdClientAPI.AllocateTPB;
2786 +    try
2787 +      index := Pos('[',TPBText);
2788 +      if index > 0 then
2789 +        system.Delete(TPBText,1,index);
2790 +      repeat
2791 +        index := Pos(',',TPBText);
2792 +        if index = 0 then
2793 +        begin
2794 +          index := Pos(']',TPBText);
2795 +          if index <> 0 then
2796 +            system.Delete(TPBText,index,1);
2797 +          Result.AddByTypeName(TPBText);
2798 +          break;
2799 +        end;
2800 +        Result.AddByTypeName(system.copy(TPBText,1,index-1));
2801 +        system.Delete(TPBText,1,index);
2802 +      until false;
2803 +    except
2804 +      Result := nil;
2805 +      raise;
2806 +    end;
2807 +  end;
2808 +
2809 + begin
2810 +  LineState := lsInit;
2811 +  JnlEntry.JnlEntryType := jeUnknown;
2812 +  while not EOF do
2813 +  begin
2814 +    if LineState = lsInit then
2815 +      ClearJnlEntry;
2816 +    token := GetNextToken;
2817 +    with JnlEntry do
2818 +    case token of
2819 +    sqltAsterisk:
2820 +      if LineState = lsInit then
2821 +        LineState := lsJnlFound;
2822 +
2823 +    sqltIdentifier:
2824 +      if LineState = lsJnlFound then
2825 +        begin
2826 +          JnlEntryType := IdentifyJnlEntry(TokenText);
2827 +          LineState := lsGotJnlType;
2828 +        end
2829 +      else
2830 +        LineState := lsInit;
2831 +
2832 +    sqltQuotedString:
2833 +      if (LineState = lsGotJnlType)
2834 +          and ParseDateTimeTZString(TokenText,TimeStamp,tz) then
2835 +            LineState := lsGotTimestamp
2836 +      else
2837 +        LineState := lsInit;
2838 +
2839 +    sqltColon:
2840 +      case LineState of
2841 +      lsGotText1Length:
2842 +        begin
2843 +          if Len > 0 then
2844 +          begin
2845 +            if JnlEntryType = jeTransStart then
2846 +              TransactionName := ReadCharacters(Len)
2847 +            else
2848 +              QueryText := ReadCharacters(Len)
2849 +          end;
2850 +          if JnlEntryType = jeTransStart then
2851 +             LineState := lsGotText1
2852 +          else
2853 +          begin
2854 +            if assigned(FOnNextJournalEntry) then
2855 +              OnNextJournalEntry(JnlEntry);
2856 +            LineState := lsInit;
2857 +          end
2858 +        end;
2859 +
2860 +      lsGotText2Length:
2861 +        begin
2862 +          if Len > 0 then
2863 +            TPB :=  CreateTPB(ReadCharacters(Len));
2864 +          LineState := lsGotText2;
2865 +        end;
2866 +
2867 +      else
2868 +      if LineState <> lsGotJnlType then
2869 +        LineState := lsInit;
2870 +    end;
2871 +
2872 +   sqltComma:
2873 +     if not (LineState in [lsGotTimestamp,lsGotSessionID,lsGotTransactionID,lsGotText1,lsGotText2]) then
2874 +       LineState := lsInit;
2875 +
2876 +   sqltNumberString:
2877 +     case LineState of
2878 +     lsGotTimestamp:
2879 +       begin
2880 +         SessionID := StrToInt(TokenText);
2881 +         LineState := lsGotSessionID;
2882 +       end;
2883 +
2884 +     lsGotSessionID:
2885 +       begin
2886 +         TransactionID := StrToInt(TokenText);
2887 +         if JnlEntryType in [jeTransCommit, jeTransRollback] then
2888 +         begin
2889 +           if assigned(FOnNextJournalEntry) then
2890 +             OnNextJournalEntry(JnlEntry);
2891 +           LineState := lsInit;
2892 +         end
2893 +         else
2894 +           LineState := lsGotTransactionID;
2895 +       end;
2896 +
2897 +     lsGotTransactionID:
2898 +       begin
2899 +         case JnlEntryType of
2900 +         jeTransStart:
2901 +           begin
2902 +             len := StrToInt(TokenText);
2903 +             LineState := lsGotText1Length;
2904 +           end;
2905 +
2906 +         jeQuery:
2907 +           begin
2908 +             len :=  StrToInt(TokenText);
2909 +             LineState := lsGotText1Length;
2910 +           end;
2911 +
2912 +         jeTransCommitRet,
2913 +         jeTransRollbackRet:
2914 +           begin
2915 +             OldTransactionID := StrToInt(TokenText);
2916 +             if assigned(FOnNextJournalEntry) then
2917 +               OnNextJournalEntry(JnlEntry);
2918 +             LineState := lsInit;
2919 +           end;
2920 +
2921 +           else
2922 +             LineState := lsInit;
2923 +         end; {case JnlEntryType}
2924 +
2925 +       end;
2926 +
2927 +     lsGotText1:
2928 +       begin
2929 +         len := StrToInt(TokenText);
2930 +         LineState := lsGotText2Length;
2931 +       end;
2932 +
2933 +     lsGotText2:
2934 +        begin
2935 +          if JnlEntryType = jeTransStart then
2936 +          begin
2937 +            DefaultCompletion := TTransactionCompletion(StrToInt(TokenText));
2938 +            if assigned(FOnNextJournalEntry) then
2939 +              OnNextJournalEntry(JnlEntry);
2940 +          end;
2941 +          LineState := lsInit;
2942 +        end;
2943 +     end; {case LineState}
2944 +    end; {case token}
2945 +  end; {while}
2946 +  ClearJnlEntry;
2947 + end;
2948 +
2949 + function TJournalProcessor.IdentifyJnlEntry(aTokenText: AnsiString
2950 +  ): TJnlEntryType;
2951 + begin
2952 +  Result := jeUnknown;
2953 +  if Length(aTokenText) > 0 then
2954 +  case aTokenText[1] of
2955 +  'S':
2956 +    Result := jeTransStart;
2957 +  'C':
2958 +    Result := jeTransCommit;
2959 +  'c':
2960 +    Result := jeTransCommitRet;
2961 +  'R':
2962 +    Result := jeTransRollback;
2963 +  'r':
2964 +    Result := jeTransRollbackRet;
2965 +  'E':
2966 +    Result := jeTransEnd;
2967 +  'Q':
2968 +    Result := jeQuery;
2969 +  end;
2970 + end;
2971 +
2972 + class function TJournalProcessor.JnlEntryText(je: TJnlEntryType): string;
2973 + begin
2974 +  case je of
2975 +  jeTransStart:
2976 +    Result := 'Transaction Start';
2977 +  jeTransCommit:
2978 +    Result := 'Commit';
2979 +  jeTransCommitRet:
2980 +    Result := 'Commit Retaining';
2981 +  jeTransRollback:
2982 +    Result := 'Rollback';
2983 +  jeTransRollbackRet:
2984 +    Result := 'Rollback Retaining';
2985 +  jeTransEnd:
2986 +    Result := 'Transaction End';
2987 +  jeQuery:
2988 +    Result := 'Query';
2989 +  jeUnknown:
2990 +    Result := 'Unknown';
2991 +  end;
2992 + end;
2993 +
2994 + function TJournalProcessor.GetChar: AnsiChar;
2995 + begin
2996 +  if FInStream.Read(Result,1) = 0 then
2997 +    Result := #0;
2998 + end;
2999 +
3000 + destructor TJournalProcessor.Destroy;
3001 + begin
3002 +  FInStream.Free;
3003 +  inherited Destroy;
3004 + end;
3005 +
3006 + class procedure TJournalProcessor.Execute(aFileName: string; api: IFirebirdAPI;
3007 +  aOnNextJournalEntry: TOnNextJournalEntry);
3008 + begin
3009 +  with TJournalProcessor.Create do
3010 +  try
3011 +    FInStream := TFileStream.Create(aFileName,fmOpenRead);
3012 +    FFirebirdClientAPI := api;
3013 +    OnNextJournalEntry := aOnNextJournalEntry;
3014 +    DoExecute;
3015 +  finally
3016 +    Free
3017 +  end;
3018 + end;
3019 +
3020 +
3021   end.

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines