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,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,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,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,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,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.