Download as
Browse Code »

Commit d5ad630e7c4e2587c496d3e48198168986807c28

Authored by anderson.peterle@previdencia.gov.br
1 parent 3c1e6d68
Exists in master

Exclusão para posterior reposição com versão 2.6-Beta-2 

git-svn-id: http://svn.softwarepublico.gov.br/svn/cacic/cacic/trunk/agente-windows@958 fecfc0c7-e812-0410-ae72-849f08638ee7
Showing 6 changed files with 0 additions and 3823 deletions   Show diff stats
chksis/LibXmlParser.pas
View file @3c1e6d6
... ... @@ -1,2728 +0,0 @@
1   -(**
2   -===============================================================================================
3   -Name : LibXmlParser
4   -===============================================================================================
5   -Project : All Projects
6   -===============================================================================================
7   -Subject : Progressive XML Parser for all types of XML Files
8   -===============================================================================================
9   -Author : Stefan Heymann
10   - Eschenweg 3
11   - 72076 Tübingen
12   - GERMANY
13   -
14   -E-Mail: stefan@destructor.de
15   -URL: www.destructor.de
16   -===============================================================================================
17   -Source, Legals ("Licence")
18   ---------------------------
19   -The official site to get this parser is http://www.destructor.de/
20   -
21   -Usage and Distribution of this Source Code is ruled by the
22   -"Destructor.de Source code Licence" (DSL) which comes with this file or
23   -can be downloaded at http://www.destructor.de/
24   -
25   -IN SHORT: Usage and distribution of this source code is free.
26   - You use it completely on your own risk.
27   -
28   -Postcardware
29   -------------
30   -If you like this code, please send a postcard of your city to my above address.
31   -===============================================================================================
32   -!!! All parts of this code which are not finished or not conforming exactly to
33   - the XmlSpec are marked with three exclamation marks
34   -
35   --!- Parts where the parser may be able to detect errors in the document's syntax are
36   - marked with the dash-exlamation mark-dash sequence.
37   -===============================================================================================
38   -Terminology:
39   -------------
40   -- Start: Start of a buffer part
41   -- Final: End (last character) of a buffer part
42   -- DTD: Document Type Definition
43   -- DTDc: Document Type Declaration
44   -- XMLSpec: The current W3C XML Recommendation (version 1.0 as of 1998-02-10), Chapter No.
45   -- Cur*: Fields concerning the "Current" part passed back by the "Scan" method
46   -===============================================================================================
47   -Scanning the XML document
48   --------------------------
49   -- Create TXmlParser Instance MyXml := TXmlParser.Create;
50   -- Load XML Document MyXml.LoadFromFile (Filename);
51   -- Start Scanning MyXml.StartScan;
52   -- Scan Loop WHILE MyXml.Scan DO
53   -- Test for Part Type CASE MyXml.CurPartType OF
54   -- Handle Parts ... : ;;;
55   -- Handle Parts ... : ;;;
56   -- Handle Parts ... : ;;;
57   - END;
58   -- Destroy MyXml.Free;
59   -===============================================================================================
60   -Loading the XML document
61   -------------------------
62   -You can load the XML document from a file with the "LoadFromFile" method.
63   -It is beyond the scope of this parser to perform HTTP or FTP accesses. If you want your
64   -application to handle such requests (URLs), you can load the XML via HTTP or FTP or whatever
65   -protocol and hand over the data buffer using the "LoadFromBuffer" or "SetBuffer" method.
66   -"LoadFromBuffer" loads the internal buffer of TXmlParser with the given null-terminated
67   -string, thereby creating a copy of that buffer.
68   -"SetBuffer" just takes the pointer to another buffer, which means that the given
69   -buffer pointer must be valid while the document is accessed via TXmlParser.
70   -===============================================================================================
71   -Encodings:
72   -----------
73   -This XML parser kind of "understands" the following encodings:
74   -- UTF-8
75   -- ISO-8859-1
76   -- Windows-1252
77   -
78   -Any flavor of multi-byte characters (and this includes UTF-16) is not supported. Sorry.
79   -
80   -Every string which has to be passed to the application passes the virtual method
81   -"TranslateEncoding" which translates the string from the current encoding (stored in
82   -"CurEncoding") into the encoding the application wishes to receive.
83   -The "TranslateEncoding" method that is built into TXmlParser assumes that the application
84   -wants to receive Windows ANSI (Windows-1252, about the same as ISO-8859-1) and is able
85   -to convert UTF-8 and ISO-8859-1 encodings.
86   -For other source and target encodings, you will have to override "TranslateEncoding".
87   -===============================================================================================
88   -Buffer Handling
89   ----------------
90   -- The document must be loaded completely into a piece of RAM
91   -- All character positions are referenced by PChar pointers
92   -- The TXmlParser instance can either "own" the buffer itself (then, FBufferSize is > 0)
93   - or reference the buffer of another instance or object (then, FBuffersize is 0 and
94   - FBuffer is not NIL)
95   -- The Property DocBuffer passes back a pointer to the first byte of the document. If there
96   - is no document stored (FBuffer is NIL), the DocBuffer returns a pointer to a NULL character.
97   -===============================================================================================
98   -Whitespace Handling
99   --------------------
100   -The TXmlParser property "PackSpaces" determines how Whitespace is returned in Text Content:
101   -While PackSpaces is true, all leading and trailing whitespace characters are trimmed of, all
102   -Whitespace is converted to Space #x20 characters and contiguous Whitespace characters are
103   -compressed to one.
104   -If the "Scan" method reports a ptContent part, the application can get the original text
105   -with all whitespace characters by extracting the characters from "CurStart" to "CurFinal".
106   -If the application detects an xml:space attribute, it can set "PackSpaces" accordingly or
107   -use CurStart/CurFinal.
108   -Please note that TXmlParser does _not_ normalize Line Breaks to single LineFeed characters
109   -as the XmlSpec requires (XmlSpec 2.11).
110   -The xml:space attribute is not handled by TXmlParser. This is on behalf of the application.
111   -===============================================================================================
112   -Non-XML-Conforming
113   -------------------
114   -TXmlParser does not conform 100 % exactly to the XmlSpec:
115   -- UTF-16 is not supported (XmlSpec 2.2)
116   - (Workaround: Convert UTF-16 to UTF-8 and hand the buffer over to TXmlParser)
117   -- As the parser only works with single byte strings, all Unicode characters > 255
118   - can currently not be handled correctly.
119   -- Line breaks are not normalized to single Linefeed #x0A characters (XmlSpec 2.11)
120   - (Workaround: The Application can access the text contents on its own [CurStart, CurFinal],
121   - thereby applying every normalization it wishes to)
122   -- The attribute value normalization does not work exactly as defined in the
123   - Second Edition of the XML 1.0 specification.
124   -- See also the code parts marked with three consecutive exclamation marks. These are
125   - parts which are not finished in the current code release.
126   -
127   -This list may be incomplete, so it may grow if I get to know any other points.
128   -As work on the parser proceeds, this list may also shrink.
129   -===============================================================================================
130   -Things Todo
131   ------------
132   -- Introduce a new event/callback which is called when there is an unresolvable
133   - entity or character reference
134   -- Support Unicode
135   -- Use Streams instead of reading the whole XML into memory
136   -===============================================================================================
137   -Change History, Version numbers
138   --------------------------------
139   -The Date is given in ISO Year-Month-Day (YYYY-MM-DD) order.
140   -Versions are counted from 1.0.0 beginning with the version from 2000-03-16.
141   -Unreleased versions don't get a version number.
142   -
143   -Date Author Version Changes
144   ------------------------------------------------------------------------------------------------
145   -2000-03-16 HeySt 1.0.0 Start
146   -2000-03-28 HeySt 1.0.1 Initial Publishing of TXmlParser on the destructor.de Web Site
147   -2000-03-30 HeySt 1.0.2 TXmlParser.AnalyzeCData: Call "TranslateEncoding" for CurContent
148   -2000-03-31 HeySt 1.0.3 Deleted the StrPosE function (was not needed anyway)
149   -2000-04-04 HeySt 1.0.4 TDtdElementRec modified: Start/Final for all Elements;
150   - Should be backwards compatible.
151   - AnalyzeDtdc: Set CurPartType to ptDtdc
152   -2000-04-23 HeySt 1.0.5 New class TObjectList. Eliminated reference to the Delphi 5
153   - "Contnrs" unit so LibXmlParser is Delphi 4 compatible.
154   -2000-07-03 HeySt 1.0.6 TNvpNode: Added Constructor
155   -2000-07-11 HeySt 1.0.7 Removed "Windows" from USES clause
156   - Added three-exclamation-mark comments for Utf8ToAnsi/AnsiToUtf8
157   - Added three-exclamation-mark comments for CHR function calls
158   -2000-07-23 HeySt 1.0.8 TXmlParser.Clear: CurAttr.Clear; EntityStack.Clear;
159   - (This was not a bug; just defensive programming)
160   -2000-07-29 HeySt 1.0.9 TNvpList: Added methods: Node(Index), Value(Index), Name(Index);
161   -2000-10-07 HeySt Introduced Conditional Defines
162   - Uses Contnrs unit and its TObjectList class again for
163   - Delphi 5 and newer versions
164   -2001-01-30 HeySt Introduced Version Numbering
165   - Made LoadFromFile and LoadFromBuffer BOOLEAN functions
166   - Introduced FileMode parameter for LoadFromFile
167   - BugFix: TAttrList.Analyze: Must add CWhitespace to ExtractName call
168   - Comments worked over
169   -2001-02-28 HeySt 1.0.10 Completely worked over and tested the UTF-8 functions
170   - Fixed a bug in TXmlParser.Scan which caused it to start over when it
171   - was called after the end of scanning, resulting in an endless loop
172   - TEntityStack is now a TObjectList instead of TList
173   -2001-07-03 HeySt 1.0.11 Updated Compiler Version IFDEFs for Kylix
174   -2001-07-11 HeySt 1.0.12 New TCustomXmlScanner component (taken over from LibXmlComps.pas)
175   -2001-07-14 HeySt 1.0.13 Bugfix TCustomXmlScanner.FOnTranslateEncoding
176   -2001-10-22 HeySt Don't clear CurName anymore when the parser finds a CDATA section.
177   -2001-12-03 HeySt 1.0.14 TObjectList.Clear: Make call to INHERITED method (fixes a memory leak)
178   -2001-12-05 HeySt 1.0.15 TObjectList.Clear: removed call to INHERITED method
179   - TObjectList.Destroy: Inserted SetCapacity call.
180   - Reduces need for frequent re-allocation of pointer buffer
181   - Dedicated to my father, Theodor Heymann
182   -2002-06-26 HeySt 1.0.16 TXmlParser.Scan: Fixed a bug with PIs whose name is beginning
183   - with 'xml'. Thanks to Uwe Kamm for submitting this bug.
184   - The CurEncoding property is now always in uppercase letters (the XML
185   - spec wants it to be treated case independently so when it's uppercase
186   - comparisons are faster)
187   -2002-03-04 HeySt 1.0.17 Included an IFDEF for Delphi 7 (VER150) and Kylix
188   - There is a new symbol HAS_CONTNRS_UNIT which is used now to
189   - distinguish between IDEs which come with the Contnrs unit and
190   - those that don't.
191   -*)
192   -
193   -
194   -// --- Delphi/Kylix Version Numbers
195   -// As this is no code, this does not blow up your object or executable code at all
196   - (*$IFDEF LINUX *)
197   - (*$DEFINE K1_OR_NEWER *)
198   - (*$ENDIF *)
199   -
200   - (*$IFDEF MSWINDOWS *)
201   - (*$DEFINE D1_OR_NEWER *)
202   - (*$IFNDEF VER80 *)
203   - (*$DEFINE D2_OR_NEWER *)
204   - (*$IFNDEF VER90 *)
205   - (*$DEFINE D3_OR_NEWER *)
206   - (*$IFNDEF VER100 *)
207   - (*$DEFINE D4_OR_NEWER *)
208   - (*$IFNDEF VER120 *)
209   - (*$DEFINE D5_OR_NEWER *)
210   - (*$IFNDEF VER130 *)
211   - (*$IFNDEF VER140 *)
212   - (*$IFNDEF VER150 *)
213   - If the compiler gets stuck here,
214   - you are using a compiler version unknown to this code.
215   - You will probably have to change this code accordingly.
216   - At first, try to comment out these lines and see what will happen.
217   - (*$ENDIF *)
218   - (*$ENDIF *)
219   - (*$ENDIF *)
220   - (*$ENDIF *)
221   - (*$ENDIF *)
222   - (*$ENDIF *)
223   - (*$ENDIF *)
224   - (*$ENDIF *)
225   -
226   - (*$IFDEF D5_OR_NEWER *)
227   - (*$DEFINE HAS_CONTNRS_UNIT *)
228   - (*$ENDIF *)
229   -
230   - (*$IFDEF K1_OR_NEWER *)
231   - (*$DEFINE HAS_CONTNRS_UNIT *)
232   - (*$ENDIF *)
233   -
234   -
235   -UNIT LibXmlParser;
236   -
237   -INTERFACE
238   -
239   -USES
240   - SysUtils, Classes,
241   - (*$IFDEF HAS_CONTNRS_UNIT *) // The Contnrs Unit was introduced in Delphi 5
242   - Contnrs,
243   - (*$ENDIF*)
244   - Math;
245   -
246   -CONST
247   - CVersion = '1.0.17'; // This variable will be updated for every release
248   - // (I hope, I won't forget to do it everytime ...)
249   -
250   -TYPE
251   - TPartType = // --- Document Part Types
252   - (ptNone, // Nothing
253   - ptXmlProlog, // XML Prolog XmlSpec 2.8 / 4.3.1
254   - ptComment, // Comment XmlSpec 2.5
255   - ptPI, // Processing Instruction XmlSpec 2.6
256   - ptDtdc, // Document Type Declaration XmlSpec 2.8
257   - ptStartTag, // Start Tag XmlSpec 3.1
258   - ptEmptyTag, // Empty-Element Tag XmlSpec 3.1
259   - ptEndTag, // End Tag XmlSpec 3.1
260   - ptContent, // Text Content between Tags
261   - ptCData); // CDATA Section XmlSpec 2.7
262   -
263   - TDtdElemType = // --- DTD Elements
264   - (deElement, // !ELEMENT declaration
265   - deAttList, // !ATTLIST declaration
266   - deEntity, // !ENTITY declaration
267   - deNotation, // !NOTATION declaration
268   - dePI, // PI in DTD
269   - deComment, // Comment in DTD
270   - deError); // Error found in the DTD
271   -
272   -TYPE
273   - TAttrList = CLASS;
274   - TEntityStack = CLASS;
275   - TNvpList = CLASS;
276   - TElemDef = CLASS;
277   - TElemList = CLASS;
278   - TEntityDef = CLASS;
279   - TNotationDef = CLASS;
280   -
281   - TDtdElementRec = RECORD // --- This Record is returned by the DTD parser callback function
282   - Start, Final : PChar; // Start/End of the Element's Declaration
283   - CASE ElementType : TDtdElemType OF // Type of the Element
284   - deElement, // <!ELEMENT>
285   - deAttList : (ElemDef : TElemDef); // <!ATTLIST>
286   - deEntity : (EntityDef : TEntityDef); // <!ENTITY>
287   - deNotation : (NotationDef : TNotationDef); // <!NOTATION>
288   - dePI : (Target : PChar; // <?PI ?>
289   - Content : PChar;
290   - AttrList : TAttrList);
291   - deError : (Pos : PChar); // Error
292   - // deComment : ((No additional fields here)); // <!-- Comment -->
293   - END;
294   -
295   - TXmlParser = CLASS // --- Internal Properties and Methods
296   - PROTECTED
297   - FBuffer : PChar; // NIL if there is no buffer available
298   - FBufferSize : INTEGER; // 0 if the buffer is not owned by the Document instance
299   - FSource : STRING; // Name of Source of document. Filename for Documents loaded with LoadFromFile
300   -
301   - FXmlVersion : STRING; // XML version from Document header. Default is '1.0'
302   - FEncoding : STRING; // Encoding from Document header. Default is 'UTF-8'
303   - FStandalone : BOOLEAN; // Standalone declaration from Document header. Default is 'yes'
304   - FRootName : STRING; // Name of the Root Element (= DTD name)
305   - FDtdcFinal : PChar; // Pointer to the '>' character terminating the DTD declaration
306   -
307   - FNormalize : BOOLEAN; // If true: Pack Whitespace and don't return empty contents
308   - EntityStack : TEntityStack; // Entity Stack for Parameter and General Entities
309   - FCurEncoding : STRING; // Current Encoding during parsing (always uppercase)
310   -
311   - PROCEDURE AnalyzeProlog; // Analyze XML Prolog or Text Declaration
312   - PROCEDURE AnalyzeComment (Start : PChar; VAR Final : PChar); // Analyze Comments
313   - PROCEDURE AnalyzePI (Start : PChar; VAR Final : PChar); // Analyze Processing Instructions (PI)
314   - PROCEDURE AnalyzeDtdc; // Analyze Document Type Declaration
315   - PROCEDURE AnalyzeDtdElements (Start : PChar; VAR Final : PChar); // Analyze DTD declarations
316   - PROCEDURE AnalyzeTag; // Analyze Start/End/Empty-Element Tags
317   - PROCEDURE AnalyzeCData; // Analyze CDATA Sections
318   - PROCEDURE AnalyzeText (VAR IsDone : BOOLEAN); // Analyze Text Content between Tags
319   - PROCEDURE AnalyzeElementDecl (Start : PChar; VAR Final : PChar);
320   - PROCEDURE AnalyzeAttListDecl (Start : PChar; VAR Final : PChar);
321   - PROCEDURE AnalyzeEntityDecl (Start : PChar; VAR Final : PChar);
322   - PROCEDURE AnalyzeNotationDecl (Start : PChar; VAR Final : PChar);
323   -
324   - PROCEDURE PushPE (VAR Start : PChar);
325   - PROCEDURE ReplaceCharacterEntities (VAR Str : STRING);
326   - PROCEDURE ReplaceParameterEntities (VAR Str : STRING);
327   - PROCEDURE ReplaceGeneralEntities (VAR Str : STRING);
328   -
329   - FUNCTION GetDocBuffer : PChar; // Returns FBuffer or a pointer to a NUL char if Buffer is empty
330   -
331   - PUBLIC // --- Document Properties
332   - PROPERTY XmlVersion : STRING READ FXmlVersion; // XML version from the Document Prolog
333   - PROPERTY Encoding : STRING READ FEncoding; // Document Encoding from Prolog
334   - PROPERTY Standalone : BOOLEAN READ FStandalone; // Standalone Declaration from Prolog
335   - PROPERTY RootName : STRING READ FRootName; // Name of the Root Element
336   - PROPERTY Normalize : BOOLEAN READ FNormalize WRITE FNormalize; // True if Content is to be normalized
337   - PROPERTY Source : STRING READ FSource; // Name of Document Source (Filename)
338   - PROPERTY DocBuffer : PChar READ GetDocBuffer; // Returns document buffer
339   - PUBLIC // --- DTD Objects
340   - Elements : TElemList; // Elements: List of TElemDef (contains Attribute Definitions)
341   - Entities : TNvpList; // General Entities: List of TEntityDef
342   - ParEntities : TNvpList; // Parameter Entities: List of TEntityDef
343   - Notations : TNvpList; // Notations: List of TNotationDef
344   - PUBLIC
345   - CONSTRUCTOR Create;
346   - DESTRUCTOR Destroy; OVERRIDE;
347   -
348   - // --- Document Handling
349   - FUNCTION LoadFromFile (Filename : STRING;
350   - FileMode : INTEGER = fmOpenRead OR fmShareDenyNone) : BOOLEAN;
351   - // Loads Document from given file
352   - FUNCTION LoadFromBuffer (Buffer : PChar) : BOOLEAN; // Loads Document from another buffer
353   - PROCEDURE SetBuffer (Buffer : PChar); // References another buffer
354   - PROCEDURE Clear; // Clear Document
355   -
356   - PUBLIC
357   - // --- Scanning through the document
358   - CurPartType : TPartType; // Current Type
359   - CurName : STRING; // Current Name
360   - CurContent : STRING; // Current Normalized Content
361   - CurStart : PChar; // Current First character
362   - CurFinal : PChar; // Current Last character
363   - CurAttr : TAttrList; // Current Attribute List
364   - PROPERTY CurEncoding : STRING READ FCurEncoding; // Current Encoding
365   - PROCEDURE StartScan;
366   - FUNCTION Scan : BOOLEAN;
367   -
368   - // --- Events / Callbacks
369   - FUNCTION LoadExternalEntity (SystemId, PublicId,
370   - Notation : STRING) : TXmlParser; VIRTUAL;
371   - FUNCTION TranslateEncoding (CONST Source : STRING) : STRING; VIRTUAL;
372   - PROCEDURE DtdElementFound (DtdElementRec : TDtdElementRec); VIRTUAL;
373   - END;
374   -
375   - TValueType = // --- Attribute Value Type
376   - (vtNormal, // Normal specified Attribute
377   - vtImplied, // #IMPLIED attribute value
378   - vtFixed, // #FIXED attribute value
379   - vtDefault); // Attribute value from default value in !ATTLIST declaration
380   -
381   - TAttrDefault = // --- Attribute Default Type
382   - (adDefault, // Normal default value
383   - adRequired, // #REQUIRED attribute
384   - adImplied, // #IMPLIED attribute
385   - adFixed); // #FIXED attribute
386   -
387   - TAttrType = // --- Type of attribute
388   - (atUnknown, // Unknown type
389   - atCData, // Character data only
390   - atID, // ID
391   - atIdRef, // ID Reference
392   - atIdRefs, // Several ID References, separated by Whitespace
393   - atEntity, // Name of an unparsed Entity
394   - atEntities, // Several unparsed Entity names, separated by Whitespace
395   - atNmToken, // Name Token
396   - atNmTokens, // Several Name Tokens, separated by Whitespace
397   - atNotation, // A selection of Notation names (Unparsed Entity)
398   - atEnumeration); // Enumeration
399   -
400   - TElemType = // --- Element content type
401   - (etEmpty, // Element is always empty
402   - etAny, // Element can have any mixture of PCDATA and any elements
403   - etChildren, // Element must contain only elements
404   - etMixed); // Mixed PCDATA and elements
405   -
406   - (*$IFDEF HAS_CONTNRS_UNIT *)
407   - TObjectList = Contnrs.TObjectList; // Re-Export this identifier
408   - (*$ELSE *)
409   - TObjectList = CLASS (TList)
410   - DESTRUCTOR Destroy; OVERRIDE;
411   - PROCEDURE Delete (Index : INTEGER);
412   - PROCEDURE Clear; OVERRIDE;
413   - END;
414   - (*$ENDIF *)
415   -
416   - TNvpNode = CLASS // Name-Value Pair Node
417   - Name : STRING;
418   - Value : STRING;
419   - CONSTRUCTOR Create (TheName : STRING = ''; TheValue : STRING = '');
420   - END;
421   -
422   - TNvpList = CLASS (TObjectList) // Name-Value Pair List
423   - PROCEDURE Add (Node : TNvpNode);
424   - FUNCTION Node (Name : STRING) : TNvpNode; OVERLOAD;
425   - FUNCTION Node (Index : INTEGER) : TNvpNode; OVERLOAD;
426   - FUNCTION Value (Name : STRING) : STRING; OVERLOAD;
427   - FUNCTION Value (Index : INTEGER) : STRING; OVERLOAD;
428   - FUNCTION Name (Index : INTEGER) : STRING;
429   - END;
430   -
431   - TAttr = CLASS (TNvpNode) // Attribute of a Start-Tag or Empty-Element-Tag
432   - ValueType : TValueType;
433   - AttrType : TAttrType;
434   - END;
435   -
436   - TAttrList = CLASS (TNvpList) // List of Attributes
437   - PROCEDURE Analyze (Start : PChar; VAR Final : PChar);
438   - END;
439   -
440   - TEntityStack = CLASS (TObjectList) // Stack where current position is stored before parsing entities
441   - PROTECTED
442   - Owner : TXmlParser;
443   - PUBLIC
444   - CONSTRUCTOR Create (TheOwner : TXmlParser);
445   - PROCEDURE Push (LastPos : PChar); OVERLOAD;
446   - PROCEDURE Push (Instance : TObject; LastPos : PChar); OVERLOAD;
447   - FUNCTION Pop : PChar; // Returns next char or NIL if EOF is reached. Frees Instance.
448   - END;
449   -
450   - TAttrDef = CLASS (TNvpNode) // Represents a <!ATTLIST Definition. "Value" is the default value
451   - TypeDef : STRING; // Type definition from the DTD
452   - Notations : STRING; // Notation List, separated by pipe symbols '|'
453   - AttrType : TAttrType; // Attribute Type
454   - DefaultType : TAttrDefault; // Default Type
455   - END;
456   -
457   - TElemDef = CLASS (TNvpList) // Represents a <!ELEMENT Definition. Is a list of TAttrDef-Nodes
458   - Name : STRING; // Element name
459   - ElemType : TElemType; // Element type
460   - Definition : STRING; // Element definition from DTD
461   - END;
462   -
463   - TElemList = CLASS (TObjectList) // List of TElemDef nodes
464   - FUNCTION Node (Name : STRING) : TElemDef;
465   - PROCEDURE Add (Node : TElemDef);
466   - END;
467   -
468   - TEntityDef = CLASS (TNvpNode) // Represents a <!ENTITY Definition.
469   - SystemId : STRING;
470   - PublicId : STRING;
471   - NotationName : STRING;
472   - END;
473   -
474   - TNotationDef = CLASS (TNvpNode) // Represents a <!NOTATION Definition. Value is the System ID
475   - PublicId : STRING;
476   - END;
477   -
478   - TCharset = SET OF CHAR;
479   -
480   -
481   -CONST
482   - CWhitespace = [#32, #9, #13, #10]; // Whitespace characters (XmlSpec 2.3)
483   - CLetter = [#$41..#$5A, #$61..#$7A, #$C0..#$D6, #$D8..#$F6, #$F8..#$FF];
484   - CDigit = [#$30..#$39];
485   - CNameChar = CLetter + CDigit + ['.', '-', '_', ':', #$B7];
486   - CNameStart = CLetter + ['_', ':'];
487   - CQuoteChar = ['"', ''''];
488   - CPubidChar = [#32, ^M, ^J, #9, 'a'..'z', 'A'..'Z', '0'..'9',
489   - '-', '''', '(', ')', '+', ',', '.', '/', ':',
490   - '=', '?', ';', '!', '*', '#', '@', '$', '_', '%'];
491   -
492   - CDStart = '<![CDATA[';
493   - CDEnd = ']]>';
494   -
495   - // --- Name Constants for the above enumeration types
496   - CPartType_Name : ARRAY [TPartType] OF STRING =
497   - ('', 'XML Prolog', 'Comment', 'PI',
498   - 'DTD Declaration', 'Start Tag', 'Empty Tag', 'End Tag',
499   - 'Text', 'CDATA');
500   - CValueType_Name : ARRAY [TValueType] OF STRING = ('Normal', 'Implied', 'Fixed', 'Default');
501   - CAttrDefault_Name : ARRAY [TAttrDefault] OF STRING = ('Default', 'Required', 'Implied', 'Fixed');
502   - CElemType_Name : ARRAY [TElemType] OF STRING = ('Empty', 'Any', 'Childs only', 'Mixed');
503   - CAttrType_Name : ARRAY [TAttrType] OF STRING = ('Unknown', 'CDATA',
504   - 'ID', 'IDREF', 'IDREFS',
505   - 'ENTITY', 'ENTITIES',
506   - 'NMTOKEN', 'NMTOKENS',
507   - 'Notation', 'Enumeration');
508   -
509   -FUNCTION ConvertWs (Source: STRING; PackWs: BOOLEAN) : STRING; // Convert WS to spaces #x20
510   -PROCEDURE SetStringSF (VAR S : STRING; BufferStart, BufferFinal : PChar); // SetString by Start/Final of buffer
511   -FUNCTION StrSFPas (Start, Finish : PChar) : STRING; // Convert buffer part to Pascal string
512   -FUNCTION TrimWs (Source : STRING) : STRING; // Trim Whitespace
513   -
514   -FUNCTION AnsiToUtf8 (Source : ANSISTRING) : STRING; // Convert Win-1252 to UTF-8
515   -FUNCTION Utf8ToAnsi (Source : STRING; UnknownChar : CHAR = '¿') : ANSISTRING; // Convert UTF-8 to Win-1252
516   -
517   -
518   -(*
519   -===============================================================================================
520   -TCustomXmlScanner event based component wrapper for TXmlParser
521   -===============================================================================================
522   -*)
523   -
524   -TYPE
525   - TCustomXmlScanner = CLASS;
526   - TXmlPrologEvent = PROCEDURE (Sender : TObject; XmlVersion, Encoding: STRING; Standalone : BOOLEAN) OF OBJECT;
527   - TCommentEvent = PROCEDURE (Sender : TObject; Comment : STRING) OF OBJECT;
528   - TPIEvent = PROCEDURE (Sender : TObject; Target, Content: STRING; Attributes : TAttrList) OF OBJECT;
529   - TDtdEvent = PROCEDURE (Sender : TObject; RootElementName : STRING) OF OBJECT;
530   - TStartTagEvent = PROCEDURE (Sender : TObject; TagName : STRING; Attributes : TAttrList) OF OBJECT;
531   - TEndTagEvent = PROCEDURE (Sender : TObject; TagName : STRING) OF OBJECT;
532   - TContentEvent = PROCEDURE (Sender : TObject; Content : STRING) OF OBJECT;
533   - TElementEvent = PROCEDURE (Sender : TObject; ElemDef : TElemDef) OF OBJECT;
534   - TEntityEvent = PROCEDURE (Sender : TObject; EntityDef : TEntityDef) OF OBJECT;
535   - TNotationEvent = PROCEDURE (Sender : TObject; NotationDef : TNotationDef) OF OBJECT;
536   - TErrorEvent = PROCEDURE (Sender : TObject; ErrorPos : PChar) OF OBJECT;
537   - TExternalEvent = PROCEDURE (Sender : TObject; SystemId, PublicId, NotationId : STRING;
538   - VAR Result : TXmlParser) OF OBJECT;
539   - TEncodingEvent = FUNCTION (Sender : TObject; CurrentEncoding, Source : STRING) : STRING OF OBJECT;
540   -
541   -
542   - TCustomXmlScanner = CLASS (TComponent)
543   - PROTECTED
544   - FXmlParser : TXmlParser;
545   - FOnXmlProlog : TXmlPrologEvent;
546   - FOnComment : TCommentEvent;
547   - FOnPI : TPIEvent;
548   - FOnDtdRead : TDtdEvent;
549   - FOnStartTag : TStartTagEvent;
550   - FOnEmptyTag : TStartTagEvent;
551   - FOnEndTag : TEndTagEvent;
552   - FOnContent : TContentEvent;
553   - FOnCData : TContentEvent;
554   - FOnElement : TElementEvent;
555   - FOnAttList : TElementEvent;
556   - FOnEntity : TEntityEvent;
557   - FOnNotation : TNotationEvent;
558   - FOnDtdError : TErrorEvent;
559   - FOnLoadExternal : TExternalEvent;
560   - FOnTranslateEncoding : TEncodingEvent;
561   - FStopParser : BOOLEAN;
562   - FUNCTION GetNormalize : BOOLEAN;
563   - PROCEDURE SetNormalize (Value : BOOLEAN);
564   -
565   - PROCEDURE WhenXmlProlog(XmlVersion, Encoding: STRING; Standalone : BOOLEAN); VIRTUAL;
566   - PROCEDURE WhenComment (Comment : STRING); VIRTUAL;
567   - PROCEDURE WhenPI (Target, Content: STRING; Attributes : TAttrList); VIRTUAL;
568   - PROCEDURE WhenDtdRead (RootElementName : STRING); VIRTUAL;
569   - PROCEDURE WhenStartTag (TagName : STRING; Attributes : TAttrList); VIRTUAL;
570   - PROCEDURE WhenEmptyTag (TagName : STRING; Attributes : TAttrList); VIRTUAL;
571   - PROCEDURE WhenEndTag (TagName : STRING); VIRTUAL;
572   - PROCEDURE WhenContent (Content : STRING); VIRTUAL;
573   - PROCEDURE WhenCData (Content : STRING); VIRTUAL;
574   - PROCEDURE WhenElement (ElemDef : TElemDef); VIRTUAL;
575   - PROCEDURE WhenAttList (ElemDef : TElemDef); VIRTUAL;
576   - PROCEDURE WhenEntity (EntityDef : TEntityDef); VIRTUAL;
577   - PROCEDURE WhenNotation (NotationDef : TNotationDef); VIRTUAL;
578   - PROCEDURE WhenDtdError (ErrorPos : PChar); VIRTUAL;
579   -
580   - PUBLIC
581   - CONSTRUCTOR Create (AOwner: TComponent); OVERRIDE;
582   - DESTRUCTOR Destroy; OVERRIDE;
583   -
584   - PROCEDURE LoadFromFile (Filename : TFilename); // Load XML Document from file
585   - PROCEDURE LoadFromBuffer (Buffer : PChar); // Load XML Document from buffer
586   - PROCEDURE SetBuffer (Buffer : PChar); // Refer to Buffer
587   - FUNCTION GetFilename : TFilename;
588   -
589   - PROCEDURE Execute; // Perform scanning
590   -
591   - PROTECTED
592   - PROPERTY XmlParser : TXmlParser READ FXmlParser;
593   - PROPERTY StopParser : BOOLEAN READ FStopParser WRITE FStopParser;
594   - PROPERTY Filename : TFilename READ GetFilename WRITE LoadFromFile;
595   - PROPERTY Normalize : BOOLEAN READ GetNormalize WRITE SetNormalize;
596   - PROPERTY OnXmlProlog : TXmlPrologEvent READ FOnXmlProlog WRITE FOnXmlProlog;
597   - PROPERTY OnComment : TCommentEvent READ FOnComment WRITE FOnComment;
598   - PROPERTY OnPI : TPIEvent READ FOnPI WRITE FOnPI;
599   - PROPERTY OnDtdRead : TDtdEvent READ FOnDtdRead WRITE FOnDtdRead;
600   - PROPERTY OnStartTag : TStartTagEvent READ FOnStartTag WRITE FOnStartTag;
601   - PROPERTY OnEmptyTag : TStartTagEvent READ FOnEmptyTag WRITE FOnEmptyTag;
602   - PROPERTY OnEndTag : TEndTagEvent READ FOnEndTag WRITE FOnEndTag;
603   - PROPERTY OnContent : TContentEvent READ FOnContent WRITE FOnContent;
604   - PROPERTY OnCData : TContentEvent READ FOnCData WRITE FOnCData;
605   - PROPERTY OnElement : TElementEvent READ FOnElement WRITE FOnElement;
606   - PROPERTY OnAttList : TElementEvent READ FOnAttList WRITE FOnAttList;
607   - PROPERTY OnEntity : TEntityEvent READ FOnEntity WRITE FOnEntity;
608   - PROPERTY OnNotation : TNotationEvent READ FOnNotation WRITE FOnNotation;
609   - PROPERTY OnDtdError : TErrorEvent READ FOnDtdError WRITE FOnDtdError;
610   - PROPERTY OnLoadExternal : TExternalEvent READ FOnLoadExternal WRITE FOnLoadExternal;
611   - PROPERTY OnTranslateEncoding : TEncodingEvent READ FOnTranslateEncoding WRITE FOnTranslateEncoding;
612   - END;
613   -
614   -(*
615   -===============================================================================================
616   -IMPLEMENTATION
617   -===============================================================================================
618   -*)
619   -
620   -IMPLEMENTATION
621   -
622   -
623   -(*
624   -===============================================================================================
625   -Unicode and UTF-8 stuff
626   -===============================================================================================
627   -*)
628   -
629   -CONST
630   - // --- Character Translation Table for Unicode <-> Win-1252
631   - WIN1252_UNICODE : ARRAY [$00..$FF] OF WORD = (
632   - $0000, $0001, $0002, $0003, $0004, $0005, $0006, $0007, $0008, $0009,
633   - $000A, $000B, $000C, $000D, $000E, $000F, $0010, $0011, $0012, $0013,
634   - $0014, $0015, $0016, $0017, $0018, $0019, $001A, $001B, $001C, $001D,
635   - $001E, $001F, $0020, $0021, $0022, $0023, $0024, $0025, $0026, $0027,
636   - $0028, $0029, $002A, $002B, $002C, $002D, $002E, $002F, $0030, $0031,
637   - $0032, $0033, $0034, $0035, $0036, $0037, $0038, $0039, $003A, $003B,
638   - $003C, $003D, $003E, $003F, $0040, $0041, $0042, $0043, $0044, $0045,
639   - $0046, $0047, $0048, $0049, $004A, $004B, $004C, $004D, $004E, $004F,
640   - $0050, $0051, $0052, $0053, $0054, $0055, $0056, $0057, $0058, $0059,
641   - $005A, $005B, $005C, $005D, $005E, $005F, $0060, $0061, $0062, $0063,
642   - $0064, $0065, $0066, $0067, $0068, $0069, $006A, $006B, $006C, $006D,
643   - $006E, $006F, $0070, $0071, $0072, $0073, $0074, $0075, $0076, $0077,
644   - $0078, $0079, $007A, $007B, $007C, $007D, $007E, $007F,
645   -
646   - $20AC, $0081, $201A, $0192, $201E, $2026, $2020, $2021, $02C6, $2030,
647   - $0160, $2039, $0152, $008D, $017D, $008F, $0090, $2018, $2019, $201C,
648   - $201D, $2022, $2013, $2014, $02DC, $2122, $0161, $203A, $0153, $009D,
649   - $017E, $0178, $00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7,
650   - $00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF, $00B0, $00B1,
651   - $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, $00B8, $00B9, $00BA, $00BB,
652   - $00BC, $00BD, $00BE, $00BF, $00C0, $00C1, $00C2, $00C3, $00C4, $00C5,
653   - $00C6, $00C7, $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF,
654   - $00D0, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7, $00D8, $00D9,
655   - $00DA, $00DB, $00DC, $00DD, $00DE, $00DF, $00E0, $00E1, $00E2, $00E3,
656   - $00E4, $00E5, $00E6, $00E7, $00E8, $00E9, $00EA, $00EB, $00EC, $00ED,
657   - $00EE, $00EF, $00F0, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7,
658   - $00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $00FE, $00FF);
659   -
660   -(* UTF-8 (somewhat simplified)
661   - -----
662   - Character Range Byte sequence
663   - --------------- -------------------------- (x=Bits from original character)
664   - $0000..$007F 0xxxxxxx
665   - $0080..$07FF 110xxxxx 10xxxxxx
666   - $8000..$FFFF 1110xxxx 10xxxxxx 10xxxxxx
667   -
668   - Example
669   - --------
670   - Transforming the Unicode character U+00E4 LATIN SMALL LETTER A WITH DIAERESIS ("ä"):
671   -
672   - ISO-8859-1, Decimal 228
673   - Win1252, Hex $E4
674   - ANSI Bin 1110 0100
675   - abcd efgh
676   -
677   - UTF-8 Binary 1100xxab 10cdefgh
678   - Binary 11000011 10100100
679   - Hex $C3 $A4
680   - Decimal 195 164
681   - ANSI Ã ¤ *)
682   -
683   -
684   -FUNCTION AnsiToUtf8 (Source : ANSISTRING) : STRING;
685   - (* Converts the given Windows ANSI (Win1252) String to UTF-8. *)
686   -VAR
687   - I : INTEGER; // Loop counter
688   - U : WORD; // Current Unicode value
689   - Len : INTEGER; // Current real length of "Result" string
690   -BEGIN
691   - SetLength (Result, Length (Source) * 3); // Worst case
692   - Len := 0;
693   - FOR I := 1 TO Length (Source) DO BEGIN
694   - U := WIN1252_UNICODE [ORD (Source [I])];
695   - CASE U OF
696   - $0000..$007F : BEGIN
697   - INC (Len);
698   - Result [Len] := CHR (U);
699   - END;
700   - $0080..$07FF : BEGIN
701   - INC (Len);
702   - Result [Len] := CHR ($C0 OR (U SHR 6));
703   - INC (Len);
704   - Result [Len] := CHR ($80 OR (U AND $3F));
705   - END;
706   - $0800..$FFFF : BEGIN
707   - INC (Len);
708   - Result [Len] := CHR ($E0 OR (U SHR 12));
709   - INC (Len);
710   - Result [Len] := CHR ($80 OR ((U SHR 6) AND $3F));
711   - INC (Len);
712   - Result [Len] := CHR ($80 OR (U AND $3F));
713   - END;
714   - END;
715   - END;
716   - SetLength (Result, Len);
717   -END;
718   -
719   -
720   -FUNCTION Utf8ToAnsi (Source : STRING; UnknownChar : CHAR = '¿') : ANSISTRING;
721   - (* Converts the given UTF-8 String to Windows ANSI (Win-1252).
722   - If a character can not be converted, the "UnknownChar" is inserted. *)
723   -VAR
724   - SourceLen : INTEGER; // Length of Source string
725   - I, K : INTEGER;
726   - A : BYTE; // Current ANSI character value
727   - U : WORD;
728   - Ch : CHAR; // Dest char
729   - Len : INTEGER; // Current real length of "Result" string
730   -BEGIN
731   - SourceLen := Length (Source);
732   - SetLength (Result, SourceLen); // Enough room to live
733   - Len := 0;
734   - I := 1;
735   - WHILE I <= SourceLen DO BEGIN
736   - A := ORD (Source [I]);
737   - IF A < $80 THEN BEGIN // Range $0000..$007F
738   - INC (Len);
739   - Result [Len] := Source [I];
740   - INC (I);
741   - END
742   - ELSE BEGIN // Determine U, Inc I
743   - IF (A AND $E0 = $C0) AND (I < SourceLen) THEN BEGIN // Range $0080..$07FF
744   - U := (WORD (A AND $1F) SHL 6) OR (ORD (Source [I+1]) AND $3F);
745   - INC (I, 2);
746   - END
747   - ELSE IF (A AND $F0 = $E0) AND (I < SourceLen-1) THEN BEGIN // Range $0800..$FFFF
748   - U := (WORD (A AND $0F) SHL 12) OR
749   - (WORD (ORD (Source [I+1]) AND $3F) SHL 6) OR
750   - ( ORD (Source [I+2]) AND $3F);
751   - INC (I, 3);
752   - END
753   - ELSE BEGIN // Unknown/unsupported
754   - INC (I);
755   - FOR K := 7 DOWNTO 0 DO
756   - IF A AND (1 SHL K) = 0 THEN BEGIN
757   - INC (I, (A SHR (K+1))-1);
758   - BREAK;
759   - END;
760   - U := WIN1252_UNICODE [ORD (UnknownChar)];
761   - END;
762   - Ch := UnknownChar; // Retrieve ANSI char
763   - FOR A := $00 TO $FF DO
764   - IF WIN1252_UNICODE [A] = U THEN BEGIN
765   - Ch := CHR (A);
766   - BREAK;
767   - END;
768   - INC (Len);
769   - Result [Len] := Ch;
770   - END;
771   - END;
772   - SetLength (Result, Len);
773   -END;
774   -
775   -
776   -(*
777   -===============================================================================================
778   -"Special" Helper Functions
779   -
780   -Don't ask me why. But including these functions makes the parser *DRAMATICALLY* faster
781   -on my K6-233 machine. You can test it yourself just by commenting them out.
782   -They do exactly the same as the Assembler routines defined in SysUtils.
783   -(This is where you can see how great the Delphi compiler really is. The compiled code is
784   -faster than hand-coded assembler!)
785   -===============================================================================================
786   ---> Just move this line below the StrScan function --> *)
787   -
788   -
789   -FUNCTION StrPos (CONST Str, SearchStr : PChar) : PChar;
790   - // Same functionality as SysUtils.StrPos
791   -VAR
792   - First : CHAR;
793   - Len : INTEGER;
794   -BEGIN
795   - First := SearchStr^;
796   - Len := StrLen (SearchStr);
797   - Result := Str;
798   - REPEAT
799   - IF Result^ = First THEN
800   - IF StrLComp (Result, SearchStr, Len) = 0 THEN BREAK;
801   - IF Result^ = #0 THEN BEGIN
802   - Result := NIL;
803   - BREAK;
804   - END;
805   - INC (Result);
806   - UNTIL FALSE;
807   -END;
808   -
809   -
810   -FUNCTION StrScan (CONST Start : PChar; CONST Ch : CHAR) : PChar;
811   - // Same functionality as SysUtils.StrScan
812   -BEGIN
813   - Result := Start;
814   - WHILE Result^ <> Ch DO BEGIN
815   - IF Result^ = #0 THEN BEGIN
816   - Result := NIL;
817   - EXIT;
818   - END;
819   - INC (Result);
820   - END;
821   -END;
822   -
823   -
824   -(*
825   -===============================================================================================
826   -Helper Functions
827   -===============================================================================================
828   -*)
829   -
830   -FUNCTION DelChars (Source : STRING; CharsToDelete : TCharset) : STRING;
831   - // Delete all "CharsToDelete" from the string
832   -VAR
833   - I : INTEGER;
834   -BEGIN
835   - Result := Source;
836   - FOR I := Length (Result) DOWNTO 1 DO
837   - IF Result [I] IN CharsToDelete THEN
838   - Delete (Result, I, 1);
839   -END;
840   -
841   -
842   -FUNCTION TrimWs (Source : STRING) : STRING;
843   - // Trimms off Whitespace characters from both ends of the string
844   -VAR
845   - I : INTEGER;
846   -BEGIN
847   - // --- Trim Left
848   - I := 1;
849   - WHILE (I <= Length (Source)) AND (Source [I] IN CWhitespace) DO
850   - INC (I);
851   - Result := Copy (Source, I, MaxInt);
852   -
853   - // --- Trim Right
854   - I := Length (Result);
855   - WHILE (I > 1) AND (Result [I] IN CWhitespace) DO
856   - DEC (I);
857   - Delete (Result, I+1, Length (Result)-I);
858   -END;
859   -
860   -
861   -FUNCTION ConvertWs (Source: STRING; PackWs: BOOLEAN) : STRING;
862   - // Converts all Whitespace characters to the Space #x20 character
863   - // If "PackWs" is true, contiguous Whitespace characters are packed to one
864   -VAR
865   - I : INTEGER;
866   -BEGIN
867   - Result := Source;
868   - FOR I := Length (Result) DOWNTO 1 DO
869   - IF (Result [I] IN CWhitespace) THEN
870   - IF PackWs AND (I > 1) AND (Result [I-1] IN CWhitespace)
871   - THEN Delete (Result, I, 1)
872   - ELSE Result [I] := #32;
873   -END;
874   -
875   -
876   -PROCEDURE SetStringSF (VAR S : STRING; BufferStart, BufferFinal : PChar);
877   -BEGIN
878   - SetString (S, BufferStart, BufferFinal-BufferStart+1);
879   -END;
880   -
881   -
882   -FUNCTION StrLPas (Start : PChar; Len : INTEGER) : STRING;
883   -BEGIN
884   - SetString (Result, Start, Len);
885   -END;
886   -
887   -
888   -FUNCTION StrSFPas (Start, Finish : PChar) : STRING;
889   -BEGIN
890   - SetString (Result, Start, Finish-Start+1);
891   -END;
892   -
893   -
894   -FUNCTION StrScanE (CONST Source : PChar; CONST CharToScanFor : CHAR) : PChar;
895   - // If "CharToScanFor" is not found, StrScanE returns the last char of the
896   - // buffer instead of NIL
897   -BEGIN
898   - Result := StrScan (Source, CharToScanFor);
899   - IF Result = NIL THEN
900   - Result := StrEnd (Source)-1;
901   -END;
902   -
903   -
904   -PROCEDURE ExtractName (Start : PChar; Terminators : TCharset; VAR Final : PChar);
905   - (* Extracts the complete Name beginning at "Start".
906   - It is assumed that the name is contained in Markup, so the '>' character is
907   - always a Termination.
908   - Start: IN Pointer to first char of name. Is always considered to be valid
909   - Terminators: IN Characters which terminate the name
910   - Final: OUT Pointer to last char of name *)
911   -BEGIN
912   - Final := Start+1;
913   - Include (Terminators, #0);
914   - Include (Terminators, '>');
915   - WHILE NOT (Final^ IN Terminators) DO
916   - INC (Final);
917   - DEC (Final);
918   -END;
919   -
920   -
921   -PROCEDURE ExtractQuote (Start : PChar; VAR Content : STRING; VAR Final : PChar);
922   - (* Extract a string which is contained in single or double Quotes.
923   - Start: IN Pointer to opening quote
924   - Content: OUT The quoted string
925   - Final: OUT Pointer to closing quote *)
926   -BEGIN
927   - Final := StrScan (Start+1, Start^);
928   - IF Final = NIL THEN BEGIN
929   - Final := StrEnd (Start+1)-1;
930   - SetString (Content, Start+1, Final-Start);
931   - END
932   - ELSE
933   - SetString (Content, Start+1, Final-1-Start);
934   -END;
935   -
936   -
937   -(*
938   -===============================================================================================
939   -TEntityStackNode
940   -This Node is pushed to the "Entity Stack" whenever the parser parses entity replacement text.
941   -The "Instance" field holds the Instance pointer of an External Entity buffer. When it is
942   -popped, the Instance is freed.
943   -The "Encoding" field holds the name of the Encoding. External Parsed Entities may have
944   -another encoding as the document entity (XmlSpec 4.3.3). So when there is an "<?xml" PI
945   -found in the stream (= Text Declaration at the beginning of external parsed entities), the
946   -Encoding found there is used for the External Entity (is assigned to TXmlParser.CurEncoding)
947   -Default Encoding is for the Document Entity is UTF-8. It is assumed that External Entities
948   -have the same Encoding as the Document Entity, unless they carry a Text Declaration.
949   -===============================================================================================
950   -*)
951   -
952   -TYPE
953   - TEntityStackNode = CLASS
954   - Instance : TObject;
955   - Encoding : STRING;
956   - LastPos : PChar;
957   - END;
958   -
959   -(*
960   -===============================================================================================
961   -TEntityStack
962   -For nesting of Entities.
963   -When there is an entity reference found in the data stream, the corresponding entity
964   -definition is searched and the current position is pushed to this stack.
965   -From then on, the program scans the entitiy replacement text as if it were normal content.
966   -When the parser reaches the end of an entity, the current position is popped off the
967   -stack again.
968   -===============================================================================================
969   -*)
970   -
971   -CONSTRUCTOR TEntityStack.Create (TheOwner : TXmlParser);
972   -BEGIN
973   - INHERITED Create;
974   - Owner := TheOwner;
975   -END;
976   -
977   -
978   -PROCEDURE TEntityStack.Push (LastPos : PChar);
979   -BEGIN
980   - Push (NIL, LastPos);
981   -END;
982   -
983   -
984   -PROCEDURE TEntityStack.Push (Instance : TObject; LastPos : PChar);
985   -VAR
986   - ESN : TEntityStackNode;
987   -BEGIN
988   - ESN := TEntityStackNode.Create;
989   - ESN.Instance := Instance;
990   - ESN.Encoding := Owner.FCurEncoding; // Save current Encoding
991   - ESN.LastPos := LastPos;
992   - Add (ESN);
993   -END;
994   -
995   -
996   -FUNCTION TEntityStack.Pop : PChar;
997   -VAR
998   - ESN : TEntityStackNode;
999   -BEGIN
1000   - IF Count > 0 THEN BEGIN
1001   - ESN := TEntityStackNode (Items [Count-1]);
1002   - Result := ESN.LastPos;
1003   - IF ESN.Instance <> NIL THEN
1004   - ESN.Instance.Free;
1005   - IF ESN.Encoding <> '' THEN
1006   - Owner.FCurEncoding := ESN.Encoding; // Restore current Encoding
1007   - Delete (Count-1);
1008   - END
1009   - ELSE
1010   - Result := NIL;
1011   -END;
1012   -
1013   -
1014   -(*
1015   -===============================================================================================
1016   -TExternalID
1017   ------------
1018   -XmlSpec 4.2.2: ExternalID ::= 'SYSTEM' S SystemLiteral |
1019   - 'PUBLIC' S PubidLiteral S SystemLiteral
1020   -XmlSpec 4.7: PublicID ::= 'PUBLIC' S PubidLiteral
1021   -SystemLiteral and PubidLiteral are quoted
1022   -===============================================================================================
1023   -*)
1024   -
1025   -TYPE
1026   - TExternalID = CLASS
1027   - PublicId : STRING;
1028   - SystemId : STRING;
1029   - Final : PChar;
1030   - CONSTRUCTOR Create (Start : PChar);
1031   - END;
1032   -
1033   -CONSTRUCTOR TExternalID.Create (Start : PChar);
1034   -BEGIN
1035   - INHERITED Create;
1036   - Final := Start;
1037   - IF StrLComp (Start, 'SYSTEM', 6) = 0 THEN BEGIN
1038   - WHILE NOT (Final^ IN (CQuoteChar + [#0, '>', '['])) DO INC (Final);
1039   - IF NOT (Final^ IN CQuoteChar) THEN EXIT;
1040   - ExtractQuote (Final, SystemID, Final);
1041   - END
1042   - ELSE IF StrLComp (Start, 'PUBLIC', 6) = 0 THEN BEGIN
1043   - WHILE NOT (Final^ IN (CQuoteChar + [#0, '>', '['])) DO INC (Final);
1044   - IF NOT (Final^ IN CQuoteChar) THEN EXIT;
1045   - ExtractQuote (Final, PublicID, Final);
1046   - INC (Final);
1047   - WHILE NOT (Final^ IN (CQuoteChar + [#0, '>', '['])) DO INC (Final);
1048   - IF NOT (Final^ IN CQuoteChar) THEN EXIT;
1049   - ExtractQuote (Final, SystemID, Final);
1050   - END;
1051   -END;
1052   -
1053   -
1054   -(*
1055   -===============================================================================================
1056   -TXmlParser
1057   -===============================================================================================
1058   -*)
1059   -
1060   -CONSTRUCTOR TXmlParser.Create;
1061   -BEGIN
1062   - INHERITED Create;
1063   - FBuffer := NIL;
1064   - FBufferSize := 0;
1065   - Elements := TElemList.Create;
1066   - Entities := TNvpList.Create;
1067   - ParEntities := TNvpList.Create;
1068   - Notations := TNvpList.Create;
1069   - CurAttr := TAttrList.Create;
1070   - EntityStack := TEntityStack.Create (Self);
1071   - Clear;
1072   -END;
1073   -
1074   -
1075   -DESTRUCTOR TXmlParser.Destroy;
1076   -BEGIN
1077   - Clear;
1078   - Elements.Free;
1079   - Entities.Free;
1080   - ParEntities.Free;
1081   - Notations.Free;
1082   - CurAttr.Free;
1083   - EntityStack.Free;
1084   - INHERITED Destroy;
1085   -END;
1086   -
1087   -
1088   -PROCEDURE TXmlParser.Clear;
1089   - // Free Buffer and clear all object attributes
1090   -BEGIN
1091   - IF (FBufferSize > 0) AND (FBuffer <> NIL) THEN
1092   - FreeMem (FBuffer);
1093   - FBuffer := NIL;
1094   - FBufferSize := 0;
1095   - FSource := '';
1096   - FXmlVersion := '';
1097   - FEncoding := '';
1098   - FStandalone := FALSE;
1099   - FRootName := '';
1100   - FDtdcFinal := NIL;
1101   - FNormalize := TRUE;
1102   - Elements.Clear;
1103   - Entities.Clear;
1104   - ParEntities.Clear;
1105   - Notations.Clear;
1106   - CurAttr.Clear;
1107   - EntityStack.Clear;
1108   -END;
1109   -
1110   -
1111   -FUNCTION TXmlParser.LoadFromFile (Filename : STRING; FileMode : INTEGER = fmOpenRead OR fmShareDenyNone) : BOOLEAN;
1112   - // Loads Document from given file
1113   - // Returns TRUE if successful
1114   -VAR
1115   - f : FILE;
1116   - ReadIn : INTEGER;
1117   - OldFileMode : INTEGER;
1118   -BEGIN
1119   - Result := FALSE;
1120   - Clear;
1121   -
1122   - // --- Open File
1123   - OldFileMode := SYSTEM.FileMode;
1124   - TRY
1125   - SYSTEM.FileMode := FileMode;
1126   - TRY
1127   - AssignFile (f, Filename);
1128   - Reset (f, 1);
1129   - EXCEPT
1130   - EXIT;
1131   - END;
1132   -
1133   - TRY
1134   - // --- Allocate Memory
1135   - TRY
1136   - FBufferSize := Filesize (f) + 1;
1137   - GetMem (FBuffer, FBufferSize);
1138   - EXCEPT
1139   - Clear;
1140   - EXIT;
1141   - END;
1142   -
1143   - // --- Read File
1144   - TRY
1145   - BlockRead (f, FBuffer^, FBufferSize, ReadIn);
1146   - (FBuffer+ReadIn)^ := #0; // NULL termination
1147   - EXCEPT
1148   - Clear;
1149   - EXIT;
1150   - END;
1151   - FINALLY
1152   - CloseFile (f);
1153   - END;
1154   -
1155   - FSource := Filename;
1156   - Result := TRUE;
1157   -
1158   - FINALLY
1159   - SYSTEM.FileMode := OldFileMode;
1160   - END;
1161   -END;
1162   -
1163   -
1164   -FUNCTION TXmlParser.LoadFromBuffer (Buffer : PChar) : BOOLEAN;
1165   - // Loads Document from another buffer
1166   - // Returns TRUE if successful
1167   - // The "Source" property becomes '<MEM>' if successful
1168   -BEGIN
1169   - Result := FALSE;
1170   - Clear;
1171   - FBufferSize := StrLen (Buffer) + 1;
1172   - TRY
1173   - GetMem (FBuffer, FBufferSize);
1174   - EXCEPT
1175   - Clear;
1176   - EXIT;
1177   - END;
1178   - StrCopy (FBuffer, Buffer);
1179   - FSource := '<MEM>';
1180   - Result := TRUE;
1181   -END;
1182   -
1183   -
1184   -PROCEDURE TXmlParser.SetBuffer (Buffer : PChar); // References another buffer
1185   -BEGIN
1186   - Clear;
1187   - FBuffer := Buffer;
1188   - FBufferSize := 0;
1189   - FSource := '<REFERENCE>';
1190   -END;
1191   -
1192   -
1193   -//-----------------------------------------------------------------------------------------------
1194   -// Scanning through the document
1195   -//-----------------------------------------------------------------------------------------------
1196   -
1197   -PROCEDURE TXmlParser.StartScan;
1198   -BEGIN
1199   - CurPartType := ptNone;
1200   - CurName := '';
1201   - CurContent := '';
1202   - CurStart := NIL;
1203   - CurFinal := NIL;
1204   - CurAttr.Clear;
1205   - EntityStack.Clear;
1206   -END;
1207   -
1208   -
1209   -FUNCTION TXmlParser.Scan : BOOLEAN;
1210   - // Scans the next Part
1211   - // Returns TRUE if a part could be found, FALSE if there is no part any more
1212   - //
1213   - // "IsDone" can be set to FALSE by AnalyzeText in order to go to the next part
1214   - // if there is no Content due to normalization
1215   -VAR
1216   - IsDone : BOOLEAN;
1217   -BEGIN
1218   - REPEAT
1219   - IsDone := TRUE;
1220   -
1221   - // --- Start of next Part
1222   - IF CurStart = NIL
1223   - THEN CurStart := DocBuffer
1224   - ELSE CurStart := CurFinal+1;
1225   - CurFinal := CurStart;
1226   -
1227   - // --- End of Document of Pop off a new part from the Entity stack?
1228   - IF CurStart^ = #0 THEN
1229   - CurStart := EntityStack.Pop;
1230   -
1231   - // --- No Document or End Of Document: Terminate Scan
1232   - IF (CurStart = NIL) OR (CurStart^ = #0) THEN BEGIN
1233   - CurStart := StrEnd (DocBuffer);
1234   - CurFinal := CurStart-1;
1235   - EntityStack.Clear;
1236   - Result := FALSE;
1237   - EXIT;
1238   - END;
1239   -
1240   - IF (StrLComp (CurStart, '<?xml', 5) = 0) AND
1241   - ((CurStart+5)^ IN CWhitespace) THEN AnalyzeProlog // XML Declaration, Text Declaration
1242   - ELSE IF StrLComp (CurStart, '<?', 2) = 0 THEN AnalyzePI (CurStart, CurFinal) // PI
1243   - ELSE IF StrLComp (CurStart, '<!--', 4) = 0 THEN AnalyzeComment (CurStart, CurFinal) // Comment
1244   - ELSE IF StrLComp (CurStart, '<!DOCTYPE', 9) = 0 THEN AnalyzeDtdc // DTDc
1245   - ELSE IF StrLComp (CurStart, CDStart, Length (CDStart)) = 0 THEN AnalyzeCdata // CDATA Section
1246   - ELSE IF StrLComp (CurStart, '<', 1) = 0 THEN AnalyzeTag // Start-Tag, End-Tag, Empty-Element-Tag
1247   - ELSE AnalyzeText (IsDone); // Text Content
1248   - UNTIL IsDone;
1249   - Result := TRUE;
1250   -END;
1251   -
1252   -
1253   -PROCEDURE TXmlParser.AnalyzeProlog;
1254   - // Analyze XML Prolog or Text Declaration
1255   -VAR
1256   - F : PChar;
1257   -BEGIN
1258   - CurAttr.Analyze (CurStart+5, F);
1259   - IF EntityStack.Count = 0 THEN BEGIN
1260   - FXmlVersion := CurAttr.Value ('version');
1261   - FEncoding := CurAttr.Value ('encoding');
1262   - FStandalone := CurAttr.Value ('standalone') = 'yes';
1263   - END;
1264   - CurFinal := StrPos (F, '?>');
1265   - IF CurFinal <> NIL
1266   - THEN INC (CurFinal)
1267   - ELSE CurFinal := StrEnd (CurStart)-1;
1268   - FCurEncoding := AnsiUpperCase (CurAttr.Value ('encoding'));
1269   - IF FCurEncoding = '' THEN
1270   - FCurEncoding := 'UTF-8'; // Default XML Encoding is UTF-8
1271   - CurPartType := ptXmlProlog;
1272   - CurName := '';
1273   - CurContent := '';
1274   -END;
1275   -
1276   -
1277   -PROCEDURE TXmlParser.AnalyzeComment (Start : PChar; VAR Final : PChar);
1278   - // Analyze Comments
1279   -BEGIN
1280   - Final := StrPos (Start+4, '-->');
1281   - IF Final = NIL
1282   - THEN Final := StrEnd (Start)-1
1283   - ELSE INC (Final, 2);
1284   - CurPartType := ptComment;
1285   -END;
1286   -
1287   -
1288   -PROCEDURE TXmlParser.AnalyzePI (Start : PChar; VAR Final : PChar);
1289   - // Analyze Processing Instructions (PI)
1290   - // This is also called for Character
1291   -VAR
1292   - F : PChar;
1293   -BEGIN
1294   - CurPartType := ptPI;
1295   - Final := StrPos (Start+2, '?>');
1296   - IF Final = NIL
1297   - THEN Final := StrEnd (Start)-1
1298   - ELSE INC (Final);
1299   - ExtractName (Start+2, CWhitespace + ['?', '>'], F);
1300   - SetStringSF (CurName, Start+2, F);
1301   - SetStringSF (CurContent, F+1, Final-2);
1302   - CurAttr.Analyze (F+1, F);
1303   -END;
1304   -
1305   -
1306   -PROCEDURE TXmlParser.AnalyzeDtdc;
1307   - (* Analyze Document Type Declaration
1308   - doctypedecl ::= '<!DOCTYPE' S Name (S ExternalID)? S? ('[' (markupdecl | PEReference | S)* ']' S?)? '>'
1309   - markupdecl ::= elementdecl | AttlistDecl | EntityDecl | NotationDecl | PI | Comment
1310   - PEReference ::= '%' Name ';'
1311   -
1312   - elementdecl ::= '<!ELEMENT' S Name S contentspec S? '>'
1313   - AttlistDecl ::= '<!ATTLIST' S Name AttDef* S? '>'
1314   - EntityDecl ::= '<!ENTITY' S Name S EntityDef S? '>' |
1315   - '<!ENTITY' S '%' S Name S PEDef S? '>'
1316   - NotationDecl ::= '<!NOTATION' S Name S (ExternalID | PublicID) S? '>'
1317   - PI ::= '<?' PITarget (S (Char* - (Char* '?>' Char* )))? '?>'
1318   - Comment ::= '<!--' ((Char - '-') | ('-' (Char - '-')))* '-->' *)
1319   -TYPE
1320   - TPhase = (phName, phDtd, phInternal, phFinishing);
1321   -VAR
1322   - Phase : TPhase;
1323   - F : PChar;
1324   - ExternalID : TExternalID;
1325   - ExternalDTD : TXmlParser;
1326   - DER : TDtdElementRec;
1327   -BEGIN
1328   - DER.Start := CurStart;
1329   - EntityStack.Clear; // Clear stack for Parameter Entities
1330   - CurPartType := ptDtdc;
1331   -
1332   - // --- Don't read DTDc twice
1333   - IF FDtdcFinal <> NIL THEN BEGIN
1334   - CurFinal := FDtdcFinal;
1335   - EXIT;
1336   - END;
1337   -
1338   - // --- Scan DTDc
1339   - CurFinal := CurStart + 9; // First char after '<!DOCTYPE'
1340   - Phase := phName;
1341   - REPEAT
1342   - CASE CurFinal^ OF
1343   - '%' : BEGIN
1344   - PushPE (CurFinal);
1345   - CONTINUE;
1346   - END;
1347   - #0 : IF EntityStack.Count = 0 THEN
1348   - BREAK
1349   - ELSE BEGIN
1350   - CurFinal := EntityStack.Pop;
1351   - CONTINUE;
1352   - END;
1353   - '[' : BEGIN
1354   - Phase := phInternal;
1355   - AnalyzeDtdElements (CurFinal+1, CurFinal);
1356   - CONTINUE;
1357   - END;
1358   - ']' : Phase := phFinishing;
1359   - '>' : BREAK;
1360   - ELSE IF NOT (CurFinal^ IN CWhitespace) THEN BEGIN
1361   - CASE Phase OF
1362   - phName : IF (CurFinal^ IN CNameStart) THEN BEGIN
1363   - ExtractName (CurFinal, CWhitespace + ['[', '>'], F);
1364   - SetStringSF (FRootName, CurFinal, F);
1365   - CurFinal := F;
1366   - Phase := phDtd;
1367   - END;
1368   - phDtd : IF (StrLComp (CurFinal, 'SYSTEM', 6) = 0) OR
1369   - (StrLComp (CurFinal, 'PUBLIC', 6) = 0) THEN BEGIN
1370   - ExternalID := TExternalID.Create (CurFinal);
1371   - ExternalDTD := LoadExternalEntity (ExternalId.SystemId, ExternalID.PublicId, '');
1372   - F := StrPos (ExternalDtd.DocBuffer, '<!');
1373   - IF F <> NIL THEN
1374   - AnalyzeDtdElements (F, F);
1375   - ExternalDTD.Free;
1376   - CurFinal := ExternalID.Final;
1377   - ExternalID.Free;
1378   - END;
1379   - ELSE BEGIN
1380   - DER.ElementType := deError;
1381   - DER.Pos := CurFinal;
1382   - DER.Final := CurFinal;
1383   - DtdElementFound (DER);
1384   - END;
1385   - END;
1386   -
1387   - END;
1388   - END;
1389   - INC (CurFinal);
1390   - UNTIL FALSE;
1391   -
1392   - CurPartType := ptDtdc;
1393   - CurName := '';
1394   - CurContent := '';
1395   -
1396   - // It is an error in the document if "EntityStack" is not empty now
1397   - IF EntityStack.Count > 0 THEN BEGIN
1398   - DER.ElementType := deError;
1399   - DER.Final := CurFinal;
1400   - DER.Pos := CurFinal;
1401   - DtdElementFound (DER);
1402   - END;
1403   -
1404   - EntityStack.Clear; // Clear stack for General Entities
1405   - FDtdcFinal := CurFinal;
1406   -END;
1407   -
1408   -
1409   -PROCEDURE TXmlParser.AnalyzeDtdElements (Start : PChar; VAR Final : PChar);
1410   - // Analyze the "Elements" of a DTD contained in the external or
1411   - // internal DTD subset.
1412   -VAR
1413   - DER : TDtdElementRec;
1414   -BEGIN
1415   - Final := Start;
1416   - REPEAT
1417   - CASE Final^ OF
1418   - '%' : BEGIN
1419   - PushPE (Final);
1420   - CONTINUE;
1421   - END;
1422   - #0 : IF EntityStack.Count = 0 THEN
1423   - BREAK
1424   - ELSE BEGIN
1425   - CurFinal := EntityStack.Pop;
1426   - CONTINUE;
1427   - END;
1428   - ']',
1429   - '>' : BREAK;
1430   - '<' : IF StrLComp (Final, '<!ELEMENT', 9) = 0 THEN AnalyzeElementDecl (Final, Final)
1431   - ELSE IF StrLComp (Final, '<!ATTLIST', 9) = 0 THEN AnalyzeAttListDecl (Final, Final)
1432   - ELSE IF StrLComp (Final, '<!ENTITY', 8) = 0 THEN AnalyzeEntityDecl (Final, Final)
1433   - ELSE IF StrLComp (Final, '<!NOTATION', 10) = 0 THEN AnalyzeNotationDecl (Final, Final)
1434   - ELSE IF StrLComp (Final, '<?', 2) = 0 THEN BEGIN // PI in DTD
1435   - DER.ElementType := dePI;
1436   - DER.Start := Final;
1437   - AnalyzePI (Final, Final);
1438   - DER.Target := PChar (CurName);
1439   - DER.Content := PChar (CurContent);
1440   - DER.AttrList := CurAttr;
1441   - DER.Final := Final;
1442   - DtdElementFound (DER);
1443   - END
1444   - ELSE IF StrLComp (Final, '<!--', 4) = 0 THEN BEGIN // Comment in DTD
1445   - DER.ElementType := deComment;
1446   - DER.Start := Final;
1447   - AnalyzeComment (Final, Final);
1448   - DER.Final := Final;
1449   - DtdElementFound (DER);
1450   - END
1451   - ELSE BEGIN
1452   - DER.ElementType := deError;
1453   - DER.Start := Final;
1454   - DER.Pos := Final;
1455   - DER.Final := Final;
1456   - DtdElementFound (DER);
1457   - END;
1458   -
1459   - END;
1460   - INC (Final);
1461   - UNTIL FALSE;
1462   -END;
1463   -
1464   -
1465   -PROCEDURE TXmlParser.AnalyzeTag;
1466   - // Analyze Tags
1467   -VAR
1468   - S, F : PChar;
1469   - Attr : TAttr;
1470   - ElemDef : TElemDef;
1471   - AttrDef : TAttrDef;
1472   - I : INTEGER;
1473   -BEGIN
1474   - CurPartType := ptStartTag;
1475   - S := CurStart+1;
1476   - IF S^ = '/' THEN BEGIN
1477   - CurPartType := ptEndTag;
1478   - INC (S);
1479   - END;
1480   - ExtractName (S, CWhitespace + ['/'], F);
1481   - SetStringSF (CurName, S, F);
1482   - CurAttr.Analyze (F+1, CurFinal);
1483   - IF CurFinal^ = '/' THEN BEGIN
1484   - CurPartType := ptEmptyTag;
1485   - END;
1486   - CurFinal := StrScanE (CurFinal, '>');
1487   -
1488   - // --- Set Default Attribute values for nonexistent attributes
1489   - IF (CurPartType = ptStartTag) OR (CurPartType = ptEmptyTag) THEN BEGIN
1490   - ElemDef := Elements.Node (CurName);
1491   - IF ElemDef <> NIL THEN BEGIN
1492   - FOR I := 0 TO ElemDef.Count-1 DO BEGIN
1493   - AttrDef := TAttrDef (ElemDef [I]);
1494   - Attr := TAttr (CurAttr.Node (AttrDef.Name));
1495   - IF (Attr = NIL) AND (AttrDef.Value <> '') THEN BEGIN
1496   - Attr := TAttr.Create (AttrDef.Name, AttrDef.Value);
1497   - Attr.ValueType := vtDefault;
1498   - CurAttr.Add (Attr);
1499   - END;
1500   - IF Attr <> NIL THEN BEGIN
1501   - CASE AttrDef.DefaultType OF
1502   - adDefault : ;
1503   - adRequired : ; // -!- It is an error in the document if "Attr.Value" is an empty string
1504   - adImplied : Attr.ValueType := vtImplied;
1505   - adFixed : BEGIN
1506   - Attr.ValueType := vtFixed;
1507   - Attr.Value := AttrDef.Value;
1508   - END;
1509   - END;
1510   - Attr.AttrType := AttrDef.AttrType;
1511   - END;
1512   - END;
1513   - END;
1514   -
1515   - // --- Normalize Attribute Values. XmlSpec:
1516   - // - a character reference is processed by appending the referenced character to the attribute value
1517   - // - an entity reference is processed by recursively processing the replacement text of the entity
1518   - // - a whitespace character (#x20, #xD, #xA, #x9) is processed by appending #x20 to the normalized value,
1519   - // except that only a single #x20 is appended for a "#xD#xA" sequence that is part of an external
1520   - // parsed entity or the literal entity value of an internal parsed entity
1521   - // - other characters are processed by appending them to the normalized value
1522   - // If the declared value is not CDATA, then the XML processor must further process the
1523   - // normalized attribute value by discarding any leading and trailing space (#x20) characters,
1524   - // and by replacing sequences of space (#x20) characters by a single space (#x20) character.
1525   - // All attributes for which no declaration has been read should be treated by a
1526   - // non-validating parser as if declared CDATA.
1527   - // !!! The XML 1.0 SE specification is somewhat different here
1528   - // This code does not conform exactly to this specification
1529   - FOR I := 0 TO CurAttr.Count-1 DO
1530   - WITH TAttr (CurAttr [I]) DO BEGIN
1531   - ReplaceGeneralEntities (Value);
1532   - ReplaceCharacterEntities (Value);
1533   - IF (AttrType <> atCData) AND (AttrType <> atUnknown)
1534   - THEN Value := TranslateEncoding (TrimWs (ConvertWs (Value, TRUE)))
1535   - ELSE Value := TranslateEncoding (ConvertWs (Value, FALSE));
1536   - END;
1537   - END;
1538   -END;
1539   -
1540   -
1541   -PROCEDURE TXmlParser.AnalyzeCData;
1542   - // Analyze CDATA Sections
1543   -BEGIN
1544   - CurPartType := ptCData;
1545   - CurFinal := StrPos (CurStart, CDEnd);
1546   - IF CurFinal = NIL THEN BEGIN
1547   - CurFinal := StrEnd (CurStart)-1;
1548   - CurContent := TranslateEncoding (StrPas (CurStart+Length (CDStart)));
1549   - END
1550   - ELSE BEGIN
1551   - SetStringSF (CurContent, CurStart+Length (CDStart), CurFinal-1);
1552   - INC (CurFinal, Length (CDEnd)-1);
1553   - CurContent := TranslateEncoding (CurContent);
1554   - END;
1555   -END;
1556   -
1557   -
1558   -PROCEDURE TXmlParser.AnalyzeText (VAR IsDone : BOOLEAN);
1559   - (* Analyzes Text Content between Tags. CurFinal will point to the last content character.
1560   - Content ends at a '<' character or at the end of the document.
1561   - Entity References and Character Entity references are resolved.
1562   - If PackSpaces is TRUE, contiguous Whitespace Characters will be compressed to
1563   - one Space #x20 character, Whitespace at the beginning and end of content will
1564   - be trimmed off and content which is or becomes empty is not returned to
1565   - the application (in this case, "IsDone" is set to FALSE which causes the
1566   - Scan method to proceed directly to the next part. *)
1567   -
1568   - PROCEDURE ProcessEntity;
1569   - (* Is called if there is an ampsersand '&' character found in the document.
1570   - IN "CurFinal" points to the ampersand
1571   - OUT "CurFinal" points to the first character after the semi-colon ';' *)
1572   - VAR
1573   - P : PChar;
1574   - Name : STRING;
1575   - EntityDef : TEntityDef;
1576   - ExternalEntity : TXmlParser;
1577   - BEGIN
1578   - P := StrScan (CurFinal , ';');
1579   - IF P <> NIL THEN BEGIN
1580   - SetStringSF (Name, CurFinal+1, P-1);
1581   -
1582   - // Is it a Character Entity?
1583   - IF (CurFinal+1)^ = '#' THEN BEGIN
1584   - IF UpCase ((CurFinal+2)^) = 'X' // !!! Can't use "CHR" for Unicode characters > 255:
1585   - THEN CurContent := CurContent + CHR (StrToIntDef ('$'+Copy (Name, 3, MaxInt), 32))
1586   - ELSE CurContent := CurContent + CHR (StrToIntDef (Copy (Name, 2, MaxInt), 32));
1587   - CurFinal := P+1;
1588   - EXIT;
1589   - END
1590   -
1591   - // Is it a Predefined Entity?
1592   - ELSE IF Name = 'lt' THEN BEGIN CurContent := CurContent + '<'; CurFinal := P+1; EXIT; END
1593   - ELSE IF Name = 'gt' THEN BEGIN CurContent := CurContent + '>'; CurFinal := P+1; EXIT; END
1594   - ELSE IF Name = 'amp' THEN BEGIN CurContent := CurContent + '&'; CurFinal := P+1; EXIT; END
1595   - ELSE IF Name = 'apos' THEN BEGIN CurContent := CurContent + ''''; CurFinal := P+1; EXIT; END
1596   - ELSE IF Name = 'quot' THEN BEGIN CurContent := CurContent + '"'; CurFinal := P+1; EXIT; END;
1597   -
1598   - // Replace with Entity from DTD
1599   - EntityDef := TEntityDef (Entities.Node (Name));
1600   - IF EntityDef <> NIL THEN BEGIN
1601   - IF EntityDef.Value <> '' THEN BEGIN
1602   - EntityStack.Push (P+1);
1603   - CurFinal := PChar (EntityDef.Value);
1604   - END
1605   - ELSE BEGIN
1606   - ExternalEntity := LoadExternalEntity (EntityDef.SystemId, EntityDef.PublicId, EntityDef.NotationName);
1607   - EntityStack.Push (ExternalEntity, P+1);
1608   - CurFinal := ExternalEntity.DocBuffer;
1609   - END;
1610   - END
1611   - ELSE BEGIN
1612   - CurContent := CurContent + Name;
1613   - CurFinal := P+1;
1614   - END;
1615   - END
1616   - ELSE BEGIN
1617   - INC (CurFinal);
1618   - END;
1619   - END;
1620   -
1621   -VAR
1622   - C : INTEGER;
1623   -BEGIN
1624   - CurFinal := CurStart;
1625   - CurPartType := ptContent;
1626   - CurContent := '';
1627   - C := 0;
1628   - REPEAT
1629   - CASE CurFinal^ OF
1630   - '&' : BEGIN
1631   - CurContent := CurContent + TranslateEncoding (StrLPas (CurFinal-C, C));
1632   - C := 0;
1633   - ProcessEntity;
1634   - CONTINUE;
1635   - END;
1636   - #0 : BEGIN
1637   - IF EntityStack.Count = 0 THEN
1638   - BREAK
1639   - ELSE BEGIN
1640   - CurContent := CurContent + TranslateEncoding (StrLPas (CurFinal-C, C));
1641   - C := 0;
1642   - CurFinal := EntityStack.Pop;
1643   - CONTINUE;
1644   - END;
1645   - END;
1646   - '<' : BREAK;
1647   - ELSE INC (C);
1648   - END;
1649   - INC (CurFinal);
1650   - UNTIL FALSE;
1651   - CurContent := CurContent + TranslateEncoding (StrLPas (CurFinal-C, C));
1652   - DEC (CurFinal);
1653   -
1654   - IF FNormalize THEN BEGIN
1655   - CurContent := ConvertWs (TrimWs (CurContent), TRUE);
1656   - IsDone := CurContent <> ''; // IsDone will only get FALSE if PackSpaces is TRUE
1657   - END;
1658   -END;
1659   -
1660   -
1661   -PROCEDURE TXmlParser.AnalyzeElementDecl (Start : PChar; VAR Final : PChar);
1662   - (* Parse <!ELEMENT declaration starting at "Start"
1663   - Final must point to the terminating '>' character
1664   - XmlSpec 3.2:
1665   - elementdecl ::= '<!ELEMENT' S Name S contentspec S? '>'
1666   - contentspec ::= 'EMPTY' | 'ANY' | Mixed | children
1667   - Mixed ::= '(' S? '#PCDATA' (S? '|' S? Name)* S? ')*' |
1668   - '(' S? '#PCDATA' S? ')'
1669   - children ::= (choice | seq) ('?' | '*' | '+')?
1670   - choice ::= '(' S? cp ( S? '|' S? cp )* S? ')'
1671   - cp ::= (Name | choice | seq) ('?' | '*' | '+')?
1672   - seq ::= '(' S? cp ( S? ',' S? cp )* S? ')'
1673   -
1674   - More simply:
1675   - contentspec ::= EMPTY
1676   - ANY
1677   - '(#PCDATA)'
1678   - '(#PCDATA | A | B)*'
1679   - '(A, B, C)'
1680   - '(A | B | C)'
1681   - '(A?, B*, C+),
1682   - '(A, (B | C | D)* )' *)
1683   -VAR
1684   - Element : TElemDef;
1685   - Elem2 : TElemDef;
1686   - F : PChar;
1687   - DER : TDtdElementRec;
1688   -BEGIN
1689   - Element := TElemDef.Create;
1690   - Final := Start + 9;
1691   - DER.Start := Start;
1692   - REPEAT
1693   - IF Final^ = '>' THEN BREAK;
1694   - IF (Final^ IN CNameStart) AND (Element.Name = '') THEN BEGIN
1695   - ExtractName (Final, CWhitespace, F);
1696   - SetStringSF (Element.Name, Final, F);
1697   - Final := F;
1698   - F := StrScan (Final+1, '>');
1699   - IF F = NIL THEN BEGIN
1700   - Element.Definition := STRING (Final);
1701   - Final := StrEnd (Final);
1702   - BREAK;
1703   - END
1704   - ELSE BEGIN
1705   - SetStringSF (Element.Definition, Final+1, F-1);
1706   - Final := F;
1707   - BREAK;
1708   - END;
1709   - END;
1710   - INC (Final);
1711   - UNTIL FALSE;
1712   - Element.Definition := DelChars (Element.Definition, CWhitespace);
1713   - ReplaceParameterEntities (Element.Definition);
1714   - IF Element.Definition = 'EMPTY' THEN Element.ElemType := etEmpty
1715   - ELSE IF Element.Definition = 'ANY' THEN Element.ElemType := etAny
1716   - ELSE IF Copy (Element.Definition, 1, 8) = '(#PCDATA' THEN Element.ElemType := etMixed
1717   - ELSE IF Copy (Element.Definition, 1, 1) = '(' THEN Element.ElemType := etChildren
1718   - ELSE Element.ElemType := etAny;
1719   -
1720   - Elem2 := Elements.Node (Element.Name);
1721   - IF Elem2 <> NIL THEN
1722   - Elements.Delete (Elements.IndexOf (Elem2));
1723   - Elements.Add (Element);
1724   - Final := StrScanE (Final, '>');
1725   - DER.ElementType := deElement;
1726   - DER.ElemDef := Element;
1727   - DER.Final := Final;
1728   - DtdElementFound (DER);
1729   -END;
1730   -
1731   -
1732   -PROCEDURE TXmlParser.AnalyzeAttListDecl (Start : PChar; VAR Final : PChar);
1733   - (* Parse <!ATTLIST declaration starting at "Start"
1734   - Final must point to the terminating '>' character
1735   - XmlSpec 3.3:
1736   - AttlistDecl ::= '<!ATTLIST' S Name AttDef* S? '>'
1737   - AttDef ::= S Name S AttType S DefaultDecl
1738   - AttType ::= StringType | TokenizedType | EnumeratedType
1739   - StringType ::= 'CDATA'
1740   - TokenizedType ::= 'ID' | 'IDREF' | 'IDREFS' | 'ENTITY' | 'ENTITIES' | 'NMTOKEN' | 'NMTOKENS'
1741   - EnumeratedType ::= NotationType | Enumeration
1742   - NotationType ::= 'NOTATION' S '(' S? Name (S? '|' S? Name)* S? ')'
1743   - Enumeration ::= '(' S? Nmtoken (S? '|' S? Nmtoken)* S? ')'
1744   - DefaultDecl ::= '#REQUIRED' | '#IMPLIED' | (('#FIXED' S)? AttValue)
1745   - AttValue ::= '"' ([^<&"] | Reference)* '"' | "'" ([^<&'] | Reference)* "'"
1746   - Examples:
1747   - <!ATTLIST address
1748   - A1 CDATA "Default"
1749   - A2 ID #REQUIRED
1750   - A3 IDREF #IMPLIED
1751   - A4 IDREFS #IMPLIED
1752   - A5 ENTITY #FIXED "&at;&#252;"
1753   - A6 ENTITIES #REQUIRED
1754   - A7 NOTATION (WMF | DXF) "WMF"
1755   - A8 (A | B | C) #REQUIRED> *)
1756   -TYPE
1757   - TPhase = (phElementName, phName, phType, phNotationContent, phDefault);
1758   -VAR
1759   - Phase : TPhase;
1760   - F : PChar;
1761   - ElementName : STRING;
1762   - ElemDef : TElemDef;
1763   - AttrDef : TAttrDef;
1764   - AttrDef2 : TAttrDef;
1765   - Strg : STRING;
1766   - DER : TDtdElementRec;
1767   -BEGIN
1768   - Final := Start + 9; // The character after <!ATTLIST
1769   - Phase := phElementName;
1770   - DER.Start := Start;
1771   - AttrDef := NIL;
1772   - ElemDef := NIL;
1773   - REPEAT
1774   - IF NOT (Final^ IN CWhitespace) THEN
1775   - CASE Final^ OF
1776   - '%' : BEGIN
1777   - PushPE (Final);
1778   - CONTINUE;
1779   - END;
1780   - #0 : IF EntityStack.Count = 0 THEN
1781   - BREAK
1782   - ELSE BEGIN
1783   - Final := EntityStack.Pop;
1784   - CONTINUE;
1785   - END;
1786   - '>' : BREAK;
1787   - ELSE CASE Phase OF
1788   - phElementName : BEGIN
1789   - ExtractName (Final, CWhitespace + CQuoteChar + ['#'], F);
1790   - SetStringSF (ElementName, Final, F);
1791   - Final := F;
1792   - ElemDef := Elements.Node (ElementName);
1793   - IF ElemDef = NIL THEN BEGIN
1794   - ElemDef := TElemDef.Create;
1795   - ElemDef.Name := ElementName;
1796   - ElemDef.Definition := 'ANY';
1797   - ElemDef.ElemType := etAny;
1798   - Elements.Add (ElemDef);
1799   - END;
1800   - Phase := phName;
1801   - END;
1802   - phName : BEGIN
1803   - AttrDef := TAttrDef.Create;
1804   - ExtractName (Final, CWhitespace + CQuoteChar + ['#'], F);
1805   - SetStringSF (AttrDef.Name, Final, F);
1806   - Final := F;
1807   - AttrDef2 := TAttrDef (ElemDef.Node (AttrDef.Name));
1808   - IF AttrDef2 <> NIL THEN
1809   - ElemDef.Delete (ElemDef.IndexOf (AttrDef2));
1810   - ElemDef.Add (AttrDef);
1811   - Phase := phType;
1812   - END;
1813   - phType : BEGIN
1814   - IF Final^ = '(' THEN BEGIN
1815   - F := StrScan (Final+1, ')');
1816   - IF F <> NIL
1817   - THEN SetStringSF (AttrDef.TypeDef, Final+1, F-1)
1818   - ELSE AttrDef.TypeDef := STRING (Final+1);
1819   - AttrDef.TypeDef := DelChars (AttrDef.TypeDef, CWhitespace);
1820   - AttrDef.AttrType := atEnumeration;
1821   - ReplaceParameterEntities (AttrDef.TypeDef);
1822   - ReplaceCharacterEntities (AttrDef.TypeDef);
1823   - Phase := phDefault;
1824   - END
1825   - ELSE IF StrLComp (Final, 'NOTATION', 8) = 0 THEN BEGIN
1826   - INC (Final, 8);
1827   - AttrDef.AttrType := atNotation;
1828   - Phase := phNotationContent;
1829   - END
1830   - ELSE BEGIN
1831   - ExtractName (Final, CWhitespace+CQuoteChar+['#'], F);
1832   - SetStringSF (AttrDef.TypeDef, Final, F);
1833   - IF AttrDef.TypeDef = 'CDATA' THEN AttrDef.AttrType := atCData
1834   - ELSE IF AttrDef.TypeDef = 'ID' THEN AttrDef.AttrType := atId
1835   - ELSE IF AttrDef.TypeDef = 'IDREF' THEN AttrDef.AttrType := atIdRef
1836   - ELSE IF AttrDef.TypeDef = 'IDREFS' THEN AttrDef.AttrType := atIdRefs
1837   - ELSE IF AttrDef.TypeDef = 'ENTITY' THEN AttrDef.AttrType := atEntity
1838   - ELSE IF AttrDef.TypeDef = 'ENTITIES' THEN AttrDef.AttrType := atEntities
1839   - ELSE IF AttrDef.TypeDef = 'NMTOKEN' THEN AttrDef.AttrType := atNmToken
1840   - ELSE IF AttrDef.TypeDef = 'NMTOKENS' THEN AttrDef.AttrType := atNmTokens;
1841   - Phase := phDefault;
1842   - END
1843   - END;
1844   - phNotationContent : BEGIN
1845   - F := StrScan (Final, ')');
1846   - IF F <> NIL THEN
1847   - SetStringSF (AttrDef.Notations, Final+1, F-1)
1848   - ELSE BEGIN
1849   - AttrDef.Notations := STRING (Final+1);
1850   - Final := StrEnd (Final);
1851   - END;
1852   - ReplaceParameterEntities (AttrDef.Notations);
1853   - AttrDef.Notations := DelChars (AttrDef.Notations, CWhitespace);
1854   - Phase := phDefault;
1855   - END;
1856   - phDefault : BEGIN
1857   - IF Final^ = '#' THEN BEGIN
1858   - ExtractName (Final, CWhiteSpace + CQuoteChar, F);
1859   - SetStringSF (Strg, Final, F);
1860   - Final := F;
1861   - ReplaceParameterEntities (Strg);
1862   - IF Strg = '#REQUIRED' THEN BEGIN AttrDef.DefaultType := adRequired; Phase := phName; END
1863   - ELSE IF Strg = '#IMPLIED' THEN BEGIN AttrDef.DefaultType := adImplied; Phase := phName; END
1864   - ELSE IF Strg = '#FIXED' THEN AttrDef.DefaultType := adFixed;
1865   - END
1866   - ELSE IF (Final^ IN CQuoteChar) THEN BEGIN
1867   - ExtractQuote (Final, AttrDef.Value, Final);
1868   - ReplaceParameterEntities (AttrDef.Value);
1869   - ReplaceCharacterEntities (AttrDef.Value);
1870   - Phase := phName;
1871   - END;
1872   - IF Phase = phName THEN BEGIN
1873   - AttrDef := NIL;
1874   - END;
1875   - END;
1876   -
1877   - END;
1878   - END;
1879   - INC (Final);
1880   - UNTIL FALSE;
1881   -
1882   - Final := StrScan (Final, '>');
1883   -
1884   - DER.ElementType := deAttList;
1885   - DER.ElemDef := ElemDef;
1886   - DER.Final := Final;
1887   - DtdElementFound (DER);
1888   -END;
1889   -
1890   -
1891   -PROCEDURE TXmlParser.AnalyzeEntityDecl (Start : PChar; VAR Final : PChar);
1892   - (* Parse <!ENTITY declaration starting at "Start"
1893   - Final must point to the terminating '>' character
1894   - XmlSpec 4.2:
1895   - EntityDecl ::= '<!ENTITY' S Name S EntityDef S? '>' |
1896   - '<!ENTITY' S '%' S Name S PEDef S? '>'
1897   - EntityDef ::= EntityValue | (ExternalID NDataDecl?)
1898   - PEDef ::= EntityValue | ExternalID
1899   - NDataDecl ::= S 'NDATA' S Name
1900   - EntityValue ::= '"' ([^%&"] | PEReference | EntityRef | CharRef)* '"' |
1901   - "'" ([^%&'] | PEReference | EntityRef | CharRef)* "'"
1902   - PEReference ::= '%' Name ';'
1903   -
1904   - Examples
1905   - <!ENTITY test1 "Stefan Heymann"> <!-- Internal, general, parsed -->
1906   - <!ENTITY test2 SYSTEM "ent2.xml"> <!-- External, general, parsed -->
1907   - <!ENTITY test2 SYSTEM "ent3.gif" NDATA gif> <!-- External, general, unparsed -->
1908   - <!ENTITY % test3 "<!ELEMENT q ANY>"> <!-- Internal, parameter -->
1909   - <!ENTITY % test6 SYSTEM "ent6.xml"> <!-- External, parameter -->
1910   - <!ENTITY test4 "&test1; ist lieb"> <!-- IGP, Replacement text <> literal value -->
1911   - <!ENTITY test5 "<p>Dies ist ein Test-Absatz</p>"> <!-- IGP, See XmlSpec 2.4 -->
1912   - *)
1913   -TYPE
1914   - TPhase = (phName, phContent, phNData, phNotationName, phFinalGT);
1915   -VAR
1916   - Phase : TPhase;
1917   - IsParamEntity : BOOLEAN;
1918   - F : PChar;
1919   - ExternalID : TExternalID;
1920   - EntityDef : TEntityDef;
1921   - EntityDef2 : TEntityDef;
1922   - DER : TDtdElementRec;
1923   -BEGIN
1924   - Final := Start + 8; // First char after <!ENTITY
1925   - DER.Start := Start;
1926   - Phase := phName;
1927   - IsParamEntity := FALSE;
1928   - EntityDef := TEntityDef.Create;
1929   - REPEAT
1930   - IF NOT (Final^ IN CWhitespace) THEN
1931   - CASE Final^ OF
1932   - '%' : IsParamEntity := TRUE;
1933   - '>' : BREAK;
1934   - ELSE CASE Phase OF
1935   - phName : IF Final^ IN CNameStart THEN BEGIN
1936   - ExtractName (Final, CWhitespace + CQuoteChar, F);
1937   - SetStringSF (EntityDef.Name, Final, F);
1938   - Final := F;
1939   - Phase := phContent;
1940   - END;
1941   - phContent : IF Final^ IN CQuoteChar THEN BEGIN
1942   - ExtractQuote (Final, EntityDef.Value, Final);
1943   - Phase := phFinalGT;
1944   - END
1945   - ELSE IF (StrLComp (Final, 'SYSTEM', 6) = 0) OR
1946   - (StrLComp (Final, 'PUBLIC', 6) = 0) THEN BEGIN
1947   - ExternalID := TExternalID.Create (Final);
1948   - EntityDef.SystemId := ExternalID.SystemId;
1949   - EntityDef.PublicId := ExternalID.PublicId;
1950   - Final := ExternalID.Final;
1951   - Phase := phNData;
1952   - ExternalID.Free;
1953   - END;
1954   - phNData : IF StrLComp (Final, 'NDATA', 5) = 0 THEN BEGIN
1955   - INC (Final, 4);
1956   - Phase := phNotationName;
1957   - END;
1958   - phNotationName : IF Final^ IN CNameStart THEN BEGIN
1959   - ExtractName (Final, CWhitespace + ['>'], F);
1960   - SetStringSF (EntityDef.NotationName, Final, F);
1961   - Final := F;
1962   - Phase := phFinalGT;
1963   - END;
1964   - phFinalGT : ; // -!- There is an error in the document if this branch is called
1965   - END;
1966   - END;
1967   - INC (Final);
1968   - UNTIL FALSE;
1969   - IF IsParamEntity THEN BEGIN
1970   - EntityDef2 := TEntityDef (ParEntities.Node (EntityDef.Name));
1971   - IF EntityDef2 <> NIL THEN
1972   - ParEntities.Delete (ParEntities.IndexOf (EntityDef2));
1973   - ParEntities.Add (EntityDef);
1974   - ReplaceCharacterEntities (EntityDef.Value);
1975   - END
1976   - ELSE BEGIN
1977   - EntityDef2 := TEntityDef (Entities.Node (EntityDef.Name));
1978   - IF EntityDef2 <> NIL THEN
1979   - Entities.Delete (Entities.IndexOf (EntityDef2));
1980   - Entities.Add (EntityDef);
1981   - ReplaceParameterEntities (EntityDef.Value); // Create replacement texts (see XmlSpec 4.5)
1982   - ReplaceCharacterEntities (EntityDef.Value);
1983   - END;
1984   - Final := StrScanE (Final, '>');
1985   -
1986   - DER.ElementType := deEntity;
1987   - DER.EntityDef := EntityDef;
1988   - DER.Final := Final;
1989   - DtdElementFound (DER);
1990   -END;
1991   -
1992   -
1993   -PROCEDURE TXmlParser.AnalyzeNotationDecl (Start : PChar; VAR Final : PChar);
1994   - // Parse <!NOTATION declaration starting at "Start"
1995   - // Final must point to the terminating '>' character
1996   - // XmlSpec 4.7: NotationDecl ::= '<!NOTATION' S Name S (ExternalID | PublicID) S? '>'
1997   -TYPE
1998   - TPhase = (phName, phExtId, phEnd);
1999   -VAR
2000   - ExternalID : TExternalID;
2001   - Phase : TPhase;
2002   - F : PChar;
2003   - NotationDef : TNotationDef;
2004   - DER : TDtdElementRec;
2005   -BEGIN
2006   - Final := Start + 10; // Character after <!NOTATION
2007   - DER.Start := Start;
2008   - Phase := phName;
2009   - NotationDef := TNotationDef.Create;
2010   - REPEAT
2011   - IF NOT (Final^ IN CWhitespace) THEN
2012   - CASE Final^ OF
2013   - '>',
2014   - #0 : BREAK;
2015   - ELSE CASE Phase OF
2016   - phName : BEGIN
2017   - ExtractName (Final, CWhitespace + ['>'], F);
2018   - SetStringSF (NotationDef.Name, Final, F);
2019   - Final := F;
2020   - Phase := phExtId;
2021   - END;
2022   - phExtId : BEGIN
2023   - ExternalID := TExternalID.Create (Final);
2024   - NotationDef.Value := ExternalID.SystemId;
2025   - NotationDef.PublicId := ExternalID.PublicId;
2026   - Final := ExternalId.Final;
2027   - ExternalId.Free;
2028   - Phase := phEnd;
2029   - END;
2030   - phEnd : ; // -!- There is an error in the document if this branch is called
2031   - END;
2032   - END;
2033   - INC (Final);
2034   - UNTIL FALSE;
2035   - Notations.Add (NotationDef);
2036   - Final := StrScanE (Final, '>');
2037   -
2038   - DER.ElementType := deNotation;
2039   - DER.NotationDef := NotationDef;
2040   - DER.Final := Final;
2041   - DtdElementFound (DER);
2042   -END;
2043   -
2044   -
2045   -PROCEDURE TXmlParser.PushPE (VAR Start : PChar);
2046   - (* If there is a parameter entity reference found in the data stream,
2047   - the current position will be pushed to the entity stack.
2048   - Start: IN Pointer to the '%' character starting the PE reference
2049   - OUT Pointer to first character of PE replacement text *)
2050   -VAR
2051   - P : PChar;
2052   - EntityDef : TEntityDef;
2053   -BEGIN
2054   - P := StrScan (Start, ';');
2055   - IF P <> NIL THEN BEGIN
2056   - EntityDef := TEntityDef (ParEntities.Node (StrSFPas (Start+1, P-1)));
2057   - IF EntityDef <> NIL THEN BEGIN
2058   - EntityStack.Push (P+1);
2059   - Start := PChar (EntityDef.Value);
2060   - END
2061   - ELSE
2062   - Start := P+1;
2063   - END;
2064   -END;
2065   -
2066   -
2067   -PROCEDURE TXmlParser.ReplaceCharacterEntities (VAR Str : STRING);
2068   - // Replaces all Character Entity References in the String
2069   -VAR
2070   - Start : INTEGER;
2071   - PAmp : PChar;
2072   - PSemi : PChar;
2073   - PosAmp : INTEGER;
2074   - Len : INTEGER; // Length of Entity Reference
2075   -BEGIN
2076   - IF Str = '' THEN EXIT;
2077   - Start := 1;
2078   - REPEAT
2079   - PAmp := StrPos (PChar (Str) + Start-1, '&#');
2080   - IF PAmp = NIL THEN BREAK;
2081   - PSemi := StrScan (PAmp+2, ';');
2082   - IF PSemi = NIL THEN BREAK;
2083   - PosAmp := PAmp - PChar (Str) + 1;
2084   - Len := PSemi-PAmp+1;
2085   - IF CompareText (Str [PosAmp+2], 'x') = 0 // !!! Can't use "CHR" for Unicode characters > 255
2086   - THEN Str [PosAmp] := CHR (StrToIntDef ('$'+Copy (Str, PosAmp+3, Len-4), 0))
2087   - ELSE Str [PosAmp] := CHR (StrToIntDef (Copy (Str, PosAmp+2, Len-3), 32));
2088   - Delete (Str, PosAmp+1, Len-1);
2089   - Start := PosAmp + 1;
2090   - UNTIL FALSE;
2091   -END;
2092   -
2093   -
2094   -PROCEDURE TXmlParser.ReplaceParameterEntities (VAR Str : STRING);
2095   - // Recursively replaces all Parameter Entity References in the String
2096   - PROCEDURE ReplaceEntities (VAR Str : STRING);
2097   - VAR
2098   - Start : INTEGER;
2099   - PAmp : PChar;
2100   - PSemi : PChar;
2101   - PosAmp : INTEGER;
2102   - Len : INTEGER;
2103   - Entity : TEntityDef;
2104   - Repl : STRING; // Replacement
2105   - BEGIN
2106   - IF Str = '' THEN EXIT;
2107   - Start := 1;
2108   - REPEAT
2109   - PAmp := StrPos (PChar (Str)+Start-1, '%');
2110   - IF PAmp = NIL THEN BREAK;
2111   - PSemi := StrScan (PAmp+2, ';');
2112   - IF PSemi = NIL THEN BREAK;
2113   - PosAmp := PAmp - PChar (Str) + 1;
2114   - Len := PSemi-PAmp+1;
2115   - Entity := TEntityDef (ParEntities.Node (Copy (Str, PosAmp+1, Len-2)));
2116   - IF Entity <> NIL THEN BEGIN
2117   - Repl := Entity.Value;
2118   - ReplaceEntities (Repl); // Recursion
2119   - END
2120   - ELSE
2121   - Repl := Copy (Str, PosAmp, Len);
2122   - Delete (Str, PosAmp, Len);
2123   - Insert (Repl, Str, PosAmp);
2124   - Start := PosAmp + Length (Repl);
2125   - UNTIL FALSE;
2126   - END;
2127   -BEGIN
2128   - ReplaceEntities (Str);
2129   -END;
2130   -
2131   -
2132   -PROCEDURE TXmlParser.ReplaceGeneralEntities (VAR Str : STRING);
2133   - // Recursively replaces General Entity References in the String
2134   - PROCEDURE ReplaceEntities (VAR Str : STRING);
2135   - VAR
2136   - Start : INTEGER;
2137   - PAmp : PChar;
2138   - PSemi : PChar;
2139   - PosAmp : INTEGER;
2140   - Len : INTEGER;
2141   - EntityDef : TEntityDef;
2142   - EntName : STRING;
2143   - Repl : STRING; // Replacement
2144   - ExternalEntity : TXmlParser;
2145   - BEGIN
2146   - IF Str = '' THEN EXIT;
2147   - Start := 1;
2148   - REPEAT
2149   - PAmp := StrPos (PChar (Str)+Start-1, '&');
2150   - IF PAmp = NIL THEN BREAK;
2151   - PSemi := StrScan (PAmp+2, ';');
2152   - IF PSemi = NIL THEN BREAK;
2153   - PosAmp := PAmp - PChar (Str) + 1;
2154   - Len := PSemi-PAmp+1;
2155   - EntName := Copy (Str, PosAmp+1, Len-2);
2156   - IF EntName = 'lt' THEN Repl := '<'
2157   - ELSE IF EntName = 'gt' THEN Repl := '>'
2158   - ELSE IF EntName = 'amp' THEN Repl := '&'
2159   - ELSE IF EntName = 'apos' THEN Repl := ''''
2160   - ELSE IF EntName = 'quot' THEN Repl := '"'
2161   - ELSE BEGIN
2162   - EntityDef := TEntityDef (Entities.Node (EntName));
2163   - IF EntityDef <> NIL THEN BEGIN
2164   - IF EntityDef.Value <> '' THEN // Internal Entity
2165   - Repl := EntityDef.Value
2166   - ELSE BEGIN // External Entity
2167   - ExternalEntity := LoadExternalEntity (EntityDef.SystemId, EntityDef.PublicId, EntityDef.NotationName);
2168   - Repl := StrPas (ExternalEntity.DocBuffer); // !!! What if it contains a Text Declaration?
2169   - ExternalEntity.Free;
2170   - END;
2171   - ReplaceEntities (Repl); // Recursion
2172   - END
2173   - ELSE
2174   - Repl := Copy (Str, PosAmp, Len);
2175   - END;
2176   - Delete (Str, PosAmp, Len);
2177   - Insert (Repl, Str, PosAmp);
2178   - Start := PosAmp + Length (Repl);
2179   - UNTIL FALSE;
2180   - END;
2181   -BEGIN
2182   - ReplaceEntities (Str);
2183   -END;
2184   -
2185   -
2186   -FUNCTION TXmlParser.LoadExternalEntity (SystemId, PublicId, Notation : STRING) : TXmlParser;
2187   - // This will be called whenever there is a Parsed External Entity or
2188   - // the DTD External Subset to be parsed.
2189   - // It has to create a TXmlParser instance and load the desired Entity.
2190   - // This instance of LoadExternalEntity assumes that "SystemId" is a valid
2191   - // file name (relative to the Document source) and loads this file using
2192   - // the LoadFromFile method.
2193   -VAR
2194   - Filename : STRING;
2195   -BEGIN
2196   - // --- Convert System ID to complete filename
2197   - Filename := StringReplace (SystemId, '/', '\', [rfReplaceAll]);
2198   - IF Copy (FSource, 1, 1) <> '<' THEN
2199   - IF (Copy (Filename, 1, 2) = '\\') OR (Copy (Filename, 2, 1) = ':') THEN
2200   - // Already has an absolute Path
2201   - ELSE BEGIN
2202   - Filename := ExtractFilePath (FSource) + Filename;
2203   - END;
2204   -
2205   - // --- Load the File
2206   - Result := TXmlParser.Create;
2207   - Result.LoadFromFile (Filename);
2208   -END;
2209   -
2210   -
2211   -FUNCTION TXmlParser.TranslateEncoding (CONST Source : STRING) : STRING;
2212   - // The member variable "CurEncoding" always holds the name of the current
2213   - // encoding, e.g. 'UTF-8' or 'ISO-8859-1'.
2214   - // This virtual method "TranslateEncoding" is responsible for translating
2215   - // the content passed in the "Source" parameter to the Encoding which
2216   - // is expected by the application.
2217   - // This instance of "TranlateEncoding" assumes that the Application expects
2218   - // Windows ANSI (Win1252) strings. It is able to transform UTF-8 or ISO-8859-1
2219   - // encodings.
2220   - // If you want your application to understand or create other encodings, you
2221   - // override this function.
2222   -BEGIN
2223   - IF CurEncoding = 'UTF-8'
2224   - THEN Result := Utf8ToAnsi (Source)
2225   - ELSE Result := Source;
2226   -END;
2227   -
2228   -
2229   -PROCEDURE TXmlParser.DtdElementFound (DtdElementRec : TDtdElementRec);
2230   - // This method is called for every element which is found in the DTD
2231   - // declaration. The variant record TDtdElementRec is passed which
2232   - // holds informations about the element.
2233   - // You can override this function to handle DTD declarations.
2234   - // Note that when you parse the same Document instance a second time,
2235   - // the DTD will not get parsed again.
2236   -BEGIN
2237   -END;
2238   -
2239   -
2240   -FUNCTION TXmlParser.GetDocBuffer: PChar;
2241   - // Returns FBuffer or a pointer to a NUL char if Buffer is empty
2242   -BEGIN
2243   - IF FBuffer = NIL
2244   - THEN Result := #0
2245   - ELSE Result := FBuffer;
2246   -END;
2247   -
2248   -
2249   -(*$IFNDEF HAS_CONTNRS_UNIT
2250   -===============================================================================================
2251   -TObjectList
2252   -===============================================================================================
2253   -*)
2254   -
2255   -DESTRUCTOR TObjectList.Destroy;
2256   -BEGIN
2257   - Clear;
2258   - SetCapacity(0);
2259   - INHERITED Destroy;
2260   -END;
2261   -
2262   -
2263   -PROCEDURE TObjectList.Delete (Index : INTEGER);
2264   -BEGIN
2265   - IF (Index < 0) OR (Index >= Count) THEN EXIT;
2266   - TObject (Items [Index]).Free;
2267   - INHERITED Delete (Index);
2268   -END;
2269   -
2270   -
2271   -PROCEDURE TObjectList.Clear;
2272   -BEGIN
2273   - WHILE Count > 0 DO
2274   - Delete (Count-1);
2275   -END;
2276   -
2277   -(*$ENDIF *)
2278   -
2279   -(*
2280   -===============================================================================================
2281   -TNvpNode
2282   ---------
2283   -Node base class for the TNvpList
2284   -===============================================================================================
2285   -*)
2286   -
2287   -CONSTRUCTOR TNvpNode.Create (TheName, TheValue : STRING);
2288   -BEGIN
2289   - INHERITED Create;
2290   - Name := TheName;
2291   - Value := TheValue;
2292   -END;
2293   -
2294   -
2295   -(*
2296   -===============================================================================================
2297   -TNvpList
2298   ---------
2299   -A generic List of Name-Value Pairs, based on the TObjectList introduced in Delphi 5
2300   -===============================================================================================
2301   -*)
2302   -
2303   -PROCEDURE TNvpList.Add (Node : TNvpNode);
2304   -VAR
2305   - I : INTEGER;
2306   -BEGIN
2307   - FOR I := Count-1 DOWNTO 0 DO
2308   - IF Node.Name > TNvpNode (Items [I]).Name THEN BEGIN
2309   - Insert (I+1, Node);
2310   - EXIT;
2311   - END;
2312   - Insert (0, Node);
2313   -END;
2314   -
2315   -
2316   -
2317   -FUNCTION TNvpList.Node (Name : STRING) : TNvpNode;
2318   - // Binary search for Node
2319   -VAR
2320   - L, H : INTEGER; // Low, High Limit
2321   - T, C : INTEGER; // Test Index, Comparison result
2322   - Last : INTEGER; // Last Test Index
2323   -BEGIN
2324   - IF Count=0 THEN BEGIN
2325   - Result := NIL;
2326   - EXIT;
2327   - END;
2328   -
2329   - L := 0;
2330   - H := Count;
2331   - Last := -1;
2332   - REPEAT
2333   - T := (L+H) DIV 2;
2334   - IF T=Last THEN BREAK;
2335   - Result := TNvpNode (Items [T]);
2336   - C := CompareStr (Result.Name, Name);
2337   - IF C = 0 THEN EXIT
2338   - ELSE IF C < 0 THEN L := T
2339   - ELSE H := T;
2340   - Last := T;
2341   - UNTIL FALSE;
2342   - Result := NIL;
2343   -END;
2344   -
2345   -
2346   -FUNCTION TNvpList.Node (Index : INTEGER) : TNvpNode;
2347   -BEGIN
2348   - IF (Index < 0) OR (Index >= Count)
2349   - THEN Result := NIL
2350   - ELSE Result := TNvpNode (Items [Index]);
2351   -END;
2352   -
2353   -
2354   -FUNCTION TNvpList.Value (Name : STRING) : STRING;
2355   -VAR
2356   - Nvp : TNvpNode;
2357   -BEGIN
2358   - Nvp := TNvpNode (Node (Name));
2359   - IF Nvp <> NIL
2360   - THEN Result := Nvp.Value
2361   - ELSE Result := '';
2362   -END;
2363   -
2364   -
2365   -FUNCTION TNvpList.Value (Index : INTEGER) : STRING;
2366   -BEGIN
2367   - IF (Index < 0) OR (Index >= Count)
2368   - THEN Result := ''
2369   - ELSE Result := TNvpNode (Items [Index]).Value;
2370   -END;
2371   -
2372   -
2373   -FUNCTION TNvpList.Name (Index : INTEGER) : STRING;
2374   -BEGIN
2375   - IF (Index < 0) OR (Index >= Count)
2376   - THEN Result := ''
2377   - ELSE Result := TNvpNode (Items [Index]).Name;
2378   -END;
2379   -
2380   -
2381   -(*
2382   -===============================================================================================
2383   -TAttrList
2384   -List of Attributes. The "Analyze" method extracts the Attributes from the given Buffer.
2385   -Is used for extraction of Attributes in Start-Tags, Empty-Element Tags and the "pseudo"
2386   -attributes in XML Prologs, Text Declarations and PIs.
2387   -===============================================================================================
2388   -*)
2389   -
2390   -PROCEDURE TAttrList.Analyze (Start : PChar; VAR Final : PChar);
2391   - // Analyze the Buffer for Attribute=Name pairs.
2392   - // Terminates when there is a character which is not IN CNameStart
2393   - // (e.g. '?>' or '>' or '/>')
2394   -TYPE
2395   - TPhase = (phName, phEq, phValue);
2396   -VAR
2397   - Phase : TPhase;
2398   - F : PChar;
2399   - Name : STRING;
2400   - Value : STRING;
2401   - Attr : TAttr;
2402   -BEGIN
2403   - Clear;
2404   - Phase := phName;
2405   - Final := Start;
2406   - REPEAT
2407   - IF (Final^ = #0) OR (Final^ = '>') THEN BREAK;
2408   - IF NOT (Final^ IN CWhitespace) THEN
2409   - CASE Phase OF
2410   - phName : BEGIN
2411   - IF NOT (Final^ IN CNameStart) THEN EXIT;
2412   - ExtractName (Final, CWhitespace + ['=', '/'], F);
2413   - SetStringSF (Name, Final, F);
2414   - Final := F;
2415   - Phase := phEq;
2416   - END;
2417   - phEq : BEGIN
2418   - IF Final^ = '=' THEN
2419   - Phase := phValue
2420   - END;
2421   - phValue : BEGIN
2422   - IF Final^ IN CQuoteChar THEN BEGIN
2423   - ExtractQuote (Final, Value, F);
2424   - Attr := TAttr.Create;
2425   - Attr.Name := Name;
2426   - Attr.Value := Value;
2427   - Attr.ValueType := vtNormal;
2428   - Add (Attr);
2429   - Final := F;
2430   - Phase := phName;
2431   - END;
2432   - END;
2433   - END;
2434   - INC (Final);
2435   - UNTIL FALSE;
2436   -END;
2437   -
2438   -
2439   -(*
2440   -===============================================================================================
2441   -TElemList
2442   -List of TElemDef nodes.
2443   -===============================================================================================
2444   -*)
2445   -
2446   -FUNCTION TElemList.Node (Name : STRING) : TElemDef;
2447   - // Binary search for the Node with the given Name
2448   -VAR
2449   - L, H : INTEGER; // Low, High Limit
2450   - T, C : INTEGER; // Test Index, Comparison result
2451   - Last : INTEGER; // Last Test Index
2452   -BEGIN
2453   - IF Count=0 THEN BEGIN
2454   - Result := NIL;
2455   - EXIT;
2456   - END;
2457   -
2458   - L := 0;
2459   - H := Count;
2460   - Last := -1;
2461   - REPEAT
2462   - T := (L+H) DIV 2;
2463   - IF T=Last THEN BREAK;
2464   - Result := TElemDef (Items [T]);
2465   - C := CompareStr (Result.Name, Name);
2466   - IF C = 0 THEN EXIT
2467   - ELSE IF C < 0 THEN L := T
2468   - ELSE H := T;
2469   - Last := T;
2470   - UNTIL FALSE;
2471   - Result := NIL;
2472   -END;
2473   -
2474   -
2475   -PROCEDURE TElemList.Add (Node : TElemDef);
2476   -VAR
2477   - I : INTEGER;
2478   -BEGIN
2479   - FOR I := Count-1 DOWNTO 0 DO
2480   - IF Node.Name > TElemDef (Items [I]).Name THEN BEGIN
2481   - Insert (I+1, Node);
2482   - EXIT;
2483   - END;
2484   - Insert (0, Node);
2485   -END;
2486   -
2487   -
2488   -(*
2489   -===============================================================================================
2490   -TScannerXmlParser
2491   -A TXmlParser descendant for the TCustomXmlScanner component
2492   -===============================================================================================
2493   -*)
2494   -
2495   -TYPE
2496   - TScannerXmlParser = CLASS (TXmlParser)
2497   - Scanner : TCustomXmlScanner;
2498   - CONSTRUCTOR Create (TheScanner : TCustomXmlScanner);
2499   - FUNCTION LoadExternalEntity (SystemId, PublicId,
2500   - Notation : STRING) : TXmlParser; OVERRIDE;
2501   - FUNCTION TranslateEncoding (CONST Source : STRING) : STRING; OVERRIDE;
2502   - PROCEDURE DtdElementFound (DtdElementRec : TDtdElementRec); OVERRIDE;
2503   - END;
2504   -
2505   -CONSTRUCTOR TScannerXmlParser.Create (TheScanner : TCustomXmlScanner);
2506   -BEGIN
2507   - INHERITED Create;
2508   - Scanner := TheScanner;
2509   -END;
2510   -
2511   -
2512   -FUNCTION TScannerXmlParser.LoadExternalEntity (SystemId, PublicId, Notation : STRING) : TXmlParser;
2513   -BEGIN
2514   - IF Assigned (Scanner.FOnLoadExternal)
2515   - THEN Scanner.FOnLoadExternal (Scanner, SystemId, PublicId, Notation, Result)
2516   - ELSE Result := INHERITED LoadExternalEntity (SystemId, PublicId, Notation);
2517   -END;
2518   -
2519   -
2520   -FUNCTION TScannerXmlParser.TranslateEncoding (CONST Source : STRING) : STRING;
2521   -BEGIN
2522   - IF Assigned (Scanner.FOnTranslateEncoding)
2523   - THEN Result := Scanner.FOnTranslateEncoding (Scanner, CurEncoding, Source)
2524   - ELSE Result := INHERITED TranslateEncoding (Source);
2525   -END;
2526   -
2527   -
2528   -PROCEDURE TScannerXmlParser.DtdElementFound (DtdElementRec : TDtdElementRec);
2529   -BEGIN
2530   - WITH DtdElementRec DO
2531   - CASE ElementType OF
2532   - deElement : Scanner.WhenElement (ElemDef);
2533   - deAttList : Scanner.WhenAttList (ElemDef);
2534   - deEntity : Scanner.WhenEntity (EntityDef);
2535   - deNotation : Scanner.WhenNotation (NotationDef);
2536   - dePI : Scanner.WhenPI (STRING (Target), STRING (Content), AttrList);
2537   - deComment : Scanner.WhenComment (StrSFPas (Start, Final));
2538   - deError : Scanner.WhenDtdError (Pos);
2539   - END;
2540   -END;
2541   -
2542   -
2543   -(*
2544   -===============================================================================================
2545   -TCustomXmlScanner
2546   -===============================================================================================
2547   -*)
2548   -
2549   -CONSTRUCTOR TCustomXmlScanner.Create (AOwner: TComponent);
2550   -BEGIN
2551   - INHERITED;
2552   - FXmlParser := TScannerXmlParser.Create (Self);
2553   -END;
2554   -
2555   -
2556   -DESTRUCTOR TCustomXmlScanner.Destroy;
2557   -BEGIN
2558   - FXmlParser.Free;
2559   - INHERITED;
2560   -END;
2561   -
2562   -
2563   -PROCEDURE TCustomXmlScanner.LoadFromFile (Filename : TFilename);
2564   - // Load XML Document from file
2565   -BEGIN
2566   - FXmlParser.LoadFromFile (Filename);
2567   -END;
2568   -
2569   -
2570   -PROCEDURE TCustomXmlScanner.LoadFromBuffer (Buffer : PChar);
2571   - // Load XML Document from buffer
2572   -BEGIN
2573   - FXmlParser.LoadFromBuffer (Buffer);
2574   -END;
2575   -
2576   -
2577   -PROCEDURE TCustomXmlScanner.SetBuffer (Buffer : PChar);
2578   - // Refer to Buffer
2579   -BEGIN
2580   - FXmlParser.SetBuffer (Buffer);
2581   -END;
2582   -
2583   -
2584   -FUNCTION TCustomXmlScanner.GetFilename : TFilename;
2585   -BEGIN
2586   - Result := FXmlParser.Source;
2587   -END;
2588   -
2589   -
2590   -FUNCTION TCustomXmlScanner.GetNormalize : BOOLEAN;
2591   -BEGIN
2592   - Result := FXmlParser.Normalize;
2593   -END;
2594   -
2595   -
2596   -PROCEDURE TCustomXmlScanner.SetNormalize (Value : BOOLEAN);
2597   -BEGIN
2598   - FXmlParser.Normalize := Value;
2599   -END;
2600   -
2601   -
2602   -PROCEDURE TCustomXmlScanner.WhenXmlProlog(XmlVersion, Encoding: STRING; Standalone : BOOLEAN);
2603   - // Is called when the parser has parsed the <? xml ?> declaration of the prolog
2604   -BEGIN
2605   - IF Assigned (FOnXmlProlog) THEN FOnXmlProlog (Self, XmlVersion, Encoding, Standalone);
2606   -END;
2607   -
2608   -
2609   -PROCEDURE TCustomXmlScanner.WhenComment (Comment : STRING);
2610   - // Is called when the parser has parsed a <!-- comment -->
2611   -BEGIN
2612   - IF Assigned (FOnComment) THEN FOnComment (Self, Comment);
2613   -END;
2614   -
2615   -
2616   -PROCEDURE TCustomXmlScanner.WhenPI (Target, Content: STRING; Attributes : TAttrList);
2617   - // Is called when the parser has parsed a <?processing instruction ?>
2618   -BEGIN
2619   - IF Assigned (FOnPI) THEN FOnPI (Self, Target, Content, Attributes);
2620   -END;
2621   -
2622   -
2623   -PROCEDURE TCustomXmlScanner.WhenDtdRead (RootElementName : STRING);
2624   - // Is called when the parser has completely parsed the DTD
2625   -BEGIN
2626   - IF Assigned (FOnDtdRead) THEN FOnDtdRead (Self, RootElementName);
2627   -END;
2628   -
2629   -
2630   -PROCEDURE TCustomXmlScanner.WhenStartTag (TagName : STRING; Attributes : TAttrList);
2631   - // Is called when the parser has parsed a start tag like <p>
2632   -BEGIN
2633   - IF Assigned (FOnStartTag) THEN FOnStartTag (Self, TagName, Attributes);
2634   -END;
2635   -
2636   -
2637   -PROCEDURE TCustomXmlScanner.WhenEmptyTag (TagName : STRING; Attributes : TAttrList);
2638   - // Is called when the parser has parsed an Empty Element Tag like <br/>
2639   -BEGIN
2640   - IF Assigned (FOnEmptyTag) THEN FOnEmptyTag (Self, TagName, Attributes);
2641   -END;
2642   -
2643   -
2644   -PROCEDURE TCustomXmlScanner.WhenEndTag (TagName : STRING);
2645   - // Is called when the parser has parsed an End Tag like </p>
2646   -BEGIN
2647   - IF Assigned (FOnEndTag) THEN FOnEndTag (Self, TagName);
2648   -END;
2649   -
2650   -
2651   -PROCEDURE TCustomXmlScanner.WhenContent (Content : STRING);
2652   - // Is called when the parser has parsed an element's text content
2653   -BEGIN
2654   - IF Assigned (FOnContent) THEN FOnContent (Self, Content);
2655   -END;
2656   -
2657   -
2658   -PROCEDURE TCustomXmlScanner.WhenCData (Content : STRING);
2659   - // Is called when the parser has parsed a CDATA section
2660   -BEGIN
2661   - IF Assigned (FOnCData) THEN FOnCData (Self, Content);
2662   -END;
2663   -
2664   -
2665   -PROCEDURE TCustomXmlScanner.WhenElement (ElemDef : TElemDef);
2666   - // Is called when the parser has parsed an <!ELEMENT> definition
2667   - // inside the DTD
2668   -BEGIN
2669   - IF Assigned (FOnElement) THEN FOnElement (Self, ElemDef);
2670   -END;
2671   -
2672   -
2673   -PROCEDURE TCustomXmlScanner.WhenAttList (ElemDef : TElemDef);
2674   - // Is called when the parser has parsed an <!ATTLIST> definition
2675   - // inside the DTD
2676   -BEGIN
2677   - IF Assigned (FOnAttList) THEN FOnAttList (Self, ElemDef);
2678   -END;
2679   -
2680   -
2681   -PROCEDURE TCustomXmlScanner.WhenEntity (EntityDef : TEntityDef);
2682   - // Is called when the parser has parsed an <!ENTITY> definition
2683   - // inside the DTD
2684   -BEGIN
2685   - IF Assigned (FOnEntity) THEN FOnEntity (Self, EntityDef);
2686   -END;
2687   -
2688   -
2689   -PROCEDURE TCustomXmlScanner.WhenNotation (NotationDef : TNotationDef);
2690   - // Is called when the parser has parsed a <!NOTATION> definition
2691   - // inside the DTD
2692   -BEGIN
2693   - IF Assigned (FOnNotation) THEN FOnNotation (Self, NotationDef);
2694   -END;
2695   -
2696   -
2697   -PROCEDURE TCustomXmlScanner.WhenDtdError (ErrorPos : PChar);
2698   - // Is called when the parser has found an Error in the DTD
2699   -BEGIN
2700   - IF Assigned (FOnDtdError) THEN FOnDtdError (Self, ErrorPos);
2701   -END;
2702   -
2703   -
2704   -PROCEDURE TCustomXmlScanner.Execute;
2705   - // Perform scanning
2706   - // Scanning is done synchronously, i.e. you can expect events to be triggered
2707   - // in the order of the XML data stream. Execute will finish when the whole XML
2708   - // document has been scanned or when the StopParser property has been set to TRUE.
2709   -BEGIN
2710   - FStopParser := FALSE;
2711   - FXmlParser.StartScan;
2712   - WHILE FXmlParser.Scan AND (NOT FStopParser) DO
2713   - CASE FXmlParser.CurPartType OF
2714   - ptNone : ;
2715   - ptXmlProlog : WhenXmlProlog (FXmlParser.XmlVersion, FXmlParser.Encoding, FXmlParser.Standalone);
2716   - ptComment : WhenComment (StrSFPas (FXmlParser.CurStart, FXmlParser.CurFinal));
2717   - ptPI : WhenPI (FXmlParser.CurName, FXmlParser.CurContent, FXmlParser.CurAttr);
2718   - ptDtdc : WhenDtdRead (FXmlParser.RootName);
2719   - ptStartTag : WhenStartTag (FXmlParser.CurName, FXmlParser.CurAttr);
2720   - ptEmptyTag : WhenEmptyTag (FXmlParser.CurName, FXmlParser.CurAttr);
2721   - ptEndTag : WhenEndTag (FXmlParser.CurName);
2722   - ptContent : WhenContent (FXmlParser.CurContent);
2723   - ptCData : WhenCData (FXmlParser.CurContent);
2724   - END;
2725   -END;
2726   -
2727   -
2728   -END.
chksis/chksis.cfg
View file @3c1e6d6
... ... @@ -1,38 +0,0 @@
1   --$A8
2   --$B-
3   --$C+
4   --$D+
5   --$E-
6   --$F-
7   --$G+
8   --$H+
9   --$I+
10   --$J-
11   --$K-
12   --$L+
13   --$M-
14   --$N+
15   --$O+
16   --$P+
17   --$Q-
18   --$R-
19   --$S-
20   --$T-
21   --$U-
22   --$V+
23   --$W-
24   --$X+
25   --$YD
26   --$Z1
27   --cg
28   --AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
29   --H+
30   --W+
31   --M
32   --$M16384,1048576
33   --K$00400000
34   --LE"c:\arquivos de programas\borland\delphi7\Projects\Bpl"
35   --LN"c:\arquivos de programas\borland\delphi7\Projects\Bpl"
36   --w-UNSAFE_TYPE
37   --w-UNSAFE_CODE
38   --w-UNSAFE_CAST
chksis/chksis.dof
View file @3c1e6d6
... ... @@ -1,136 +0,0 @@
1   -[FileVersion]
2   -Version=7.0
3   -[Compiler]
4   -A=8
5   -B=0
6   -C=1
7   -D=1
8   -E=0
9   -F=0
10   -G=1
11   -H=1
12   -I=1
13   -J=0
14   -K=0
15   -L=1
16   -M=0
17   -N=1
18   -O=1
19   -P=1
20   -Q=0
21   -R=0
22   -S=0
23   -T=0
24   -U=0
25   -V=1
26   -W=0
27   -X=1
28   -Y=1
29   -Z=1
30   -ShowHints=1
31   -ShowWarnings=1
32   -UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
33   -NamespacePrefix=
34   -SymbolDeprecated=1
35   -SymbolLibrary=1
36   -SymbolPlatform=1
37   -UnitLibrary=1
38   -UnitPlatform=1
39   -UnitDeprecated=1
40   -HResultCompat=1
41   -HidingMember=1
42   -HiddenVirtual=1
43   -Garbage=1
44   -BoundsError=1
45   -ZeroNilCompat=1
46   -StringConstTruncated=1
47   -ForLoopVarVarPar=1
48   -TypedConstVarPar=1
49   -AsgToTypedConst=1
50   -CaseLabelRange=1
51   -ForVariable=1
52   -ConstructingAbstract=1
53   -ComparisonFalse=1
54   -ComparisonTrue=1
55   -ComparingSignedUnsigned=1
56   -CombiningSignedUnsigned=1
57   -UnsupportedConstruct=1
58   -FileOpen=1
59   -FileOpenUnitSrc=1
60   -BadGlobalSymbol=1
61   -DuplicateConstructorDestructor=1
62   -InvalidDirective=1
63   -PackageNoLink=1
64   -PackageThreadVar=1
65   -ImplicitImport=1
66   -HPPEMITIgnored=1
67   -NoRetVal=1
68   -UseBeforeDef=1
69   -ForLoopVarUndef=1
70   -UnitNameMismatch=1
71   -NoCFGFileFound=1
72   -MessageDirective=1
73   -ImplicitVariants=1
74   -UnicodeToLocale=1
75   -LocaleToUnicode=1
76   -ImagebaseMultiple=1
77   -SuspiciousTypecast=1
78   -PrivatePropAccessor=1
79   -UnsafeType=0
80   -UnsafeCode=0
81   -UnsafeCast=0
82   -[Linker]
83   -MapFile=0
84   -OutputObjs=0
85   -ConsoleApp=1
86   -DebugInfo=0
87   -RemoteSymbols=0
88   -MinStackSize=16384
89   -MaxStackSize=1048576
90   -ImageBase=4194304
91   -ExeDescription=
92   -[Directories]
93   -OutputDir=
94   -UnitOutputDir=
95   -PackageDLLOutputDir=
96   -PackageDCPOutputDir=
97   -SearchPath=
98   -Packages=vcl;rtl;vclx;indy;inet;xmlrtl;vclie;inetdbbde;inetdbxpress;dbrtl;dsnap;dsnapcon;vcldb;soaprtl;VclSmp;dbexpress;dbxcds;inetdb;bdertl;vcldbx;webdsnap;websnap;adortl;ibxpress;teeui;teedb;tee;dss;visualclx;visualdbclx;vclactnband;vclshlctrls;IntrawebDB_50_70;Intraweb_50_70;Rave50CLX;Rave50VCL;dclOffice2k;MSI_D7_Rtl
99   -Conditionals=
100   -DebugSourceDirs=
101   -UsePackages=0
102   -[Parameters]
103   -RunParams=
104   -HostApplication=
105   -Launcher=
106   -UseLauncher=0
107   -DebugCWD=
108   -[Language]
109   -ActiveLang=
110   -ProjectLang=
111   -RootDir=C:\Arquivos de programas\Borland\Delphi7\Bin\
112   -[Version Info]
113   -IncludeVerInfo=1
114   -AutoIncBuild=0
115   -MajorVer=2
116   -MinorVer=5
117   -Release=0
118   -Build=773
119   -Debug=0
120   -PreRelease=0
121   -Special=0
122   -Private=0
123   -DLL=0
124   -Locale=1046
125   -CodePage=1252
126   -[Version Info Keys]
127   -CompanyName=Dataprev - Emp. de TI da Prev.Social - URES
128   -FileDescription=Módulo Verificador de Integridade do Sistema CACIC
129   -FileVersion=2.5.0.773
130   -InternalName=
131   -LegalCopyright=
132   -LegalTrademarks=
133   -OriginalFilename=
134   -ProductName=ChkSIS
135   -ProductVersion=2.6
136   -Comments=Baseado na licença GPL (General Public License)
chksis/chksis.dpr
View file @3c1e6d6
... ... @@ -1,887 +0,0 @@
1   -(**
2   ----------------------------------------------------------------------------------------------------------------------------------------------------------------
3   -Copyright 2000, 2001, 2002, 2003, 2004, 2005 Dataprev - Empresa de Tecnologia e Informações da Previdência Social, Brasil
4   -
5   -Este arquivo é parte do programa CACIC - Configurador Automático e Coletor de Informações Computacionais
6   -
7   -O CACIC é um software livre; você pode redistribui-lo e/ou modifica-lo dentro dos termos da Licença Pública Geral GNU como
8   -publicada pela Fundação do Software Livre (FSF); na versão 2 da Licença, ou (na sua opinião) qualquer versão.
9   -
10   -Este programa é distribuido na esperança que possa ser util, mas SEM NENHUMA GARANTIA; sem uma garantia implicita de ADEQUAÇÂO a qualquer
11   -MERCADO ou APLICAÇÃO EM PARTICULAR. Veja a Licença Pública Geral GNU para maiores detalhes.
12   -
13   -Você deve ter recebido uma cópia da Licença Pública Geral GNU, sob o título "LICENCA.txt", junto com este programa, se não, escreva para a Fundação do Software
14   -Livre(FSF) Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
15   ----------------------------------------------------------------------------------------------------------------------------------------------------------------
16   -*)
17   -
18   -program chksis;
19   -{$R *.res}
20   -
21   -uses
22   - Windows,
23   - forms,
24   - SysUtils,
25   - Classes,
26   - Registry,
27   - Inifiles,
28   - XML,
29   - LibXmlParser,
30   - strUtils,
31   - IdHTTP,
32   - IdFTP,
33   - idFTPCommon,
34   - IdBaseComponent,
35   - IdComponent,
36   - IdTCPConnection,
37   - IdTCPClient,
38   - PJVersionInfo,
39   - Winsock,
40   - Tlhelp32,
41   - CACIC_Library in '..\CACIC_Library.pas';
42   -
43   -var
44   - PJVersionInfo1: TPJVersionInfo;
45   - v_strCipherClosed,
46   - v_versao_local,
47   - v_versao_remota,
48   - v_retorno : String;
49   - v_Debugs : Boolean;
50   -
51   -var
52   - v_tstrCipherOpened : TStrings;
53   -
54   -var
55   - g_oCacic : TCACIC;
56   -
57   -function VerFmt(const MS, LS: DWORD): string;
58   - // Format the version number from the given DWORDs containing the info
59   -begin
60   - Result := Format('%d.%d.%d.%d',
61   - [HiWord(MS), LoWord(MS), HiWord(LS), LoWord(LS)])
62   -end;
63   -
64   -procedure log_diario(strMsg : String);
65   -var
66   - HistoricoLog : TextFile;
67   - strDataArqLocal,
68   - strDataAtual,
69   - v_path : string;
70   -begin
71   - try
72   - v_path := g_oCacic.getWinDir + 'chksis.log';
73   - FileSetAttr (v_path,0); // Retira os atributos do arquivo para evitar o erro FILE ACCESS DENIED em máquinas 2000
74   - AssignFile(HistoricoLog,v_path); {Associa o arquivo a uma variável do tipo TextFile}
75   - {$IOChecks off}
76   - Reset(HistoricoLog); {Abre o arquivo texto}
77   - {$IOChecks on}
78   - if (IOResult <> 0) then // Arquivo não existe, será recriado.
79   - begin
80   - Rewrite (HistoricoLog);
81   - Append(HistoricoLog);
82   - Writeln(HistoricoLog,FormatDateTime('dd/mm hh:nn:ss : ', Now) + '======================> Iniciando o Log <=======================');
83   - end;
84   - DateTimeToString(strDataArqLocal, 'yyyymmdd', FileDateToDateTime(Fileage(v_path)));
85   - DateTimeToString(strDataAtual , 'yyyymmdd', Date);
86   - if (strDataAtual <> strDataArqLocal) then // Se o arquivo INI não é da data atual...
87   - begin
88   - Rewrite (HistoricoLog); //Cria/Recria o arquivo
89   - Append(HistoricoLog);
90   - Writeln(HistoricoLog,FormatDateTime('dd/mm hh:nn:ss : ', Now) + '======================> Iniciando o Log <=======================');
91   - end;
92   - Append(HistoricoLog);
93   - Writeln(HistoricoLog,FormatDateTime('dd/mm hh:nn:ss : ', Now)+ '[Verif.Integr.Sistema] '+strMsg); {Grava a string Texto no arquivo texto}
94   - CloseFile(HistoricoLog); {Fecha o arquivo texto}
95   - except
96   - log_diario('Erro na gravação do log!');
97   - end;
98   -end;
99   -function GetVersionInfo(p_File: string):string;
100   -begin
101   - PJVersionInfo1 := TPJVersionInfo.Create(PJVersionInfo1);
102   - PJVersionInfo1.FileName := PChar(p_File);
103   - Result := VerFmt(PJVersionInfo1.FixedFileInfo.dwFileVersionMS, PJVersionInfo1.FixedFileInfo.dwFileVersionLS);
104   -end;
105   -
106   -// Função para fixar o HomeDrive como letra para a pasta do CACIC
107   -function TrataCacicDir(strCacicDir : String) : String;
108   -var tstrCacicDir1,
109   - tstrCacicDir2 : TStrings;
110   - intAUX : integer;
111   -Begin
112   - Result := strCacicDir;
113   - // Crio um array separado por ":" (Para o caso de ter sido informada a letra da unidade)
114   - tstrCacicDir1 := TStrings.Create;
115   - tstrCacicDir1 := g_oCacic.explode(strCacicDir,':');
116   -
117   - if (tstrCacicDir1.Count > 1) then
118   - Begin
119   - tstrCacicDir2 := TStrings.Create;
120   - // Ignoro a letra informada...
121   - // Certifico-me de que as barras são invertidas... (erros acontecem)
122   - // Crio um array quebrado por "\"
123   - Result := StringReplace(tstrCacicDir1[1],'/','\',[rfReplaceAll]);
124   - tstrCacicDir2 := g_oCacic.explode(Result,'\');
125   -
126   - // Inicializo retorno com a unidade raiz do Sistema Operacional
127   - // Concateno ao retorno as partes que formarão o caminho completo do CACIC
128   - Result := g_oCacic.getHomeDrive;
129   - for intAux := 0 to (tstrCacicDir2.Count-1) do
130   - if (tstrCacicDir2[intAux] <> '') then
131   - Result := Result + tstrCacicDir2[intAux] + '\';
132   - tstrCacicDir2.Free;
133   - End
134   - else
135   - Result := g_oCacic.getHomeDrive + strCacicDir + '\';
136   -
137   - tstrCacicDir1.Free;
138   -
139   - Result := StringReplace(Result,'\\','\',[rfReplaceAll]);
140   -End;
141   -
142   -procedure log_DEBUG(p_msg:string);
143   -Begin
144   - if v_Debugs then log_diario('(v.'+getVersionInfo(ParamStr(0))+') DEBUG - '+p_msg);
145   -End;
146   -
147   -Function CipherClose(p_DatFileName : string) : String;
148   -var v_strCipherOpenImploded : string;
149   - v_DatFile : TextFile;
150   -begin
151   - try
152   -
153   - FileSetAttr (p_DatFileName,0); // Retira os atributos do arquivo para evitar o erro FILE ACCESS DENIED em máquinas 2000
154   - AssignFile(v_DatFile,p_DatFileName); {Associa o arquivo a uma variável do tipo TextFile}
155   -
156   - {$IOChecks off}
157   - ReWrite(v_DatFile); {Abre o arquivo texto}
158   - {$IOChecks on}
159   -
160   - if (IOResult <> 0) then
161   - Begin
162   - // Recriação do arquivo .DAT
163   - Rewrite (v_DatFile);
164   - Append(v_DatFile);
165   - End;
166   -
167   - v_strCipherOpenImploded := g_oCacic.implode(v_tstrCipherOpened,g_oCacic.getSeparatorKey);
168   - v_strCipherClosed := g_oCacic.enCrypt(v_strCipherOpenImploded);
169   -
170   - Writeln(v_DatFile,v_strCipherClosed); {Grava a string Texto no arquivo texto}
171   -
172   - CloseFile(v_DatFile);
173   - except
174   - log_diario('Problema na gravação do arquivo de configurações.');
175   - end;
176   -end;
177   -
178   -Function CipherOpen(p_DatFileName : string) : TStrings;
179   -var v_DatFile : TextFile;
180   - v_strCipherOpened,
181   - v_strCipherClosed : string;
182   -begin
183   - v_strCipherOpened := '';
184   - if FileExists(p_DatFileName) then
185   - begin
186   - AssignFile(v_DatFile,p_DatFileName);
187   - {$IOChecks off}
188   - Reset(v_DatFile);
189   - {$IOChecks on}
190   - if (IOResult <> 0) then // Arquivo não existe, será recriado.
191   - begin
192   - Rewrite (v_DatFile);
193   - Append(v_DatFile);
194   - end;
195   -
196   - Readln(v_DatFile,v_strCipherClosed);
197   - while not EOF(v_DatFile) do Readln(v_DatFile,v_strCipherClosed);
198   - CloseFile(v_DatFile);
199   - v_strCipherOpened:= g_oCacic.deCrypt(v_strCipherClosed);
200   - end;
201   - if (trim(v_strCipherOpened)<>'') then
202   - Result := g_oCacic.explode(v_strCipherOpened,g_oCacic.getSeparatorKey)
203   - else
204   - Result := g_oCacic.explode('Configs.ID_SO' + g_oCacic.getSeparatorKey + g_oCacic.getWindowsStrId() + g_oCacic.getSeparatorKey + 'Configs.Endereco_WS' + g_oCacic.getSeparatorKey + '/cacic2/ws/',g_oCacic.getSeparatorKey);
205   -
206   - if Result.Count mod 2 <> 0 then
207   - Result.Add('');
208   -end;
209   -
210   -Procedure SetValorDatMemoria(p_Chave : string; p_Valor : String);
211   -begin
212   - // Exemplo: p_Chave => Configs.nu_ip_servidor : p_Valor => 10.71.0.120
213   - if (v_tstrCipherOpened.IndexOf(p_Chave)<>-1) then
214   - v_tstrCipherOpened[v_tstrCipherOpened.IndexOf(p_Chave)+1] := p_Valor
215   - else
216   - Begin
217   - v_tstrCipherOpened.Add(p_Chave);
218   - v_tstrCipherOpened.Add(p_Valor);
219   - End;
220   -end;
221   -
222   -
223   -function GetRootKey(strRootKey: String): HKEY;
224   -begin
225   - /// Encontrar uma maneira mais elegante de fazer esses testes.
226   - if Trim(strRootKey) = 'HKEY_LOCAL_MACHINE' Then Result := HKEY_LOCAL_MACHINE
227   - else if Trim(strRootKey) = 'HKEY_CLASSES_ROOT' Then Result := HKEY_CLASSES_ROOT
228   - else if Trim(strRootKey) = 'HKEY_CURRENT_USER' Then Result := HKEY_CURRENT_USER
229   - else if Trim(strRootKey) = 'HKEY_USERS' Then Result := HKEY_USERS
230   - else if Trim(strRootKey) = 'HKEY_CURRENT_CONFIG' Then Result := HKEY_CURRENT_CONFIG
231   - else if Trim(strRootKey) = 'HKEY_DYN_DATA' Then Result := HKEY_DYN_DATA;
232   -end;
233   -
234   -function SetValorChaveRegEdit(Chave: String; Dado: Variant): Variant;
235   -var RegEditSet: TRegistry;
236   - RegDataType: TRegDataType;
237   - strRootKey, strKey, strValue : String;
238   - ListaAuxSet : TStrings;
239   - I : Integer;
240   -begin
241   - ListaAuxSet := g_oCacic.explode(Chave, '\');
242   - strRootKey := ListaAuxSet[0];
243   - For I := 1 To ListaAuxSet.Count - 2 Do strKey := strKey + ListaAuxSet[I] + '\';
244   - strValue := ListaAuxSet[ListaAuxSet.Count - 1];
245   -
246   - RegEditSet := TRegistry.Create;
247   - try
248   - RegEditSet.Access := KEY_WRITE;
249   - RegEditSet.Rootkey := GetRootKey(strRootKey);
250   -
251   - if RegEditSet.OpenKey(strKey, True) then
252   - Begin
253   - RegDataType := RegEditSet.GetDataType(strValue);
254   - if RegDataType = rdString then
255   - begin
256   - RegEditSet.WriteString(strValue, Dado);
257   - end
258   - else if RegDataType = rdExpandString then
259   - begin
260   - RegEditSet.WriteExpandString(strValue, Dado);
261   - end
262   - else if RegDataType = rdInteger then
263   - begin
264   - RegEditSet.WriteInteger(strValue, Dado);
265   - end
266   - else
267   - begin
268   - RegEditSet.WriteString(strValue, Dado);
269   - end;
270   -
271   - end;
272   - finally
273   - RegEditSet.CloseKey;
274   - end;
275   - ListaAuxSet.Free;
276   - RegEditSet.Free;
277   -end;
278   -
279   -Function RemoveCaracteresEspeciais(Texto : String) : String;
280   -var I : Integer;
281   - strAux : String;
282   -Begin
283   - For I := 0 To Length(Texto) Do
284   - if ord(Texto[I]) in [32..126] Then
285   - strAux := strAux + Texto[I]
286   - else strAux := strAux + ' '; // Coloca um espaço onde houver caracteres especiais
287   - Result := strAux;
288   -end;
289   -
290   -//Para buscar do RegEdit...
291   -function GetValorChaveRegEdit(Chave: String): Variant;
292   -var RegEditGet: TRegistry;
293   - RegDataType: TRegDataType;
294   - strRootKey, strKey, strValue, s: String;
295   - ListaAuxGet : TStrings;
296   - DataSize, Len, I : Integer;
297   -begin
298   - try
299   - ListaAuxGet := g_oCacic.explode(Chave, '\');
300   -
301   - strRootKey := ListaAuxGet[0];
302   - For I := 1 To ListaAuxGet.Count - 2 Do strKey := strKey + ListaAuxGet[I] + '\';
303   - strValue := ListaAuxGet[ListaAuxGet.Count - 1];
304   - RegEditGet := TRegistry.Create;
305   -
306   - RegEditGet.Access := KEY_READ;
307   - RegEditGet.Rootkey := GetRootKey(strRootKey);
308   - if RegEditGet.OpenKeyReadOnly(strKey) then //teste
309   - Begin
310   - RegDataType := RegEditGet.GetDataType(strValue);
311   - if (RegDataType = rdString) or (RegDataType = rdExpandString) then Result := RegEditGet.ReadString(strValue)
312   - else if RegDataType = rdInteger then Result := RegEditGet.ReadInteger(strValue)
313   - else if (RegDataType = rdBinary) or (RegDataType = rdUnknown)
314   - then
315   - begin
316   - DataSize := RegEditGet.GetDataSize(strValue);
317   - if DataSize = -1 then exit;
318   - SetLength(s, DataSize);
319   - Len := RegEditGet.ReadBinaryData(strValue, PChar(s)^, DataSize);
320   - if Len <> DataSize then exit;
321   - Result := RemoveCaracteresEspeciais(s);
322   - end
323   - end;
324   - finally
325   - RegEditGet.CloseKey;
326   - RegEditGet.Free;
327   - ListaAuxGet.Free;
328   -
329   - end;
330   -end;
331   -
332   -
333   -function GetValorChaveRegIni(p_Secao, p_Chave, p_File : String): String;
334   -//Para buscar do Arquivo INI...
335   -// Marreta devido a limitações do KERNEL w9x no tratamento de arquivos texto e suas seções
336   -//function GetValorChaveRegIni(p_SectionName, p_KeyName, p_IniFileName : String) : String;
337   -var
338   - FileText : TStringList;
339   - i, j, v_Size_Section, v_Size_Key : integer;
340   - v_SectionName, v_KeyName : string;
341   - begin
342   - Result := '';
343   - v_SectionName := '[' + p_Secao + ']';
344   - v_Size_Section := strLen(PChar(v_SectionName));
345   - v_KeyName := p_Chave + '=';
346   - v_Size_Key := strLen(PChar(v_KeyName));
347   - FileText := TStringList.Create;
348   - if (FileExists(p_File)) then
349   - Begin
350   - try
351   - FileText.LoadFromFile(p_File);
352   - For i := 0 To FileText.Count - 1 Do
353   - Begin
354   - if (LowerCase(Trim(PChar(Copy(FileText[i],1,v_Size_Section)))) = LowerCase(Trim(PChar(v_SectionName)))) then
355   - Begin
356   - For j := i to FileText.Count - 1 Do
357   - Begin
358   - if (LowerCase(Trim(PChar(Copy(FileText[j],1,v_Size_Key)))) = LowerCase(Trim(PChar(v_KeyName)))) then
359   - Begin
360   - Result := PChar(Copy(FileText[j],v_Size_Key + 1,strLen(PChar(FileText[j]))-v_Size_Key));
361   - Break;
362   - End;
363   - End;
364   - End;
365   - if (Result <> '') then break;
366   - End;
367   - finally
368   - FileText.Free;
369   - end;
370   - end
371   - else FileText.Free;
372   - end;
373   -
374   -
375   -Procedure DelValorReg(Chave: String);
376   -var RegDelValorReg: TRegistry;
377   - strRootKey, strKey, strValue : String;
378   - ListaAuxDel : TStrings;
379   - I : Integer;
380   -begin
381   - ListaAuxDel := g_oCacic.explode(Chave, '\');
382   - strRootKey := ListaAuxDel[0];
383   - For I := 1 To ListaAuxDel.Count - 2 Do strKey := strKey + ListaAuxDel[I] + '\';
384   - strValue := ListaAuxDel[ListaAuxDel.Count - 1];
385   - RegDelValorReg := TRegistry.Create;
386   -
387   - try
388   - RegDelValorReg.Access := KEY_WRITE;
389   - RegDelValorReg.Rootkey := GetRootKey(strRootKey);
390   -
391   - if RegDelValorReg.OpenKey(strKey, True) then
392   - RegDelValorReg.DeleteValue(strValue);
393   - finally
394   - RegDelValorReg.CloseKey;
395   - end;
396   - RegDelValorReg.Free;
397   - ListaAuxDel.Free;
398   -end;
399   -function Get_File_Size(sFileToExamine: string; bInKBytes: Boolean): string;
400   -var
401   - SearchRec: TSearchRec;
402   - sgPath: string;
403   - inRetval, I1: Integer;
404   -begin
405   - sgPath := ExpandFileName(sFileToExamine);
406   - try
407   - inRetval := FindFirst(ExpandFileName(sFileToExamine), faAnyFile, SearchRec);
408   - if inRetval = 0 then
409   - I1 := SearchRec.Size
410   - else
411   - I1 := -1;
412   - finally
413   - SysUtils.FindClose(SearchRec);
414   - end;
415   - Result := IntToStr(I1);
416   -end;
417   -
418   -Function FTP(p_Host : String; p_Port : String; p_Username : String; p_Password : String; p_PathServer : String; p_File : String; p_Dest : String) : Boolean;
419   -var IdFTP : TIdFTP;
420   - msg_error : string;
421   -begin
422   - msg_error := '';
423   - Try
424   - IdFTP := TIdFTP.Create(IdFTP);
425   - IdFTP.Host := p_Host;
426   - IdFTP.Username := p_Username;
427   - IdFTP.Password := p_Password;
428   - IdFTP.Port := strtoint(p_Port);
429   - IdFTP.TransferType := ftBinary;
430   - IdFTP.Passive := true;
431   - Try
432   - if IdFTP.Connected = true then
433   - begin
434   - IdFTP.Disconnect;
435   - end;
436   - msg_error := 'Falha ao tentar conexão com o servidor FTP: "' + p_Host + '"';
437   - IdFTP.Connect(true);
438   - msg_error := 'Falha ao tentar mudar diretório no servidor FTP: "' + p_PathServer + '"';
439   - IdFTP.ChangeDir(p_PathServer);
440   - Try
441   - log_DEBUG('Size de "'+p_File+'" Antes do FTP => '+IntToSTR(IdFTP.Size(p_File)));
442   - msg_error := 'Falha ao tentar obter arquivo no servidor FTP: "' + p_File + '"';
443   - IdFTP.Get(p_File, p_Dest + '\' + p_File, True);
444   - log_DEBUG('Size de "'+p_Dest + '\' + p_File +'" Após o FTP => '+Get_File_Size(p_Dest + '\' + p_File,true));
445   - Finally
446   - log_DEBUG('Size de "'+p_Dest + '\' + p_File +'" Após o FTP em Finally => '+Get_File_Size(p_Dest + '\' + p_File,true));
447   - idFTP.Disconnect;
448   - result := true;
449   - End;
450   - Except
451   - log_diario(msg_error);
452   - result := false;
453   - end;
454   - idFTP.Free;
455   - Except
456   - result := false;
457   - End;
458   -end;
459   -
460   -function GetIP: string;
461   -var ipwsa:TWSAData; p:PHostEnt; s:array[0..128] of char; c:pchar;
462   -begin
463   - wsastartup(257,ipwsa);
464   - GetHostName(@s, 128);
465   - p := GetHostByName(@s);
466   - c := iNet_ntoa(PInAddr(p^.h_addr_list^)^);
467   - Result := String(c);
468   -end;
469   -function FindWindowByTitle(WindowTitle: string): Hwnd;
470   -var
471   - NextHandle: Hwnd;
472   - ConHandle : Thandle;
473   - NextTitle: array[0..260] of char;
474   -begin
475   - // Get the first window
476   -
477   - NextHandle := GetWindow(ConHandle, GW_HWNDFIRST);
478   - while NextHandle > 0 do
479   - begin
480   - // retrieve its text
481   - GetWindowText(NextHandle, NextTitle, 255);
482   -
483   - if (trim(StrPas(NextTitle))<> '') and (Pos(strlower(pchar(WindowTitle)), strlower(PChar(StrPas(NextTitle)))) <> 0) then
484   - begin
485   - Result := NextHandle;
486   - Exit;
487   - end
488   - else
489   - // Get the next window
490   - NextHandle := GetWindow(NextHandle, GW_HWNDNEXT);
491   - end;
492   - Result := 0;
493   -end;
494   -
495   -// Rotina obtida em http://www.swissdelphicenter.ch/torry/showcode.php?id=266
496   -{For Windows 9x/ME/2000/XP }
497   -function KillTask(ExeFileName: string): Integer;
498   -const
499   - PROCESS_TERMINATE = $0001;
500   -var
501   - ContinueLoop: BOOL;
502   - FSnapshotHandle: THandle;
503   - FProcessEntry32: TProcessEntry32;
504   -begin
505   - Result := 0;
506   - FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
507   - FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
508   - ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
509   -
510   - while Integer(ContinueLoop) <> 0 do
511   - begin
512   - if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
513   - UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) =
514   - UpperCase(ExeFileName))) then
515   - Result := Integer(TerminateProcess(
516   - OpenProcess(PROCESS_TERMINATE,
517   - BOOL(0),
518   - FProcessEntry32.th32ProcessID),
519   - 0));
520   - ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
521   - end;
522   - CloseHandle(FSnapshotHandle);
523   -end;
524   -
525   -// Rotina obtida em http://www.swissdelphicenter.ch/torry/showcode.php?id=266
526   -{ For Windows NT/2000/XP }
527   -procedure KillProcess(hWindowHandle: HWND);
528   -var
529   - hprocessID: INTEGER;
530   - processHandle: THandle;
531   - DWResult: DWORD;
532   -begin
533   - SendMessageTimeout(hWindowHandle, WM_DDE_TERMINATE, 0, 0,
534   - SMTO_ABORTIFHUNG or SMTO_NORMAL, 5000, DWResult);
535   -
536   - if isWindow(hWindowHandle) then
537   - begin
538   - // PostMessage(hWindowHandle, WM_QUIT, 0, 0);
539   -
540   - { Get the process identifier for the window}
541   - GetWindowThreadProcessID(hWindowHandle, @hprocessID);
542   - if hprocessID <> 0 then
543   - begin
544   - { Get the process handle }
545   - processHandle := OpenProcess(PROCESS_TERMINATE or PROCESS_QUERY_INFORMATION,
546   - False, hprocessID);
547   - if processHandle <> 0 then
548   - begin
549   - { Terminate the process }
550   - TerminateProcess(processHandle, 0);
551   - CloseHandle(ProcessHandle);
552   - end;
553   - end;
554   - end;
555   -end;
556   -
557   -
558   -// Dica baixada de http://procedure.blig.ig.com.br/
559   -// Adaptada por Anderson Peterle - v:2.2.0.16 - 03/2007
560   -procedure Matar(v_dir,v_files: string);
561   -var SearchRec: TSearchRec;
562   - Result: Integer;
563   - strFileName : String;
564   -begin
565   - strFileName := StringReplace(v_dir + '\' + v_files,'\\','\',[rfReplaceAll]);
566   - Result:=FindFirst(strFileName, faAnyFile, SearchRec);
567   -
568   - while result=0 do
569   - begin
570   - strFileName := StringReplace(v_dir + '\' + SearchRec.Name,'\\','\',[rfReplaceAll]);
571   -
572   - if not DeleteFile(strFileName) then
573   - Begin
574   - if (not g_oCacic.isWindowsNTPlataform()) then // Menor que NT Like
575   - KillTask(SearchRec.Name)
576   - else
577   - KillProcess(FindWindow(PChar(SearchRec.Name),nil));
578   - DeleteFile(strFileName);
579   - End;
580   -
581   - Result:=FindNext(SearchRec);
582   - end;
583   -end;
584   -
585   -function Posso_Rodar_CACIC : boolean;
586   -Begin
587   - result := false;
588   -
589   - // Se o aguarde_CACIC.txt existir é porque refere-se a uma versão mais atual: 2.2.0.20 ou maior
590   - if (FileExists(g_oCacic.getCacicPath + 'aguarde_CACIC.txt')) then
591   - Begin
592   - // Se eu conseguir matar o arquivo abaixo é porque não há outra sessão deste agente aberta... (POG? Nããão! :) )
593   - Matar(g_oCacic.getCacicPath,'aguarde_CACIC.txt');
594   - if (not (FileExists(g_oCacic.getCacicPath + 'aguarde_CACIC.txt'))) then
595   - result := true;
596   - End;
597   -End;
598   -
599   -Function ChecaVersoesAgentes(p_strNomeAgente : String) : integer;
600   -var v_versao_REM,
601   - v_versao_LOC,
602   - strNomeAgente : String;
603   - v_array_NomeAgente : TStrings;
604   - intAux : integer;
605   -Begin
606   - v_array_NomeAgente := g_oCacic.explode(p_strNomeAgente,'\');
607   -
608   - v_versao_REM := XML_RetornaValor(StringReplace(StrUpper(PChar(v_array_NomeAgente[v_array_NomeAgente.count-1])),'.EXE','',[rfReplaceAll]), v_retorno);
609   - v_versao_LOC := GetVersionInfo(p_strNomeAgente);
610   -
611   - log_diario('Checando versão de "'+p_strNomeAgente+'"');
612   -
613   - intAux := v_array_NomeAgente.Count;
614   -
615   - // V: 2.2.0.16
616   - // Verifico existência do arquivo "versoes_agentes.ini" para comparação das versões dos agentes principais
617   - if (v_versao_REM = '') AND FileExists(ExtractFilePath(Application.Exename)+'versoes_agentes.ini') then
618   - Begin
619   - if (GetValorChaveRegIni('versoes_agentes',v_array_NomeAgente[intAux-1],ExtractFilePath(Application.Exename)+'versoes_agentes.ini')<>'') then
620   - Begin
621   - log_diario('Encontrado arquivo "'+(ExtractFilePath(Application.Exename)+'versoes_agentes.ini')+'"');
622   - v_versao_REM := GetValorChaveRegIni('versoes_agentes',v_array_NomeAgente[intAux-1],ExtractFilePath(Application.Exename)+'versoes_agentes.ini');
623   - End;
624   - End;
625   -
626   - log_diario('Versão Remota: "'+v_versao_REM+'" - Versão Local: "'+v_versao_LOC+'"');
627   -
628   - if (v_versao_REM + v_versao_LOC <> '') and
629   - (v_versao_LOC <> '0000') then
630   - Begin
631   - if (v_versao_REM = v_versao_LOC) then
632   - Result := 1
633   - else
634   - Result := 2;
635   - End
636   - else
637   - Result := 0;
638   -End;
639   -
640   -function GetFolderDate(Folder: string): TDateTime;
641   -var
642   - Rec: TSearchRec;
643   - Found: Integer;
644   - Date: TDateTime;
645   -begin
646   - if Folder[Length(folder)] = '\' then
647   - Delete(Folder, Length(folder), 1);
648   - Result := 0;
649   - Found := FindFirst(Folder, faDirectory, Rec);
650   - try
651   - if Found = 0 then
652   - begin
653   - Date := FileDateToDateTime(Rec.Time);
654   - Result := Date;
655   - end;
656   - finally
657   - FindClose(Rec);
658   - end;
659   -end;
660   -
661   -procedure executa_chksis;
662   -var
663   - bool_download_CACIC2,
664   - bool_ExistsAutoRun : boolean;
665   - v_ip_serv_cacic, v_cacic_dir, v_rem_cacic_v0x,
666   - v_te_serv_updates, v_nu_porta_serv_updates, v_nm_usuario_login_serv_updates,
667   - v_te_senha_login_serv_updates, v_te_path_serv_updates : String;
668   - Request_Config : TStringList;
669   - Response_Config : TStringStream;
670   - IdHTTP1: TIdHTTP;
671   - intAux : integer;
672   -begin
673   -
674   - bool_download_CACIC2 := false;
675   - v_ip_serv_cacic := GetValorChaveRegIni('Cacic2', 'ip_serv_cacic', ExtractFilePath(ParamStr(0)) + 'chksis.ini');
676   - v_cacic_dir := GetValorChaveRegIni('Cacic2', 'cacic_dir' , ExtractFilePath(ParamStr(0)) + 'chksis.ini');
677   - v_rem_cacic_v0x := GetValorChaveRegIni('Cacic2', 'rem_cacic_v0x', ExtractFilePath(ParamStr(0)) + 'chksis.ini');
678   -
679   - g_oCacic.setCacicPath(TrataCacicDir(v_cacic_dir));
680   -
681   - v_Debugs := false;
682   - if DirectoryExists(g_oCacic.getCacicPath + 'Temp\Debugs') then
683   - Begin
684   - if (FormatDateTime('ddmmyyyy', GetFolderDate(g_oCacic.getCacicPath + 'Temp\Debugs')) = FormatDateTime('ddmmyyyy', date)) then
685   - Begin
686   - v_Debugs := true;
687   - log_DEBUG('Pasta "' + g_oCacic.getCacicPath + 'Temp\Debugs" com data '+FormatDateTime('dd-mm-yyyy', GetFolderDate(g_oCacic.getCacicPath + 'Temp\Debugs'))+' encontrada. DEBUG ativado.');
688   - End;
689   - End;
690   -
691   - log_DEBUG('setCacicPath "'+g_oCacic.getCacicPath+'"');
692   -
693   - log_DEBUG('Verificando recepção do parâmetro rem_cacic_v0x...');
694   - // Caso o parâmetro rem_cacic_v0x seja "S/s" removo a chave/valor de execução do Cacic antigo
695   - if (LowerCase(v_rem_cacic_v0x)='s') then
696   - begin
697   - log_DEBUG('Excluindo chave de execução do CACIC');
698   - DelValorReg('HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run\cacic');
699   - end;
700   -
701   - log_DEBUG('Verificando existência da pasta "'+g_oCacic.getCacicPath+'"');
702   - // Verifico a existência do diretório configurado para o Cacic, normalmente CACIC
703   - if not DirectoryExists(g_oCacic.getCacicPath) then
704   - begin
705   - log_DEBUG('Criando diretório ' + g_oCacic.getCacicPath);
706   - ForceDirectories(g_oCacic.getCacicPath);
707   - end;
708   -
709   - log_DEBUG('Verificando existência da pasta "'+g_oCacic.getCacicPath+'modulos"');
710   - // Para eliminar versão 20014 e anteriores que provavelmente não fazem corretamente o AutoUpdate
711   - if not DirectoryExists(g_oCacic.getCacicPath+'modulos') then
712   - begin
713   - log_DEBUG('Excluindo '+ g_oCacic.getCacicPath + 'cacic2.exe');
714   - Matar(g_oCacic.getCacicPath,'cacic2.exe');
715   - log_DEBUG('Criando diretório ' + g_oCacic.getCacicPath + 'modulos');
716   - ForceDirectories(g_oCacic.getCacicPath + 'modulos');
717   - end;
718   -
719   - log_DEBUG('Verificando existência da pasta "'+g_oCacic.getCacicPath+'temp"');
720   - // Crio o SubDiretório TEMP, caso não exista
721   - if not DirectoryExists(g_oCacic.getCacicPath+'temp') then
722   - begin
723   - log_DEBUG('Criando diretório ' + g_oCacic.getCacicPath + 'temp');
724   - ForceDirectories(g_oCacic.getCacicPath + 'temp');
725   - end;
726   -
727   - log_DEBUG('Verificando existência dos agentes principais "'+g_oCacic.getCacicPath+'cacic2.exe" e "'+g_oCacic.getCacicPath + 'modulos\ger_cols.exe"');
728   - // Verifico existência dos dois principais objetos
729   - If (not FileExists(g_oCacic.getCacicPath + 'cacic2.exe')) or (not FileExists(g_oCacic.getCacicPath + 'modulos\ger_cols.exe')) Then
730   - Begin
731   - // Busco as configurações para acesso ao ambiente FTP - Updates
732   - Request_Config := TStringList.Create;
733   - Request_Config.Values['in_chkcacic'] := 'chkcacic';
734   - Request_Config.Values['te_fila_ftp'] := '1'; // Indicará que o agente quer entrar no grupo para FTP
735   - Request_Config.Values['id_ip_estacao']:= GetIP; // Informará o IP para registro na tabela redes_grupos_FTP
736   - Response_Config := TStringStream.Create('');
737   -
738   - Try
739   - log_diario('Tentando contato com ' + 'http://' + v_ip_serv_cacic + '/cacic2/ws/get_config.php');
740   - IdHTTP1 := TIdHTTP.Create(nil);
741   - IdHTTP1.Post('http://' + v_ip_serv_cacic + '/cacic2/ws/get_config.php', Request_Config, Response_Config);
742   - IdHTTP1.Disconnect;
743   - IdHTTP1.Free;
744   - v_retorno := Response_Config.DataString;
745   - v_te_serv_updates := XML_RetornaValor('te_serv_updates' , Response_Config.DataString);
746   - v_nu_porta_serv_updates := XML_RetornaValor('nu_porta_serv_updates' , Response_Config.DataString);
747   - v_nm_usuario_login_serv_updates := XML_RetornaValor('nm_usuario_login_serv_updates', Response_Config.DataString);
748   - v_te_senha_login_serv_updates := XML_RetornaValor('te_senha_login_serv_updates' , Response_Config.DataString);
749   - v_te_path_serv_updates := XML_RetornaValor('te_path_serv_updates' , Response_Config.DataString);
750   -
751   - log_DEBUG(':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::');
752   - log_DEBUG(':::::::::::::::: VALORES OBTIDOS NO Gerente WEB :::::::::::::::');
753   - log_DEBUG(':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::');
754   - log_DEBUG('Servidor de updates......................: '+v_te_serv_updates);
755   - log_DEBUG('Porta do servidor de updates.............: '+v_nu_porta_serv_updates);
756   - log_DEBUG('Usuário para login no servidor de updates: '+v_nm_usuario_login_serv_updates);
757   - log_DEBUG('Pasta no servidor de updates.............: '+v_te_path_serv_updates);
758   - log_DEBUG(' ');
759   - log_DEBUG('Versões dos Agentes Principais:');
760   - log_DEBUG('------------------------------');
761   - log_DEBUG('Cacic2 - Agente do Systray.........: '+XML_RetornaValor('CACIC2', v_retorno));
762   - log_DEBUG('Ger_Cols - Gerente de Coletas........: '+XML_RetornaValor('GER_COLS', v_retorno));
763   - log_DEBUG('ChkSis - Verificador de Integridade: '+XML_RetornaValor('CHKSIS', v_retorno));
764   - log_DEBUG(':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::');
765   -
766   - Except log_DEBUG('Falha no contato com ' + 'http://' + v_ip_serv_cacic + '/cacic2/ws/get_config.php');
767   - End;
768   -
769   - Request_Config.Free;
770   - Response_Config.Free;
771   -
772   - log_DEBUG('Verificando existência do agente "'+g_oCacic.getCacicPath+'cacic2.exe"');
773   - // Verificação de versão do cacic2.exe e exclusão em caso de versão antiga
774   - If (FileExists(g_oCacic.getCacicPath + 'cacic2.exe')) Then
775   - Begin
776   - intAux := ChecaVersoesAgentes(g_oCacic.getCacicPath + 'cacic2.exe');
777   - // 0 => Arquivo de versões ou informação inexistente
778   - // 1 => Versões iguais
779   - // 2 => Versões diferentes
780   - if (intAux = 0) then
781   - Begin
782   - v_versao_local := StringReplace(trim(GetVersionInfo(g_oCacic.getCacicPath + 'cacic2.exe')),'.','',[rfReplaceAll]);
783   - v_versao_remota := StringReplace(XML_RetornaValor('CACIC2' , v_retorno),'0103','',[rfReplaceAll]);
784   - End;
785   -
786   - if (intAux = 2) or // Caso haja diferença na comparação de versões com "versoes_agentes.ini"...
787   - (v_versao_local ='0000') or // Provavelmente versão muito antiga ou corrompida
788   - (v_versao_local ='2208') then
789   - Matar(g_oCacic.getCacicPath, 'cacic2.exe');
790   - End;
791   -
792   - log_DEBUG('Verificando existência do agente "'+g_oCacic.getCacicPath+'modulos\ger_cols.exe"');
793   - // Verificação de versão do ger_cols.exe e exclusão em caso de versão antiga
794   - If (FileExists(g_oCacic.getCacicPath + 'modulos\ger_cols.exe')) Then
795   - Begin
796   - intAux := ChecaVersoesAgentes(g_oCacic.getCacicPath + 'modulos\ger_cols.exe');
797   - // 0 => Arquivo de versões ou informação inexistente
798   - // 1 => Versões iguais
799   - // 2 => Versões diferentes
800   - if (intAux = 0) then
801   - Begin
802   - v_versao_local := StringReplace(trim(GetVersionInfo(g_oCacic.getCacicPath + 'modulos\ger_cols.exe')),'.','',[rfReplaceAll]);
803   - v_versao_remota := StringReplace(XML_RetornaValor('GER_COLS' , v_retorno),'0103','',[rfReplaceAll]);
804   - End;
805   -
806   - if (intAux = 2) or // Caso haja diferença na comparação de versões com "versoes_agentes.ini"...
807   - (v_versao_local ='0000') then // Provavelmente versão muito antiga ou corrompida
808   - Matar(g_oCacic.getCacicPath + 'modulos\', 'ger_cols.exe');
809   -
810   - End;
811   -
812   - log_DEBUG('Nova Verificação de existência do agente "'+g_oCacic.getCacicPath+'cacic2.exe"');
813   - // Tento detectar o Agente Principal e faço FTP caso não exista
814   - If not FileExists(g_oCacic.getCacicPath + 'cacic2.exe') Then
815   - begin
816   - log_diario('Fazendo FTP de cacic2.exe a partir de ' + v_te_serv_updates + '/' +
817   - v_nu_porta_serv_updates+'/'+
818   - v_nm_usuario_login_serv_updates + '/' +
819   - v_te_path_serv_updates + ' para a pasta ' + g_oCacic.getCacicPath);
820   - FTP(v_te_serv_updates,
821   - v_nu_porta_serv_updates,
822   - v_nm_usuario_login_serv_updates,
823   - v_te_senha_login_serv_updates,
824   - v_te_path_serv_updates,
825   - 'cacic2.exe',
826   - g_oCacic.getCacicPath);
827   - bool_download_CACIC2 := true;
828   - end;
829   -
830   - log_DEBUG('Nova Verificação de existência do agente "'+g_oCacic.getCacicPath+'modulos\ger_cols.exe"');
831   - // Tento detectar o Gerente de Coletas e faço FTP caso não exista
832   - If (not FileExists(g_oCacic.getCacicPath + 'modulos\ger_cols.exe')) Then
833   - begin
834   - log_diario('Fazendo FTP de ger_cols.exe a partir de ' + v_te_serv_updates + '/' +
835   - v_nu_porta_serv_updates+'/'+
836   - v_nm_usuario_login_serv_updates + '/' +
837   - v_te_path_serv_updates + ' para a pasta ' + g_oCacic.getCacicPath + 'modulos');
838   -
839   - FTP(v_te_serv_updates,
840   - v_nu_porta_serv_updates,
841   - v_nm_usuario_login_serv_updates,
842   - v_te_senha_login_serv_updates,
843   - v_te_path_serv_updates,
844   - 'ger_cols.exe',
845   - g_oCacic.getCacicPath + 'modulos');
846   - end;
847   -
848   -
849   - End;
850   -
851   - // 5 segundos para espera de possível FTP...
852   - Sleep(5000);
853   -
854   - // Caso o Cacic tenha sido baixado executo-o com parâmetro de configuração de servidor
855   - if Posso_Rodar_CACIC or not bool_ExistsAutoRun then
856   - Begin
857   - log_diario('Executando '+g_oCacic.getCacicPath + 'cacic2.exe /ip_serv_cacic=' + v_ip_serv_cacic);
858   -
859   - // Caso tenha havido download de agentes principais, executar coletas imediatamente...
860   - if (bool_download_CACIC2) then
861   - g_oCacic.createSampleProcess(g_oCacic.getCacicPath + 'cacic2.exe /ip_serv_cacic=' + v_ip_serv_cacic+ ' /execute', false)
862   - else
863   - g_oCacic.createSampleProcess(g_oCacic.getCacicPath + 'cacic2.exe /ip_serv_cacic=' + v_ip_serv_cacic , false);
864   - End;
865   -end;
866   -
867   -const
868   - CACIC_APP_NAME = 'chksis';
869   -
870   -begin
871   - g_oCacic := TCACIC.Create();
872   -
873   - g_oCacic.setBoolCipher(true);
874   -
875   - if( not g_oCacic.isAppRunning( CACIC_APP_NAME ) )
876   - then begin
877   - if (FindWindowByTitle('chkcacic') = 0) and (FindWindowByTitle('cacic2') = 0)
878   - then
879   - if (FileExists(ExtractFilePath(ParamStr(0)) + 'chksis.ini'))
880   - then executa_chksis
881   - else log_diario('Não executei devido execução em paralelo de "chkcacic" ou "cacic2"!');
882   - end;
883   -
884   - g_oCacic.Free();
885   -
886   -end.
887   -
chksis/chksis.res
View file @3c1e6d6
No preview for this file type
chksis/xml.pas
View file @3c1e6d6
... ... @@ -1,34 +0,0 @@
1   -unit XML;
2   -
3   -
4   -interface
5   -
6   -Uses LibXmlParser, SysUtils;
7   -
8   -Function XML_RetornaValor(Tag : String; Fonte : String) : String;
9   -
10   -implementation
11   -
12   -
13   -Function XML_RetornaValor(Tag : String; Fonte : String): String;
14   -VAR
15   - Parser : TXmlParser;
16   -begin
17   - Parser := TXmlParser.Create;
18   - Parser.Normalize := TRUE;
19   - Parser.LoadFromBuffer(PAnsiChar(Fonte));
20   - Parser.StartScan;
21   - WHILE Parser.Scan DO
22   - Begin
23   - if (Parser.CurPartType in [ptContent, ptCData]) Then // Process Parser.CurContent field here
24   - begin
25   - if (UpperCase(Parser.CurName) = UpperCase(Tag)) then
26   - Begin
27   - Result := Parser.CurContent;
28   - end;
29   - end;
30   - end;
31   - Parser.Free;
32   -end;
33   -
34   -end.