Download as
Browse Code »

Commit 3c1e6d68fd9fc6ebc08475a5e54c3d7f06509239

Authored by anderson.peterle@previdencia.gov.br
1 parent eda4e86b
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@957 fecfc0c7-e812-0410-ae72-849f08638ee7
Showing 19 changed files with 0 additions and 7026 deletions   Show diff stats
chkcacic/FormConfig.ddp
View file @eda4e86
No preview for this file type
chkcacic/FormConfig.dfm
View file @eda4e86
... ... @@ -1,239 +0,0 @@
1   -object Configs: TConfigs
2   - Left = 260
3   - Top = 102
4   - BorderIcons = []
5   - BorderStyle = bsSingle
6   - Caption = 'Configura'#231#245'es do CHKCACIC'
7   - ClientHeight = 367
8   - ClientWidth = 490
9   - Color = clBtnFace
10   - Font.Charset = DEFAULT_CHARSET
11   - Font.Color = clWindowText
12   - Font.Height = -11
13   - Font.Name = 'MS Sans Serif'
14   - Font.Style = []
15   - OldCreateOrder = False
16   - Position = poScreenCenter
17   - PixelsPerInch = 96
18   - TextHeight = 13
19   - object gbOpcional: TGroupBox
20   - Left = 5
21   - Top = 91
22   - Width = 480
23   - Height = 219
24   - Caption = 'Opcional'
25   - Font.Charset = DEFAULT_CHARSET
26   - Font.Color = clWindowText
27   - Font.Height = -11
28   - Font.Name = 'MS Sans Serif'
29   - Font.Style = [fsBold]
30   - ParentFont = False
31   - TabOrder = 3
32   - object lbMensagemNaoAplicavel: TLabel
33   - Left = 265
34   - Top = 25
35   - Width = 192
36   - Height = 13
37   - Caption = '(N'#227'o aplicar ao chkCACIC do NetLogon)'
38   - Font.Charset = DEFAULT_CHARSET
39   - Font.Color = clRed
40   - Font.Height = -11
41   - Font.Name = 'MS Sans Serif'
42   - Font.Style = []
43   - ParentFont = False
44   - end
45   - object Label_te_instala_informacoes_extras: TLabel
46   - Left = 9
47   - Top = 50
48   - Width = 89
49   - Height = 13
50   - Caption = 'Informa'#231#245'es extras'
51   - Font.Charset = DEFAULT_CHARSET
52   - Font.Color = clWindowText
53   - Font.Height = -11
54   - Font.Name = 'MS Sans Serif'
55   - Font.Style = []
56   - ParentFont = False
57   - end
58   - object Memo_te_instala_informacoes_extras: TMemo
59   - Left = 9
60   - Top = 66
61   - Width = 462
62   - Height = 144
63   - Color = clInactiveBorder
64   - Enabled = False
65   - Font.Charset = DEFAULT_CHARSET
66   - Font.Color = clWindowText
67   - Font.Height = -11
68   - Font.Name = 'MS Sans Serif'
69   - Font.Style = []
70   - Lines.Strings = (
71   - 'Empresa-UF / Suporte T'#233'cnico'
72   - ''
73   - 'Emails: email1_do_suporte@xxxxxx.yyy.zz, '
74   - ' email2_do_suporte@xxxxxx.yyy.zz'
75   - ''
76   - 'Fones: (xx) yyyy-zzzz / (xx) yyyy-zzzz'
77   - ''
78   - 'Endere'#231'o: Rua Nome_da_Rua, N'#186' 99999'
79   - ' Cidade/UF')
80   - ParentFont = False
81   - TabOrder = 1
82   - end
83   - object ckboxExibeInformacoes: TCheckBox
84   - Left = 9
85   - Top = 23
86   - Width = 256
87   - Height = 17
88   - Caption = 'Exibe informa'#231#245'es sobre o processo de instala'#231#227'o'
89   - Font.Charset = DEFAULT_CHARSET
90   - Font.Color = clWindowText
91   - Font.Height = -11
92   - Font.Name = 'MS Sans Serif'
93   - Font.Style = []
94   - ParentFont = False
95   - TabOrder = 0
96   - OnClick = ckboxExibeInformacoesClick
97   - end
98   - end
99   - object gbObrigatorio: TGroupBox
100   - Left = 5
101   - Top = 8
102   - Width = 480
103   - Height = 76
104   - Caption = 'Obrigat'#243'rio'
105   - Font.Charset = DEFAULT_CHARSET
106   - Font.Color = clWindowText
107   - Font.Height = -11
108   - Font.Name = 'MS Sans Serif'
109   - Font.Style = [fsBold]
110   - ParentFont = False
111   - TabOrder = 2
112   - object Label_ip_serv_cacic: TLabel
113   - Left = 8
114   - Top = 19
115   - Width = 143
116   - Height = 13
117   - Caption = 'Identificador do Servidor WEB'
118   - Font.Charset = DEFAULT_CHARSET
119   - Font.Color = clWindowText
120   - Font.Height = -11
121   - Font.Name = 'MS Sans Serif'
122   - Font.Style = []
123   - ParentFont = False
124   - end
125   - object Label_cacic_dir: TLabel
126   - Left = 260
127   - Top = 19
128   - Width = 103
129   - Height = 13
130   - Caption = 'Pasta para Instala'#231#227'o'
131   - Font.Charset = DEFAULT_CHARSET
132   - Font.Color = clWindowText
133   - Font.Height = -11
134   - Font.Name = 'MS Sans Serif'
135   - Font.Style = []
136   - ParentFont = False
137   - end
138   - object Label1: TLabel
139   - Left = 8
140   - Top = 57
141   - Width = 195
142   - Height = 12
143   - Caption = 'Informe apenas o endere'#231'o IP ou nome (DNS)'
144   - Font.Charset = DEFAULT_CHARSET
145   - Font.Color = clBlue
146   - Font.Height = -9
147   - Font.Name = 'Arial'
148   - Font.Style = []
149   - ParentFont = False
150   - end
151   - object Label2: TLabel
152   - Left = 259
153   - Top = 57
154   - Width = 212
155   - Height = 12
156   - Caption = 'Pasta a ser criada na unidade padr'#227'o (HomeDrive)'
157   - Font.Charset = DEFAULT_CHARSET
158   - Font.Color = clBlue
159   - Font.Height = -9
160   - Font.Name = 'Arial'
161   - Font.Style = []
162   - ParentFont = False
163   - end
164   - end
165   - object Edit_ip_serv_cacic: TEdit
166   - Left = 13
167   - Top = 42
168   - Width = 195
169   - Height = 21
170   - MaxLength = 100
171   - TabOrder = 0
172   - end
173   - object Edit_cacic_dir: TEdit
174   - Left = 265
175   - Top = 42
176   - Width = 211
177   - Height = 21
178   - MaxLength = 100
179   - TabOrder = 1
180   - Text = 'Cacic'
181   - end
182   - object Button_Gravar: TButton
183   - Left = 48
184   - Top = 314
185   - Width = 214
186   - Height = 35
187   - Caption = 'Concluir Instala'#231#227'o/Atualiza'#231#227'o'
188   - Font.Charset = DEFAULT_CHARSET
189   - Font.Color = clWindowText
190   - Font.Height = -13
191   - Font.Name = 'MS Sans Serif'
192   - Font.Style = []
193   - ParentFont = False
194   - TabOrder = 4
195   - OnClick = Button_GravarClick
196   - end
197   - object btSair: TButton
198   - Left = 291
199   - Top = 314
200   - Width = 150
201   - Height = 35
202   - Caption = 'Sair'
203   - Font.Charset = DEFAULT_CHARSET
204   - Font.Color = clWindowText
205   - Font.Height = -13
206   - Font.Name = 'MS Sans Serif'
207   - Font.Style = []
208   - ParentFont = False
209   - TabOrder = 5
210   - OnClick = btSairClick
211   - end
212   - object pnVersao: TPanel
213   - Left = 426
214   - Top = 354
215   - Width = 58
216   - Height = 14
217   - BevelOuter = bvLowered
218   - TabOrder = 6
219   - object lbVersao: TLabel
220   - Left = 4
221   - Top = 1
222   - Width = 53
223   - Height = 12
224   - Alignment = taCenter
225   - AutoSize = False
226   - Caption = 'V:2.00.00.00'
227   - Font.Charset = DEFAULT_CHARSET
228   - Font.Color = clWindowText
229   - Font.Height = -9
230   - Font.Name = 'Arial'
231   - Font.Style = []
232   - ParentFont = False
233   - end
234   - end
235   - object PJVersionInfo1: TPJVersionInfo
236   - Left = 5
237   - Top = 323
238   - end
239   -end
chkcacic/FormConfig.pas
View file @eda4e86
... ... @@ -1,111 +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   -unit FormConfig;
19   -
20   -interface
21   -
22   -uses
23   - Windows,
24   - Messages,
25   - SysUtils,
26   - Variants,
27   - Classes,
28   - Graphics,
29   - Controls,
30   - Forms,
31   - Dialogs,
32   - StdCtrls,
33   - main,
34   - PJVersionInfo,
35   - NTFileSecurity,
36   - Buttons,
37   - ExtCtrls;
38   -
39   -type
40   - TConfigs = class(TForm)
41   - Edit_ip_serv_cacic: TEdit;
42   - Edit_cacic_dir: TEdit;
43   - gbObrigatorio: TGroupBox;
44   - Label_ip_serv_cacic: TLabel;
45   - Label_cacic_dir: TLabel;
46   - gbOpcional: TGroupBox;
47   - lbMensagemNaoAplicavel: TLabel;
48   - Label_te_instala_informacoes_extras: TLabel;
49   - Button_Gravar: TButton;
50   - Memo_te_instala_informacoes_extras: TMemo;
51   - PJVersionInfo1: TPJVersionInfo;
52   - ckboxExibeInformacoes: TCheckBox;
53   - btSair: TButton;
54   - pnVersao: TPanel;
55   - lbVersao: TLabel;
56   - Label1: TLabel;
57   - Label2: TLabel;
58   - procedure Button_GravarClick(Sender: TObject);
59   - procedure ckboxExibeInformacoesClick(Sender: TObject);
60   - procedure btSairClick(Sender: TObject);
61   - private
62   - { Private declarations }
63   - public
64   - { Public declarations }
65   - end;
66   -
67   -var
68   - Configs: TConfigs;
69   -
70   -implementation
71   -
72   -{$R *.dfm}
73   -
74   -procedure TConfigs.Button_GravarClick(Sender: TObject);
75   -begin
76   - if trim(Edit_cacic_dir.Text) = '' then
77   - Edit_cacic_dir.Text := 'Cacic';
78   -
79   - if trim(Edit_ip_serv_cacic.Text) = '' then
80   - Edit_ip_serv_cacic.SetFocus
81   - else
82   - Begin
83   - main.GravaConfiguracoes;
84   - Close;
85   - Application.terminate;
86   - End;
87   -end;
88   -
89   -procedure TConfigs.ckboxExibeInformacoesClick(Sender: TObject);
90   -begin
91   - if ckboxExibeInformacoes.Checked then
92   - Begin
93   - Memo_te_instala_informacoes_extras.Enabled := true;
94   - Memo_te_instala_informacoes_extras.Color := clWindow;
95   - v_exibe_informacoes := 'S';
96   - End
97   - else
98   - Begin
99   - Memo_te_instala_informacoes_extras.Enabled := false;
100   - Memo_te_instala_informacoes_extras.Color := clInactiveBorder;
101   - v_exibe_informacoes := 'N';
102   - End;
103   -end;
104   -
105   -procedure TConfigs.btSairClick(Sender: TObject);
106   -begin
107   - Close;
108   - Application.Terminate;
109   -end;
110   -
111   -end.
chkcacic/IdHTTP.pas
View file @eda4e86
... ... @@ -1,1575 +0,0 @@
1   -unit IdHTTP;
2   -
3   -{
4   - Implementation of the HTTP protcol as specified in RFC 2616, 2109, 2965.
5   - (See NOTE below for details of what is exactly implemented)
6   -
7   - Author: Hadi Hariri (hadi@urusoft.com)
8   - Copyright: (c) Chad Z. Hower and The Winshoes Working Group.
9   -
10   -NOTE:
11   - Initially only GET and POST will be supported. As time goes on more will
12   - be added. For other developers, please add the date and what you have done
13   - below.
14   -
15   -Initials: Hadi Hariri - HH
16   -
17   -Details of implementation
18   --------------------------
19   -2001-Nov Nick Panteleeff
20   - - Authentication and POST parameter extentsions
21   -2001-Sept Doychin Bondzhev
22   - - New internal design and new Authentication procedures.
23   - - Bug fixes and new features in few other supporting components
24   -2001-Jul-7 Doychin Bondzhev
25   - - new property AllowCookie
26   - - There is no more ExtraHeders property in Request/Response. Raw headers is used for that purpose.
27   -2001-Jul-1 Doychin Bondzhev
28   - - SSL support is up again - Thanks to Gregor
29   -2001-Jun-17 Doychin Bondzhev
30   - - New unit IdHTTPHeaderInfo.pas that contains the
31   - TIdHeaderInfo(TIdEntytiHeaderInfo, TIdRequestHeaderInfo and TIdResponseHeaderInfo)
32   - - Still in development and not verry well tested
33   - By default when there is no authorization object associated with HTTP compoenet and there is user name and password
34   - HTTP component creates and instance of TIdBasicAuthentication class. This behaivor is for both web server and proxy server
35   - authorizations
36   -2001-Apr-17 Doychin Bondzhev
37   - - Added OnProxyAuthorization event. This event is called on 407 response from the HTTP Proxy.
38   - - Added 2 new properties in TIdHeaderInfo
39   - property AuthenticationScheme: TIdAuthenticationScheme - this property contains information for authentication scheme
40   - requested by the web server
41   - property ProxyAuthenticationScheme: TIdAuthenticationScheme - this property contains information for authentication scheme
42   - requested by the proxy server
43   - - Now the component authomaticly reconginizes the requested authorization scheme and it supports Basic like before and has been
44   - extend to support Digest authorization
45   -2001-Mar-31 Doychin Bondzhev
46   - - If there is no CookieManager it does not support cookies.
47   -2001-Feb-18 Doychin Bondzhev
48   - - Added OnAuthorization event. This event is called on 401 response from the HTTP server.
49   - This can be used to ask the user program to supply user name and password in order to acces
50   - the requested resource
51   -2001-Feb-02 Doychin Bondzhev
52   - - Added Cookie support and relative paths on redirect
53   -2000-Jul-25 Hadi Hariri
54   - - Overloaded POst and moved clearing to disconect.
55   -2000-June-22 Hadi Hariri
56   - - Added Proxy support.
57   -2000-June-10 Hadi Hariri
58   - - Added Chunk-Encoding support and HTTP version number. Some additional
59   - improvements.
60   -2000-May-23 J. Peter Mugaas
61   - -added redirect capability and supporting properties. Redirect is optional
62   - and is set with HandleRedirects. Redirection is limited to RedirectMaximum
63   - to prevent stack overflow due to recursion and to prevent redirects between
64   - two places which would cause this to go on to infinity.
65   -2000-May-22 J. Peter Mugaas
66   - -adjusted code for servers which returned LF instead of EOL
67   - -Headers are now retreived before an exception is raised. This
68   - also facilitates server redirection where the server tells the client to
69   - get a document from another location.
70   -2000-May-01 Hadi Hariri
71   - -Converted to Mercury
72   -2000-May-01 Hadi Hariri
73   - -Added PostFromStream and some clean up
74   -2000-Apr-10 Hadi Hariri
75   - -Re-done quite a few things and fixed GET bugs and finished POST method.
76   -2000-Jan-13 MTL
77   - -Moved to the New Palette Scheme
78   -2000-Jan-08 MTL
79   - -Cleaned up a few compiler hints during 7.038 build
80   -1999-Dec-10 Hadi Hariri
81   - -Started.
82   -}
83   -
84   -interface
85   -
86   -uses
87   - Classes,
88   - IdException, IdAssignedNumbers, IdHeaderList, IdHTTPHeaderInfo, IdSSLOpenSSL,
89   - IdTCPClient, IdURI, IdCookie, IdCookieManager, IdAuthentication , IdAuthenticationManager,
90   - IdMultipartFormData;
91   -
92   -type
93   - // TO DOCUMENTATION TEAM
94   - // ------------------------
95   - // For internal use. No need of documentation
96   - // hmConnect - Used to connect trought CERN proxy to SSL enabled sites.
97   - TIdHTTPMethod = (hmHead, hmGet, hmPost, hmOptions, hmTrace, hmPut, hmDelete, hmConnect);
98   - TIdHTTPWhatsNext = (wnGoToURL, wnJustExit, wnDontKnow, wnReadAndGo, wnAuthRequest);
99   - TIdHTTPConnectionType = (ctNormal, ctSSL, ctProxy, ctSSLProxy);
100   -
101   - // Protocol options
102   - TIdHTTPOption = (hoInProcessAuth, hoKeepOrigProtocol, hoForceEncodeParams);
103   - TIdHTTPOptions = set of TIdHTTPOption;
104   -
105   - // Must be documented
106   - TIdHTTPProtocolVersion = (pv1_0, pv1_1);
107   -
108   - TIdHTTPOnRedirectEvent = procedure(Sender: TObject; var dest: string; var NumRedirect: Integer; var Handled: boolean; var VMethod: TIdHTTPMethod) of object;
109   - TIdOnSelectAuthorization = procedure(Sender: TObject; var AuthenticationClass: TIdAuthenticationClass; AuthInfo: TIdHeaderList) of object;
110   - TIdOnAuthorization = procedure(Sender: TObject; Authentication: TIdAuthentication; var Handled: boolean) of object;
111   - // TIdProxyOnAuthorization = procedure(Sender: TObject; Authentication: TIdAuthentication; var Handled: boolean) of object;
112   -
113   -const
114   - Id_TIdHTTP_ProtocolVersion = pv1_1;
115   - Id_TIdHTTP_RedirectMax = 15;
116   - Id_TIdHTTP_HandleRedirects = False;
117   -
118   -type
119   - TIdCustomHTTP = class;
120   -
121   - // TO DOCUMENTATION TEAM
122   - // ------------------------
123   - // The following classes are used internally and no need of documentation
124   - // Only TIdHTTP must be documented
125   - //
126   - TIdHTTPResponse = class(TIdResponseHeaderInfo)
127   - protected
128   - FHTTP: TIdCustomHTTP;
129   - FResponseCode: Integer;
130   - FResponseText: string;
131   - FKeepAlive: Boolean;
132   - FContentStream: TStream;
133   - FResponseVersion: TIdHTTPProtocolVersion;
134   - //
135   - function GetKeepAlive: Boolean;
136   - function GetResponseCode: Integer;
137   - public
138   - constructor Create(AParent: TIdCustomHTTP); reintroduce; virtual;
139   - property KeepAlive: Boolean read GetKeepAlive write FKeepAlive;
140   - property ResponseText: string read FResponseText write FResponseText;
141   - property ResponseCode: Integer read GetResponseCode write FResponseCode;
142   - property ResponseVersion: TIdHTTPProtocolVersion read FResponseVersion write FResponseVersion;
143   - property ContentStream: TStream read FContentStream write FContentStream;
144   - end;
145   -
146   - TIdHTTPRequest = class(TIdRequestHeaderInfo)
147   - protected
148   - FHTTP: TIdCustomHTTP;
149   - FURL: string;
150   - FMethod: TIdHTTPMethod;
151   - FSourceStream: TStream;
152   - FUseProxy: TIdHTTPConnectionType;
153   - public
154   - constructor Create(AHTTP: TIdCustomHTTP); reintroduce; virtual;
155   - property URL: string read FURL write FURL;
156   - property Method: TIdHTTPMethod read FMethod write FMethod;
157   - property Source: TStream read FSourceStream write FSourceStream;
158   - property UseProxy: TIdHTTPConnectionType read FUseProxy;
159   - end;
160   -
161   - TIdHTTPProtocol = class(TObject)
162   - FHTTP: TIdCustomHTTP;
163   - FRequest: TIdHTTPRequest;
164   - FResponse: TIdHTTPResponse;
165   - public
166   - constructor Create(AConnection: TIdCustomHTTP);
167   - destructor Destroy; override;
168   - function ProcessResponse: TIdHTTPWhatsNext;
169   - procedure BuildAndSendRequest(AURI: TIdURI);
170   - procedure RetrieveHeaders;
171   -
172   - property Request: TIdHTTPRequest read FRequest;
173   - property Response: TIdHTTPResponse read FResponse;
174   - end;
175   -
176   - TIdCustomHTTP = class(TIdTCPClient)
177   - protected
178   - FCookieManager: TIdCookieManager;
179   - FFreeOnDestroy: Boolean;
180   - {Retries counter for WWW authorization}
181   - FAuthRetries: Integer;
182   - {Retries counter for proxy authorization}
183   - FAuthProxyRetries: Integer;
184   - {Max retries for authorization}
185   - FMaxAuthRetries: Integer;
186   - FAllowCookies: Boolean;
187   - FAuthenticationManager: TIdAuthenticationManager;
188   - FProtocolVersion: TIdHTTPProtocolVersion;
189   -
190   - {this is an internal counter for redirercts}
191   - FRedirectCount: Integer;
192   - FRedirectMax: Integer;
193   - FHandleRedirects: Boolean;
194   - FOptions: TIdHTTPOptions;
195   - FURI: TIdURI;
196   - FHTTPProto: TIdHTTPProtocol;
197   - FProxyParameters: TIdProxyConnectionInfo;
198   - //
199   - FOnRedirect: TIdHTTPOnRedirectEvent;
200   - FOnSelectAuthorization: TIdOnSelectAuthorization;
201   - FOnSelectProxyAuthorization: TIdOnSelectAuthorization;
202   - FOnAuthorization: TIdOnAuthorization;
203   - FOnProxyAuthorization: TIdOnAuthorization;
204   - //
205   - procedure SetHost(const Value: string); override;
206   - procedure SetPort(const Value: integer); override;
207   - procedure SetAuthenticationManager(const Value: TIdAuthenticationManager);
208   - procedure SetCookieManager(ACookieManager: TIdCookieManager);
209   - procedure SetAllowCookies(AValue: Boolean);
210   - function GetResponseCode: Integer;
211   - function GetResponseText: string;
212   - function DoOnAuthorization(ARequest: TIdHTTPRequest; AResponse: TIdHTTPResponse): Boolean; virtual;
213   - function DoOnProxyAuthorization(ARequest: TIdHTTPRequest; AResponse: TIdHTTPResponse): Boolean; virtual;
214   - function DoOnRedirect(var Location: string; var VMethod: TIdHTTPMethod; RedirectCount: integer): boolean; virtual;
215   - procedure Notification(AComponent: TComponent; Operation: TOperation); override;
216   - procedure ProcessCookies(ARequest: TIdHTTPRequest; AResponse: TIdHTTPResponse);
217   - function SetHostAndPort: TIdHTTPConnectionType;
218   - procedure SetCookies(AURL: TIdURI; ARequest: TIdHTTPRequest);
219   - procedure ReadResult(AResponse: TIdHTTPResponse);
220   - procedure PrepareRequest(ARequest: TIdHTTPRequest);
221   - procedure ConnectToHost(ARequest: TIdHTTPRequest; AResponse: TIdHTTPResponse);
222   - function GetResponseHeaders: TIdHTTPResponse;
223   - function GetRequestHeaders: TIdHTTPRequest;
224   - procedure SetRequestHeaders(const Value: TIdHTTPRequest);
225   -
226   - procedure EncodeRequestParams(const AStrings: TStrings);
227   - function SetRequestParams(const AStrings: TStrings): string;
228   -
229   - procedure CheckAndConnect(AResponse: TIdHTTPResponse);
230   - procedure DoOnDisconnected; override;
231   - public
232   - constructor Create(AOwner: TComponent); override;
233   - destructor Destroy; override;
234   - procedure DoRequest(const AMethod: TIdHTTPMethod; AURL: string;
235   - const ASource, AResponseContent: TStream); virtual;
236   - procedure Options(AURL: string); overload;
237   - procedure Get(AURL: string; const AResponseContent: TStream); overload;
238   - function Get(AURL: string): string; overload;
239   - procedure Trace(AURL: string; const AResponseContent: TStream); overload;
240   - function Trace(AURL: string): string; overload;
241   - procedure Head(AURL: string);
242   -
243   - function Post(AURL: string; const ASource: TStrings): string; overload;
244   - function Post(AURL: string; const ASource: TStream): string; overload;
245   - function Post(AURL: string; const ASource: TIdMultiPartFormDataStream): string; overload;
246   - procedure Post(AURL: string; const ASource: TStrings; const AResponseContent: TStream);
247   - overload;
248   - {Post data provided by a stream, this is for submitting data to a server}
249   - procedure Post(AURL: string; const ASource, AResponseContent: TStream);
250   - overload;
251   - procedure Post(AURL: string; const ASource: TIdMultiPartFormDataStream; AResponseContent: TStream);
252   - overload;
253   - //
254   - function Put(AURL: string; const ASource: TStream): string; overload;
255   - procedure Put(AURL: string; const ASource, AResponseContent: TStream);
256   - overload;
257   - {This is the response code number such as 404 for File not Found}
258   - property ResponseCode: Integer read GetResponseCode;
259   - {This is the text of the message such as "404 File Not Found here Sorry"}
260   - property ResponseText: string read GetResponseText;
261   - property Response: TIdHTTPResponse read GetResponseHeaders;
262   - { This is the last processed URL }
263   - property URL: TIdURI read FURI;
264   - // Num retries for Authentication
265   - property AuthRetries: Integer read FMaxAuthRetries write FMaxAuthRetries default 3;
266   - property AllowCookies: Boolean read FAllowCookies write SetAllowCookies;
267   - {Do we handle redirect requests or simply raise an exception and let the
268   - developer deal with it}
269   - property HandleRedirects: Boolean read FHandleRedirects write FHandleRedirects default Id_TIdHTTP_HandleRedirects;
270   - property ProtocolVersion: TIdHTTPProtocolVersion read FProtocolVersion write FProtocolVersion default Id_TIdHTTP_ProtocolVersion;
271   - {This is the maximum number of redirects we wish to handle, we limit this
272   - to prevent stack overflow due to recursion. Recursion is safe ONLY if
273   - prevented for continuing to infinity}
274   - property RedirectMaximum: Integer read FRedirectMax write FRedirectMax default Id_TIdHTTP_RedirectMax;
275   - property ProxyParams: TIdProxyConnectionInfo read FProxyParameters write FProxyParameters;
276   - property Request: TIdHTTPRequest read GetRequestHeaders write SetRequestHeaders;
277   - property HTTPOptions: TIdHTTPOptions read FOptions write FOptions;
278   - // Fired when a rediretion is requested.
279   - property OnRedirect: TIdHTTPOnRedirectEvent read FOnRedirect write FOnRedirect;
280   - property OnSelectAuthorization: TIdOnSelectAuthorization read FOnSelectAuthorization write FOnSelectAuthorization;
281   - property OnSelectProxyAuthorization: TIdOnSelectAuthorization read FOnSelectProxyAuthorization write FOnSelectProxyAuthorization;
282   - property OnAuthorization: TIdOnAuthorization read FOnAuthorization write FOnAuthorization;
283   - property OnProxyAuthorization: TIdOnAuthorization read FOnProxyAuthorization write FOnProxyAuthorization;
284   - // Cookie stuff
285   - property CookieManager: TIdCookieManager read FCookieManager write SetCookieManager;
286   - //
287   - property AuthenticationManager: TIdAuthenticationManager read FAuthenticationManager write SetAuthenticationManager;
288   - end;
289   -
290   - TIdHTTP = class(TIdCustomHTTP)
291   - published
292   - // Num retries for Authentication
293   - property AuthRetries;
294   - property AllowCookies;
295   - {Do we handle redirect requests or simply raise an exception and let the
296   - developer deal with it}
297   - property HandleRedirects;
298   - property ProtocolVersion;
299   - {This is the maximum number of redirects we wish to handle, we limit this
300   - to prevent stack overflow due to recursion. Recursion is safe ONLY if
301   - prevented for continuing to infinity}
302   - property RedirectMaximum;
303   - property ProxyParams;
304   - property Request;
305   - property HTTPOptions;
306   - // Fired when a rediretion is requested.
307   - property OnRedirect;
308   - property OnSelectAuthorization;
309   - property OnSelectProxyAuthorization;
310   - property OnAuthorization;
311   - property OnProxyAuthorization;
312   - property Host;
313   - property Port default IdPORT_HTTP;
314   - // Cookie stuff
315   - property CookieManager;
316   - //
317   - // property AuthenticationManager: TIdAuthenticationManager read FAuthenticationManager write SetAuthenticationManager;
318   - end;
319   -
320   - EIdUnknownProtocol = class(EIdException);
321   - EIdHTTPProtocolException = class(EIdProtocolReplyError)
322   - protected
323   - FErrorMessage: string;
324   - public
325   - constructor CreateError(const anErrCode: Integer; const asReplyMessage: string;
326   - const asErrorMessage: string); reintroduce; virtual;
327   - property ErrorMessage: string read FErrorMessage;
328   - end;
329   -
330   -implementation
331   -
332   -uses
333   - SysUtils,
334   - IdGlobal, IdComponent, IdCoderMIME, IdTCPConnection, IdResourceStrings;
335   -
336   -const
337   - ProtocolVersionString: array[TIdHTTPProtocolVersion] of string = ('1.0', '1.1');
338   -
339   -{ EIdHTTPProtocolException }
340   -
341   -constructor EIdHTTPProtocolException.CreateError(const anErrCode: Integer;
342   - const asReplyMessage: string; const asErrorMessage: string);
343   -begin
344   - inherited CreateError(anErrCode, asReplyMessage);
345   - FErrorMessage := asErrorMessage;
346   -end;
347   -
348   -{ TIdHTTP }
349   -
350   -constructor TIdCustomHTTP.Create(AOwner: TComponent);
351   -begin
352   - FURI := TIdURI.Create('');
353   -
354   - inherited Create(AOwner);
355   - Port := IdPORT_HTTP;
356   -
357   - FAuthRetries := 0;
358   - FAuthProxyRetries := 0;
359   - FMaxAuthRetries := 3;
360   - AllowCookies := true;
361   - FFreeOnDestroy := false;
362   - FOptions := [hoForceEncodeParams];
363   -
364   - FRedirectMax := Id_TIdHTTP_RedirectMax;
365   - FHandleRedirects := Id_TIdHTTP_HandleRedirects;
366   - //
367   - FProtocolVersion := Id_TIdHTTP_ProtocolVersion;
368   -
369   - FHTTPProto := TIdHTTPProtocol.Create(self);
370   - FProxyParameters := TIdProxyConnectionInfo.Create;
371   - FProxyParameters.Clear;
372   -end;
373   -
374   -destructor TIdCustomHTTP.Destroy;
375   -begin
376   - FreeAndNil(FHTTPProto);
377   - FreeAndNil(FURI);
378   - FreeAndNil(FProxyParameters);
379   -
380   - {if FFreeOnDestroy then
381   - begin
382   - FreeAndNil(FCookieManager);
383   - end;}
384   -
385   - inherited Destroy;
386   -end;
387   -
388   -procedure TIdCustomHTTP.Options(AURL: string);
389   -begin
390   - DoRequest(hmOptions, AURL, nil, nil);
391   -end;
392   -
393   -procedure TIdCustomHTTP.Get(AURL: string; const AResponseContent: TStream);
394   -begin
395   - DoRequest(hmGet, AURL, nil, AResponseContent);
396   -end;
397   -
398   -procedure TIdCustomHTTP.Trace(AURL: string; const AResponseContent: TStream);
399   -begin
400   - DoRequest(hmTrace, AURL, nil, AResponseContent);
401   -end;
402   -
403   -procedure TIdCustomHTTP.Head(AURL: string);
404   -begin
405   - DoRequest(hmHead, AURL, nil, nil);
406   -end;
407   -
408   -procedure TIdCustomHTTP.Post(AURL: string; const ASource, AResponseContent: TStream);
409   -var
410   - OldProtocol: TIdHTTPProtocolVersion;
411   -begin
412   - // PLEASE READ CAREFULLY
413   -
414   - // Currently when issuing a POST, IdHTTP will automatically set the protocol
415   - // to version 1.0 independently of the value it had initially. This is because
416   - // there are some servers that don't respect the RFC to the full extent. In
417   - // particular, they don't respect sending/not sending the Expect: 100-Continue
418   - // header. Until we find an optimum solution that does NOT break the RFC, we
419   - // will restrict POSTS to version 1.0.
420   - if Connected then
421   - begin
422   - Disconnect;
423   - end;
424   - OldProtocol := FProtocolVersion;
425   - // If hoKeepOrigProtocol is SET, is possible to assume that the developer
426   - // is sure in operations of the server
427   - if not (hoKeepOrigProtocol in FOptions) then
428   - FProtocolVersion := pv1_0;
429   - DoRequest(hmPost, AURL, ASource, AResponseContent);
430   - FProtocolVersion := OldProtocol;
431   -end;
432   -
433   -procedure TIdCustomHTTP.EncodeRequestParams(const AStrings: TStrings);
434   -var
435   - i: Integer;
436   - S: string;
437   -begin
438   - for i := 0 to AStrings.Count - 1 do begin
439   - S := AStrings.Names[i];
440   - if Length(AStrings.Values[S]) > 0 then begin
441   - AStrings.Values[S] := TIdURI.ParamsEncode(AStrings.Values[S]);
442   - end;
443   - end;
444   -end;
445   -
446   -function TIdCustomHTTP.SetRequestParams(const AStrings: TStrings): string;
447   -var
448   - S: string;
449   -begin
450   - if Assigned(AStrings) then begin
451   - if hoForceEncodeParams in FOptions then
452   - EncodeRequestParams(AStrings);
453   - if AStrings.Count > 1 then
454   - S := StringReplace(AStrings.Text, sLineBreak, '&', [rfReplaceall])
455   - else
456   - S := AStrings.Text;
457   - // break trailing CR&LF
458   - Result := Trim(S);
459   - end else
460   - Result := '';
461   -end;
462   -
463   -procedure TIdCustomHTTP.Post(AURL: string; const ASource: TStrings; const AResponseContent: TStream);
464   -var
465   - LParams: TStringStream;
466   -begin
467   - // Usual posting request have default ContentType is application/x-www-form-urlencoded
468   - if (Request.ContentType = '') or (AnsiSameText(Request.ContentType, 'text/html')) then
469   - Request.ContentType := 'application/x-www-form-urlencoded';
470   -
471   - LParams := TStringStream.Create(SetRequestParams(ASource));
472   - try
473   - Post(AURL, LParams, AResponseContent);
474   - finally
475   - LParams.Free;
476   - end;
477   -end;
478   -
479   -function TIdCustomHTTP.Post(AURL: string; const ASource: TStrings): string;
480   -var
481   - LResponse: TStringStream;
482   -begin
483   - LResponse := TStringStream.Create('');
484   - try
485   - Post(AURL, ASource, LResponse);
486   - finally
487   - result := LResponse.DataString;
488   - LResponse.Free;
489   - end;
490   -end;
491   -
492   -function TIdCustomHTTP.Post(AURL: string; const ASource: TStream): string;
493   -var
494   - LResponse: TStringStream;
495   -begin
496   - LResponse := TStringStream.Create('');
497   - try
498   - Post(AURL, ASource, LResponse);
499   - finally
500   - result := LResponse.DataString;
501   - LResponse.Free;
502   - end;
503   -end;
504   -
505   -procedure TIdCustomHTTP.Put(AURL: string; const ASource, AResponseContent: TStream);
506   -begin
507   - DoRequest(hmPut, AURL, ASource, AResponseContent);
508   -end;
509   -
510   -function TIdCustomHTTP.Put(AURL: string; const ASource: TStream): string;
511   -var
512   - LResponse: TStringStream;
513   -begin
514   - LResponse := TStringStream.Create('');
515   - try
516   - Put(AURL, ASource, LResponse);
517   - finally
518   - result := LResponse.DataString;
519   - LResponse.Free;
520   - end;
521   -end;
522   -
523   -function TIdCustomHTTP.Get(AURL: string): string;
524   -var
525   - Stream: TMemoryStream;
526   -begin
527   - Stream := TMemoryStream.Create;
528   - try
529   - Get(AURL, Stream);
530   - finally
531   - if Stream.Size > 0 then // DO we have result?
532   - begin
533   - SetLength(result, Stream.Size);
534   - Move(PChar(Stream.Memory)^, result[1], Stream.Size);
535   - end;
536   - Stream.Free;
537   - end;
538   -end;
539   -
540   -function TIdCustomHTTP.Trace(AURL: string): string;
541   -var
542   - Stream: TStringStream;
543   -begin
544   - Stream := TStringStream.Create(''); try
545   - Trace(AURL, Stream);
546   - result := Stream.DataString;
547   - finally Stream.Free; end;
548   -end;
549   -
550   -function TIdCustomHTTP.DoOnRedirect(var Location: string; var VMethod: TIdHTTPMethod; RedirectCount: integer): boolean;
551   -begin
552   - result := HandleRedirects;
553   - if assigned(FOnRedirect) then
554   - begin
555   - FOnRedirect(self, Location, RedirectCount, result, VMethod);
556   - end;
557   -end;
558   -
559   -procedure TIdCustomHTTP.SetCookies(AURL: TIdURI; ARequest: TIdHTTPRequest);
560   -var
561   - S: string;
562   -begin
563   - if Assigned(FCookieManager) then
564   - begin
565   - // Send secure cookies only if we have Secured connection
566   - S := FCookieManager.GenerateCookieList(AURL, (IOHandler is TIdSSLIOHandlerSocket));
567   - if Length(S) > 0 then
568   - begin
569   - ARequest.RawHeaders.Values['Cookie'] := S;
570   - end;
571   - end;
572   -end;
573   -
574   -// This function sets the Host and Port and returns a boolean depending on
575   -// whether a PROXY is being used or not.
576   -
577   -function TIdCustomHTTP.SetHostAndPort: TIdHTTPConnectionType;
578   -begin
579   - // First check to see if a Proxy has been specified.
580   - if Length(ProxyParams.ProxyServer) > 0 then
581   - begin
582   - if ((not AnsiSameText(Host, ProxyParams.ProxyServer)) or
583   - (Port <> ProxyParams.ProxyPort)) and (Connected) then
584   - begin
585   - Disconnect;
586   - end;
587   -
588   - FHost := ProxyParams.ProxyServer;
589   - FPort := ProxyParams.ProxyPort;
590   -
591   - if AnsiSameText(URL.Protocol, 'HTTPS') then
592   - begin
593   - Result := ctSSLProxy;
594   -
595   - if Assigned(IOHandler) then
596   - begin
597   - if not (IOHandler is TIdSSLIOHandlerSocket) then
598   - begin
599   - raise EIdIOHandlerPropInvalid.Create(RSIOHandlerPropInvalid);
600   - end else begin
601   - (IOHandler as TIdSSLIOHandlerSocket).PassThrough := true;
602   - end;
603   - end;
604   - end
605   - else begin
606   - Result := ctProxy;
607   - if Assigned(IOHandler) and (IOHandler is TIdSSLIOHandlerSocket) then
608   - begin
609   - (IOHandler as TIdSSLIOHandlerSocket).PassThrough := true;
610   - end;
611   - end;
612   - end
613   - else begin
614   - Result := ctNormal;
615   -
616   - if ((not AnsiSameText(Host, URL.Host)) or (Port <> StrToInt(URL.Port))) then begin
617   - if Connected then begin
618   - Disconnect;
619   - end;
620   - Host := URL.Host;
621   - Port := StrToInt(URL.Port);
622   - end;
623   -
624   - if AnsiSameText(URL.Protocol, 'HTTPS') then
625   - begin
626   - // Just check can we do SSL
627   - if not Assigned(IOHandler) or (not (IOHandler is TIdSSLIOHandlerSocket)) then
628   - raise EIdIOHandlerPropInvalid.Create(RSIOHandlerPropInvalid)
629   - else begin
630   - (IOHandler as TIdSSLIOHandlerSocket).PassThrough := false;
631   - result := ctSSL;
632   - end;
633   - end
634   - else
635   - begin
636   - if Assigned(IOHandler) then
637   - begin
638   - if (IOHandler is TIdSSLIOHandlerSocket) then
639   - begin
640   - (IOHandler as TIdSSLIOHandlerSocket).PassThrough := true;
641   - end;
642   - end;
643   - end;
644   - end;
645   -end;
646   -
647   -procedure TIdCustomHTTP.ReadResult(AResponse: TIdHTTPResponse);
648   -var
649   - Size: Integer;
650   -
651   - function ChunkSize: integer;
652   - var
653   - j: Integer;
654   - s: string;
655   - begin
656   - s := ReadLn;
657   - j := AnsiPos(' ', s);
658   - if j > 0 then
659   - begin
660   - s := Copy(s, 1, j - 1);
661   - end;
662   - Result := StrToIntDef('$' + s, 0);
663   - end;
664   -
665   -begin
666   - if Assigned(AResponse.ContentStream) then // Only for Get and Post
667   - begin
668   - if AResponse.ContentLength > 0 then // If chunked then this is also 0
669   - begin
670   - try
671   - ReadStream(AResponse.ContentStream, AResponse.ContentLength);
672   - except
673   - on E: EIdConnClosedGracefully do
674   - end;
675   - end
676   - else
677   - begin
678   - if AnsiPos('chunked', AResponse.RawHeaders.Values['Transfer-Encoding']) > 0 then {do not localize}
679   - begin // Chunked
680   - DoStatus(hsStatusText, [RSHTTPChunkStarted]);
681   - Size := ChunkSize;
682   - while Size > 0 do
683   - begin
684   - ReadStream(AResponse.ContentStream, Size);
685   - ReadLn; // blank line
686   - Size := ChunkSize;
687   - end;
688   - ReadLn; // blank line
689   - end
690   - else begin
691   - if not AResponse.HasContentLength then
692   - ReadStream(AResponse.ContentStream, -1, True);
693   - end;
694   - end;
695   - end;
696   -end;
697   -
698   -procedure TIdCustomHTTP.PrepareRequest(ARequest: TIdHTTPRequest);
699   -var
700   - LURI: TIdURI;
701   -begin
702   - LURI := TIdURI.Create(ARequest.URL);
703   -
704   - if Length(LURI.Username) > 0 then
705   - begin
706   - ARequest.Username := LURI.Username;
707   - ARequest.Password := LURI.Password;
708   - end;
709   -
710   - FURI.Username := ARequest.Username;
711   - FURI.Password := ARequest.Password;
712   -
713   - FURI.Path := ProcessPath(FURI.Path, LURI.Path);
714   - FURI.Document := LURI.Document;
715   - FURI.Params := LURI.Params;
716   -
717   - if Length(LURI.Host) > 0 then begin
718   - FURI.Host := LURI.Host;
719   - end;
720   -
721   - if Length(LURI.Protocol) > 0 then begin
722   - FURI.Protocol := LURI.Protocol;
723   - end else begin
724   - FURI.Protocol := 'http';
725   - end;
726   -
727   - if Length(LURI.Port) > 0 then begin
728   - FURI.Port := LURI.Port;
729   - end
730   - else begin
731   - case StrToIntDef(FURI.Port, 0) of
732   - 0, IdPORT_HTTP, IdPORT_SSL: begin
733   - if AnsiSameText(FURI.Protocol, 'http') then begin
734   - FURI.Port := IntToStr(IdPORT_HTTP);
735   - end else begin
736   - if AnsiSameText(FURI.Protocol, 'https') then begin
737   - FURI.Port := IntToStr(IdPORT_SSL);
738   - end else begin
739   - raise EIdUnknownProtocol.Create('');
740   - end;
741   - end;
742   - end;
743   - end;
744   - end;
745   -
746   - // The URL part is not URL encoded at this place
747   -
748   - ARequest.URL := URL.Path + URL.Document + URL.Params;
749   -
750   - if ARequest.Method = hmOptions then
751   - begin
752   - if AnsiSameText(LURI.Document, '*') then
753   - begin
754   - ARequest.URL := LURI.Document;
755   - end;
756   - end;
757   - LURI.Free; // Free URI Object;
758   -
759   - // Check for valid HTTP request methods
760   - if ARequest.Method in [hmTrace, hmPut, hmOptions, hmDelete] then
761   - begin
762   - if ProtocolVersion <> pv1_1 then
763   - begin
764   - raise EIdException.Create('This request method is supported in HTTP 1.1');
765   - end;
766   - end;
767   -
768   - if ARequest.Method in [hmPost, hmPut] then
769   - begin
770   - ARequest.ContentLength := ARequest.Source.Size;
771   - end
772   - else ARequest.ContentLength := -1;
773   -
774   - if FURI.Port <> IntToStr(IdPORT_HTTP) then
775   - ARequest.Host := FURI.Host + ':' + FURI.Port
776   - else
777   - ARequest.Host := FURI.Host;
778   -end;
779   -
780   -procedure TIdCustomHTTP.CheckAndConnect(AResponse: TIdHTTPResponse);
781   -begin
782   - if not AResponse.KeepAlive then begin
783   - Disconnect;
784   - end;
785   -
786   - CheckForGracefulDisconnect(false);
787   -
788   - if not Connected then try
789   - Connect(ReadTimeout);
790   - except
791   - on E: EIdSSLProtocolReplyError do
792   - begin
793   - Disconnect;
794   - raise;
795   - end;
796   - end;
797   -end;
798   -
799   -
800   -procedure TIdCustomHTTP.ConnectToHost(ARequest: TIdHTTPRequest; AResponse: TIdHTTPResponse);
801   -var
802   - LLocalHTTP: TIdHTTPProtocol;
803   -begin
804   - ARequest.FUseProxy := SetHostAndPort;
805   -
806   - if ARequest.UseProxy = ctProxy then
807   - begin
808   - ARequest.URL := FURI.URI;
809   - end;
810   -
811   - case ARequest.UseProxy of
812   - ctNormal:
813   - if (ProtocolVersion = pv1_0) and (Length(ARequest.Connection) = 0) then
814   - ARequest.Connection := 'keep-alive';
815   - ctSSL, ctSSLProxy: ARequest.Connection := '';
816   - ctProxy:
817   - if (ProtocolVersion = pv1_0) and (Length(ARequest.Connection) = 0) then
818   - ARequest.ProxyConnection := 'keep-alive';
819   - end;
820   -
821   - if ARequest.UseProxy = ctSSLProxy then begin
822   - LLocalHTTP := TIdHTTPProtocol.Create(Self);
823   -
824   - with LLocalHTTP do begin
825   - Request.UserAgent := ARequest.UserAgent;
826   - Request.Host := ARequest.Host;
827   - Request.ContentLength := ARequest.ContentLength;
828   - Request.Pragma := 'no-cache';
829   - Request.URL := URL.Host + ':' + URL.Port;
830   - Request.Method := hmConnect;
831   - Request.ProxyConnection := 'keep-alive';
832   - Response.ContentStream := TMemoryStream.Create;
833   - try
834   - try
835   - repeat
836   - CheckAndConnect(Response);
837   - BuildAndSendRequest(nil);
838   -
839   - Response.ResponseText := ReadLn;
840   - if Length(Response.ResponseText) = 0 then begin
841   - Response.ResponseText := 'HTTP/1.0 200 OK'; // Support for HTTP responses whithout Status line and headers
842   - Response.Connection := 'close';
843   - end
844   - else begin
845   - RetrieveHeaders;
846   - ProcessCookies(LLocalHTTP.Request, LLocalHTTP.Response);
847   - end;
848   -
849   - if Response.ResponseCode = 200 then
850   - begin
851   - // Connection established
852   - (IOHandler as TIdSSLIOHandlerSocket).PassThrough := false;
853   - break;
854   - end
855   - else begin
856   - ProcessResponse;
857   - end;
858   - until false;
859   - except
860   - raise;
861   - // TODO: Add property that will contain the error messages.
862   - end;
863   - finally
864   - LLocalHTTP.Response.ContentStream.Free;
865   - LLocalHTTP.Free;
866   - end;
867   - end;
868   - end
869   - else begin
870   - CheckAndConnect(AResponse);
871   - end;
872   -
873   - FHTTPProto.BuildAndSendRequest(URL);
874   -
875   - if (ARequest.Method in [hmPost, hmPut]) then
876   - begin
877   - WriteStream(ARequest.Source, True, false);
878   - end;
879   -end;
880   -
881   -procedure TIdCustomHTTP.DoRequest(const AMethod: TIdHTTPMethod; AURL: string;
882   - const ASource, AResponseContent: TStream);
883   -var
884   - LResponseLocation: Integer;
885   -begin
886   - if Assigned(AResponseContent) then
887   - begin
888   - LResponseLocation := AResponseContent.Position;
889   - end
890   - else
891   - LResponseLocation := 0; // Just to avoid the waringing message
892   -
893   - FAuthRetries := 0;
894   - FAuthProxyRetries := 0;
895   -
896   - Request.URL := AURL;
897   - Request.Method := AMethod;
898   - Request.Source := ASource;
899   - Response.ContentStream := AResponseContent;
900   -
901   - try
902   - repeat
903   - Inc(FRedirectCount);
904   -
905   - PrepareRequest(Request);
906   - ConnectToHost(Request, Response);
907   -
908   - // Workaround for servers wich respond with 100 Continue on GET and HEAD
909   - // This workaround is just for temporary use until we have final HTTP 1.1
910   - // realisation
911   - repeat
912   - Response.ResponseText := ReadLn;
913   - FHTTPProto.RetrieveHeaders;
914   - ProcessCookies(Request, Response);
915   - until Response.ResponseCode <> 100;
916   -
917   - case FHTTPProto.ProcessResponse of
918   - wnAuthRequest: begin
919   - Dec(FRedirectCount);
920   - Request.URL := AURL;
921   - end;
922   - wnReadAndGo: begin
923   - ReadResult(Response);
924   - if Assigned(AResponseContent) then
925   - begin
926   - AResponseContent.Position := LResponseLocation;
927   - AResponseContent.Size := LResponseLocation;
928   - end;
929   - FAuthRetries := 0;
930   - FAuthProxyRetries := 0;
931   - end;
932   - wnGoToURL: begin
933   - if Assigned(AResponseContent) then
934   - begin
935   - AResponseContent.Position := LResponseLocation;
936   - AResponseContent.Size := LResponseLocation;
937   - end;
938   - FAuthRetries := 0;
939   - FAuthProxyRetries := 0;
940   - end;
941   - wnJustExit: begin
942   - break;
943   - end;
944   - wnDontKnow:
945   - // TODO: This is for temporary use. Will remove it for final release
946   - raise EIdException.Create('Undefined situation');
947   - end;
948   - until false;
949   - finally
950   - if not Response.KeepAlive then begin
951   - Disconnect;
952   - end;
953   - end;
954   - FRedirectCount := 0;
955   -end;
956   -
957   -procedure TIdCustomHTTP.SetAllowCookies(AValue: Boolean);
958   -begin
959   - FAllowCookies := AValue;
960   -end;
961   -
962   -procedure TIdCustomHTTP.ProcessCookies(ARequest: TIdHTTPRequest; AResponse: TIdHTTPResponse);
963   -var
964   - Cookies, Cookies2: TStringList;
965   - i: Integer;
966   -begin
967   - Cookies := nil;
968   - Cookies2 := nil;
969   - try
970   - if not Assigned(FCookieManager) and AllowCookies then
971   - begin
972   - CookieManager := TIdCookieManager.Create(Self);
973   - FFreeOnDestroy := true;
974   - end;
975   -
976   - if Assigned(FCookieManager) then
977   - begin
978   - Cookies := TStringList.Create;
979   - Cookies2 := TStringList.Create;
980   -
981   - AResponse.RawHeaders.Extract('Set-cookie', Cookies);
982   - AResponse.RawHeaders.Extract('Set-cookie2', Cookies2);
983   -
984   - for i := 0 to Cookies.Count - 1 do
985   - CookieManager.AddCookie(Cookies[i], FURI.Host);
986   -
987   - for i := 0 to Cookies2.Count - 1 do
988   - CookieManager.AddCookie2(Cookies2[i], FURI.Host);
989   - end;
990   - finally
991   - FreeAndNil(Cookies);
992   - FreeAndNil(Cookies2);
993   - end;
994   -end;
995   -
996   -procedure TIdCustomHTTP.Notification(AComponent: TComponent; Operation: TOperation);
997   -begin
998   - inherited Notification(AComponent, Operation);
999   - if Operation = opRemove then
1000   - begin
1001   - if (AComponent = FCookieManager) then
1002   - begin
1003   - FCookieManager := nil;
1004   - end;
1005   - if AComponent = FAuthenticationManager then
1006   - begin
1007   - FAuthenticationManager := nil;
1008   - end;
1009   - end;
1010   -end;
1011   -
1012   -procedure TIdCustomHTTP.SetCookieManager(ACookieManager: TIdCookieManager);
1013   -begin
1014   - if Assigned(FCookieManager) then
1015   - begin
1016   - if FFreeOnDestroy then begin
1017   - FCookieManager.Free;
1018   - end;
1019   - end;
1020   -
1021   - FCookieManager := ACookieManager;
1022   - FFreeOnDestroy := false;
1023   -
1024   - if Assigned(FCookieManager) then
1025   - begin
1026   - FCookieManager.FreeNotification(Self);
1027   - end;
1028   -end;
1029   -
1030   -function TIdCustomHTTP.DoOnAuthorization(ARequest: TIdHTTPRequest; AResponse: TIdHTTPResponse): Boolean;
1031   -var
1032   - i: Integer;
1033   - S: string;
1034   - Auth: TIdAuthenticationClass;
1035   -begin
1036   - Inc(FAuthRetries);
1037   - if not Assigned(ARequest.Authentication) then
1038   - begin
1039   - // Find wich Authentication method is supported from us.
1040   - for i := 0 to AResponse.WWWAuthenticate.Count - 1 do
1041   - begin
1042   - S := AResponse.WWWAuthenticate[i];
1043   - Auth := FindAuthClass(Fetch(S));
1044   - if Auth <> nil then
1045   - break;
1046   - end;
1047   -
1048   - if Auth = nil then begin
1049   - result := false;
1050   - exit;
1051   - end;
1052   -
1053   - if Assigned(FOnSelectAuthorization) then
1054   - begin
1055   - OnSelectAuthorization(self, Auth, AResponse.WWWAuthenticate);
1056   - end;
1057   -
1058   - ARequest.Authentication := Auth.Create;
1059   - end;
1060   -
1061   - // Clear password and reset autorization if previous failed
1062   - {if (AResponse.FResponseCode = 401) then begin
1063   - ARequest.Password := '';
1064   - ARequest.Authentication.Reset;
1065   - end;}
1066   -
1067   - result := Assigned(FOnAuthorization);
1068   -
1069   - if Result then
1070   - begin
1071   - with ARequest.Authentication do
1072   - begin
1073   - Username := ARequest.Username;
1074   - Password := ARequest.Password;
1075   - Params.Values['Authorization'] := ARequest.Authentication.Authentication;
1076   - AuthParams := AResponse.WWWAuthenticate;
1077   - end;
1078   -
1079   - result := false;
1080   -
1081   - repeat
1082   - case ARequest.Authentication.Next of
1083   - wnAskTheProgram:
1084   - begin // Ask the user porgram to supply us with authorization information
1085   - if Assigned(FOnAuthorization) then
1086   - begin
1087   - ARequest.Authentication.UserName := ARequest.Username;
1088   - ARequest.Authentication.Password := ARequest.Password;
1089   -
1090   - OnAuthorization(self, ARequest.Authentication, result);
1091   -
1092   - if result then begin
1093   - ARequest.BasicAuthentication := true;
1094   - ARequest.Username := ARequest.Authentication.UserName;
1095   - ARequest.Password := ARequest.Authentication.Password;
1096   - end
1097   - else begin
1098   - break;
1099   - end;
1100   - end;
1101   - end;
1102   - wnDoRequest:
1103   - begin
1104   - result := true;
1105   - break;
1106   - end;
1107   - wnFail:
1108   - begin
1109   - result := False;
1110   - Break;
1111   - end;
1112   - end;
1113   - until false;
1114   - end;
1115   -end;
1116   -
1117   -function TIdCustomHTTP.DoOnProxyAuthorization(ARequest: TIdHTTPRequest; AResponse: TIdHTTPResponse): Boolean;
1118   -var
1119   - i: Integer;
1120   - S: string;
1121   - Auth: TIdAuthenticationClass;
1122   -begin
1123   - Inc(FAuthProxyRetries);
1124   - if not Assigned(ProxyParams.Authentication) then
1125   - begin
1126   - // Find wich Authentication method is supported from us.
1127   - for i := 0 to AResponse.ProxyAuthenticate.Count - 1 do
1128   - begin
1129   - S := AResponse.ProxyAuthenticate[i];
1130   - try
1131   - Auth := FindAuthClass(Fetch(S));
1132   - break;
1133   - except
1134   - end;
1135   - end;
1136   -
1137   - if i = AResponse.ProxyAuthenticate.Count then
1138   - begin
1139   - result := false;
1140   - exit;
1141   - end;
1142   -
1143   - if Assigned(FOnSelectProxyAuthorization) then
1144   - begin
1145   - OnSelectProxyAuthorization(self, Auth, AResponse.ProxyAuthenticate);
1146   - end;
1147   -
1148   - ProxyParams.Authentication := Auth.Create;
1149   - end;
1150   -
1151   - result := Assigned(OnProxyAuthorization);
1152   -
1153   - // Clear password and reset autorization if previous failed
1154   - if (AResponse.FResponseCode = 407) then begin
1155   - ProxyParams.ProxyPassword := '';
1156   - ProxyParams.Authentication.Reset;
1157   - end;
1158   -
1159   - if Result then
1160   - begin
1161   - with ProxyParams.Authentication do
1162   - begin
1163   - Username := ProxyParams.ProxyUsername;
1164   - Password := ProxyParams.ProxyPassword;
1165   -
1166   - AuthParams := AResponse.ProxyAuthenticate;
1167   - end;
1168   -
1169   - result := false;
1170   -
1171   - repeat
1172   - case ProxyParams.Authentication.Next of
1173   - wnAskTheProgram: // Ask the user porgram to supply us with authorization information
1174   - begin
1175   - if Assigned(OnProxyAuthorization) then
1176   - begin
1177   - ProxyParams.Authentication.Username := ProxyParams.ProxyUsername;
1178   - ProxyParams.Authentication.Password := ProxyParams.ProxyPassword;
1179   -
1180   - OnProxyAuthorization(self, ProxyParams.Authentication, result);
1181   -
1182   - if result then begin
1183   - ProxyParams.ProxyUsername := ProxyParams.Authentication.Username;
1184   - ProxyParams.ProxyPassword := ProxyParams.Authentication.Password;
1185   - end
1186   - else begin
1187   - break;
1188   - end;
1189   - end;
1190   - end;
1191   - wnDoRequest:
1192   - begin
1193   - result := true;
1194   - break;
1195   - end;
1196   - wnFail:
1197   - begin
1198   - result := False;
1199   - Break;
1200   - end;
1201   - end;
1202   - until false;
1203   - end;
1204   -end;
1205   -
1206   -function TIdCustomHTTP.GetResponseCode: Integer;
1207   -begin
1208   - result := Response.ResponseCode;
1209   -end;
1210   -
1211   -function TIdCustomHTTP.GetResponseText: string;
1212   -begin
1213   - result := Response.FResponseText;
1214   -end;
1215   -
1216   -function TIdCustomHTTP.GetResponseHeaders: TIdHTTPResponse;
1217   -begin
1218   - result := FHTTPProto.Response;
1219   -end;
1220   -
1221   -function TIdCustomHTTP.GetRequestHeaders: TIdHTTPRequest;
1222   -begin
1223   - result := FHTTPProto.Request;
1224   -end;
1225   -
1226   -procedure TIdCustomHTTP.DoOnDisconnected;
1227   -begin
1228   - inherited DoOnDisconnected;
1229   -
1230   - if Assigned(Request.Authentication) and
1231   - (Request.Authentication.CurrentStep = Request.Authentication.Steps) then begin
1232   - if Assigned(AuthenticationManager) then begin
1233   - AuthenticationManager.AddAuthentication(Request.Authentication, URL);
1234   - end;
1235   - FreeAndNil(Request.Authentication);
1236   - end;
1237   -
1238   - if Assigned(ProxyParams.Authentication) then begin
1239   - ProxyParams.Authentication.Reset;
1240   - end;
1241   -end;
1242   -
1243   -procedure TIdCustomHTTP.SetAuthenticationManager(const Value: TIdAuthenticationManager);
1244   -begin
1245   - FAuthenticationManager := Value;
1246   - if Assigned(FAuthenticationManager) then
1247   - begin
1248   - FAuthenticationManager.FreeNotification(self);
1249   - end;
1250   -end;
1251   -
1252   -procedure TIdCustomHTTP.SetHost(const Value: string);
1253   -begin
1254   - inherited SetHost(Value);
1255   - URL.Host := Value;
1256   -end;
1257   -
1258   -procedure TIdCustomHTTP.SetPort(const Value: integer);
1259   -begin
1260   - inherited SetPort(Value);
1261   - URL.Port := IntToStr(Value);
1262   -end;
1263   -
1264   -procedure TIdCustomHTTP.SetRequestHEaders(const Value: TIdHTTPRequest);
1265   -begin
1266   - FHTTPProto.Request.Assign(Value);
1267   -end;
1268   -
1269   -procedure TIdCustomHTTP.Post(AURL: string;
1270   - const ASource: TIdMultiPartFormDataStream; AResponseContent: TStream);
1271   -begin
1272   - Request.ContentType := ASource.RequestContentType;
1273   - Post(AURL, TStream(ASource), AResponseContent);
1274   -end;
1275   -
1276   -function TIdCustomHTTP.Post(AURL: string;
1277   - const ASource: TIdMultiPartFormDataStream): string;
1278   -begin
1279   - Request.ContentType := ASource.RequestContentType;
1280   - result := Post(AURL, TStream(ASource));
1281   -end;
1282   -
1283   -{ TIdHTTPResponse }
1284   -
1285   -constructor TIdHTTPResponse.Create(AParent: TIdCustomHTTP);
1286   -begin
1287   - inherited Create;
1288   -
1289   - FHTTP := AParent;
1290   -end;
1291   -
1292   -function TIdHTTPResponse.GetKeepAlive: Boolean;
1293   -var
1294   - S: string;
1295   - i: TIdHTTPProtocolVersion;
1296   -begin
1297   - S := Copy(FResponseText, 6, 3);
1298   -
1299   - for i := Low(TIdHTtpProtocolVersion) to High(TIdHTtpProtocolVersion) do
1300   - if AnsiSameText(ProtocolVersionString[i], S) then
1301   - begin
1302   - ResponseVersion := i;
1303   - break;
1304   - end;
1305   -
1306   - FHTTP.CheckForDisconnect(false);
1307   - FKeepAlive := FHTTP.Connected;
1308   -
1309   - if FKeepAlive then
1310   - case FHTTP.ProtocolVersion of
1311   - pv1_1: // By default we assume that keep-alive is by default and will close the connection only there is "close"
1312   - begin
1313   - FKeepAlive :=
1314   - not (AnsiSameText(Trim(Connection), 'CLOSE') or
1315   - AnsiSameText(Trim(ProxyConnection), 'CLOSE'));
1316   - end;
1317   - pv1_0: // By default we assume that keep-alive is not by default and will keep the connection only if there is "keep-alive"
1318   - begin
1319   - FKeepAlive := AnsiSameText(Trim(Connection), 'KEEP-ALIVE') or
1320   - AnsiSameText(Trim(ProxyConnection), 'KEEP-ALIVE') {or
1321   - ((ResponseVersion = pv1_1) and (Length(Trim(Connection)) = 0) and
1322   - (Length(Trim(ProxyConnection)) = 0))};
1323   - end;
1324   - end;
1325   - result := FKeepAlive;
1326   -end;
1327   -
1328   -function TIdHTTPResponse.GetResponseCode: Integer;
1329   -var
1330   - S: string;
1331   -begin
1332   - S := FResponseText;
1333   - Fetch(S);
1334   - S := Trim(S);
1335   - FResponseCode := StrToIntDef(Fetch(S, ' ', False), -1);
1336   - Result := FResponseCode;
1337   -end;
1338   -
1339   -{ TIdHTTPRequest }
1340   -
1341   -constructor TIdHTTPRequest.Create(AHTTP: TIdCustomHTTP);
1342   -begin
1343   - inherited Create;
1344   -
1345   - FHTTP := AHTTP;
1346   - FUseProxy := ctNormal;
1347   -end;
1348   -
1349   -{ TIdHTTPProtocol }
1350   -
1351   -constructor TIdHTTPProtocol.Create(AConnection: TIdCustomHTTP);
1352   -begin
1353   - inherited Create;
1354   - FHTTP := AConnection;
1355   - // Create the headers
1356   - FRequest := TIdHTTPRequest.Create(FHTTP);
1357   - FResponse := TIdHTTPResponse.Create(FHTTP);
1358   -end;
1359   -
1360   -destructor TIdHTTPProtocol.Destroy;
1361   -begin
1362   - FreeAndNil(FRequest);
1363   - FreeAndNil(FResponse);
1364   -
1365   - inherited Destroy;
1366   -end;
1367   -
1368   -procedure TIdHTTPProtocol.BuildAndSendRequest(AURI: TIdURI);
1369   -var
1370   - i: Integer;
1371   -begin
1372   - Request.SetHeaders;
1373   - FHTTP.ProxyParams.SetHeaders(Request.RawHeaders);
1374   - if Assigned(AURI) then
1375   - FHTTP.SetCookies(AURI, Request);
1376   -
1377   - // This is a wrokaround for some HTTP servers wich does not implement properly the HTTP protocol
1378   - FHTTP.OpenWriteBuffer;
1379   - case Request.Method of
1380   - hmHead: FHTTP.WriteLn('HEAD ' + Request.URL + ' HTTP/' + ProtocolVersionString[FHTTP.ProtocolVersion]); {do not localize}
1381   - hmGet: FHTTP.WriteLn('GET ' + Request.URL + ' HTTP/' + ProtocolVersionString[FHTTP.ProtocolVersion]); {do not localize}
1382   - hmPost: FHTTP.WriteLn('POST ' + Request.URL + ' HTTP/' + ProtocolVersionString[FHTTP.ProtocolVersion]); {do not localize}
1383   - // HTTP 1.1 only
1384   - hmOptions: FHTTP.WriteLn('OPTIONS ' + Request.URL + ' HTTP/' + ProtocolVersionString[FHTTP.ProtocolVersion]); {do not localize}
1385   - hmTrace: FHTTP.WriteLn('TRACE ' + Request.URL + ' HTTP/' + ProtocolVersionString[FHTTP.ProtocolVersion]); {do not localize}
1386   - hmPut: FHTTP.WriteLn('PUT ' + Request.URL + ' HTTP/' + ProtocolVersionString[FHTTP.ProtocolVersion]); {do not localize}
1387   - hmConnect: FHTTP.WriteLn('CONNECT ' + Request.URL + ' HTTP/' + ProtocolVersionString[FHTTP.ProtocolVersion]); {do not localize}
1388   - end;
1389   - // write the headers
1390   - for i := 0 to Request.RawHeaders.Count - 1 do
1391   - if Length(Request.RawHeaders.Strings[i]) > 0 then
1392   - FHTTP.WriteLn(Request.RawHeaders.Strings[i]);
1393   - FHTTP.WriteLn('');
1394   - FHTTP.CloseWriteBuffer;
1395   -end;
1396   -
1397   -procedure TIdHTTPProtocol.RetrieveHeaders;
1398   -var
1399   - S: string;
1400   -begin
1401   - // Set the response headers
1402   - // Clear headers
1403   - // Don't use Capture.
1404   -
1405   - Response.RawHeaders.Clear;
1406   - s := FHTTP.ReadLn;
1407   - try
1408   - while Length(s) > 0 do
1409   - begin
1410   - Response.RawHeaders.Add(S);
1411   - s := FHTTP.ReadLn;
1412   - end;
1413   - except
1414   - on E: EIdConnClosedGracefully do begin
1415   - FHTTP.Disconnect;
1416   - end;
1417   - end;
1418   - Response.ProcessHeaders;
1419   -end;
1420   -
1421   -function TIdHTTPProtocol.ProcessResponse: TIdHTTPWhatsNext;
1422   - procedure RaiseException;
1423   - var
1424   - LRespStream: TStringStream;
1425   - LTempStream: TStream;
1426   - LTemp: Integer;
1427   - begin
1428   - LTemp := FHTTP.ReadTimeout;
1429   - FHTTP.ReadTimeout := 2000; // Lets wait 2 seconds for any kind of content
1430   - LRespStream := TStringStream.Create('');
1431   - LTempStream := Response.ContentStream;
1432   - Response.ContentStream := LRespStream;
1433   - try
1434   - FHTTP.ReadResult(Response);
1435   - raise EIdHTTPProtocolException.CreateError(Response.ResponseCode, FHTTP.ResponseText, LRespStream.DataString);
1436   - finally
1437   - Response.ContentStream := LTempStream;
1438   - LRespStream.Free;
1439   - FHTTP.ReadTimeout := LTemp;
1440   - end;
1441   - end;
1442   -
1443   - procedure ReadContent;
1444   - Var
1445   - LTempResponse: TStringStream;
1446   - LTempStream: TStream;
1447   - begin
1448   - LTempResponse := TStringStream.Create('');
1449   - LTempStream := Response.ContentStream;
1450   - Response.ContentStream := LTempResponse;
1451   - try
1452   - FHTTP.ReadResult(Response);
1453   - finally
1454   - LTempResponse.Free;
1455   - Response.ContentStream := LTempStream;
1456   - end;
1457   - end;
1458   -
1459   -var
1460   - LTemp: Integer;
1461   - LLocation: string;
1462   - LMethod: TIdHTTPMethod;
1463   - LResponseDigit: Integer;
1464   - LNeedAutorization: Boolean;
1465   -begin
1466   - result := wnDontKnow;
1467   - LNeedAutorization := False;
1468   - LResponseDigit := Response.ResponseCode div 100;
1469   - // Handle Redirects
1470   - if ((LResponseDigit = 3) and (Response.ResponseCode <> 304)) or (Length(Response.Location) > 0) then
1471   - begin
1472   - // LLocation := TIdURI.URLDecode(Response.Location);
1473   - LLocation := Response.Location;
1474   -
1475   - if (FHTTP.FHandleRedirects) and (FHTTP.FRedirectCount < FHTTP.FRedirectMax) then
1476   - begin
1477   - LMethod := Request.Method;
1478   - if FHTTP.DoOnRedirect(LLocation, LMethod, FHTTP.FRedirectCount) then
1479   - begin
1480   - result := wnGoToURL;
1481   - Request.URL := LLocation;
1482   - Request.Method := LMethod;
1483   - end
1484   - else
1485   - RaiseException;
1486   - end
1487   - else // Just fire the event
1488   - begin
1489   - LMethod := Request.Method;
1490   - result := wnJustExit;
1491   - if not FHTTP.DoOnRedirect(LLocation, LMethod, FHTTP.FRedirectCount) then // If not Handled
1492   - RaiseException
1493   - else
1494   - Response.Location := LLocation;
1495   - end;
1496   -
1497   - if FHTTP.Connected then
1498   - begin
1499   - // This is a workaround for buggy HTTP 1.1 servers which
1500   - // does not return any body with 302 response code
1501   - LTemp := FHTTP.ReadTimeout;
1502   - FHTTP.ReadTimeout := 4000; // Lets wait 4 seconds for any kind of content
1503   - try
1504   - ReadContent;
1505   - except end;
1506   - FHTTP.ReadTimeout := LTemp;
1507   - end;
1508   - end
1509   - else
1510   - begin
1511   - // GREGOR Workaround
1512   - // if we get an error we disconnect if we use SSLIOHandler
1513   - if Assigned(FHTTP.IOHandler) then
1514   - begin
1515   - Response.KeepAlive := not (FHTTP.Connected and (FHTTP.IOHandler is TIdSSLIOHandlerSocket) and Response.KeepAlive);
1516   - end;
1517   -
1518   - if LResponseDigit <> 2 then
1519   - begin
1520   - result := wnGoToURL;
1521   - case Response.ResponseCode of
1522   - 401:
1523   - begin // HTTP Server authorization requered
1524   - if (FHTTP.FAuthRetries >= FHTTP.AuthRetries) or not FHTTP.DoOnAuthorization(Request, Response) then
1525   - begin
1526   - if Assigned(Request.Authentication) then
1527   - Request.Authentication.Reset;
1528   - RaiseException;
1529   - end else begin
1530   - if hoInProcessAuth in FHTTP.HTTPOptions then
1531   - LNeedAutorization := True;
1532   - end;
1533   - end;
1534   - 407:
1535   - begin // Proxy Server authorization requered
1536   - if (FHTTP.FAuthProxyRetries >= FHTTP.AuthRetries) or not FHTTP.DoOnProxyAuthorization(Request, Response) then
1537   - begin
1538   - if Assigned(FHTTP.ProxyParams.Authentication) then
1539   - FHTTP.ProxyParams.Authentication.Reset;
1540   - RaiseException;
1541   - end else begin
1542   - if hoInProcessAuth in FHTTP.HTTPOptions then
1543   - LNeedAutorization := True;
1544   - end;
1545   - end;
1546   - else begin
1547   - RaiseException;
1548   - end;
1549   - end;
1550   - end;
1551   -
1552   - if FHTTP.Connected then begin
1553   - if LNeedAutorization then begin
1554   - // Read the content of Error message in temporary stream
1555   - LTemp := FHTTP.ReadTimeout;
1556   - FHTTP.ReadTimeout := 4000; // Lets wait 4 seconds for any kind of content
1557   - try
1558   - ReadContent;
1559   - except end;
1560   - FHTTP.ReadTimeout := LTemp;
1561   - result := wnAuthRequest
1562   - end
1563   - else if (Response.ResponseCode <> 204) then
1564   - begin
1565   - FHTTP.ReadResult(Response);
1566   - result := wnJustExit;
1567   - end
1568   - else
1569   - result := wnJustExit;
1570   - end;
1571   - end;
1572   -end;
1573   -
1574   -end.
1575   -
chkcacic/LibXmlParser.pas
View file @eda4e86
... ... @@ -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.
chkcacic/cacic_logo.png
View file @eda4e86

4.14 KB
chkcacic/chkcacic.cfg
View file @eda4e86
... ... @@ -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
chkcacic/chkcacic.dof
View file @eda4e86
... ... @@ -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
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=12
119   -Debug=0
120   -PreRelease=0
121   -Special=0
122   -Private=0
123   -DLL=0
124   -Locale=2070
125   -CodePage=1252
126   -[Version Info Keys]
127   -CompanyName=Dataprev - Emp. de TI da Prev.Social - URES
128   -FileDescription=Módulo Verificador/Instalador dos Agentes Principais para o Sistema CACIC
129   -FileVersion=2.5.0.12
130   -InternalName=
131   -LegalCopyright=
132   -LegalTrademarks=
133   -OriginalFilename=
134   -ProductName=ChkCACIC
135   -ProductVersion=2.6
136   -Comments=Baseado na licença GPL (General Public License)
chkcacic/chkcacic.dpr
View file @eda4e86
... ... @@ -1,44 +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   -program chkcacic;
18   -uses
19   - Forms, windows,
20   - main in 'main.pas',
21   - FormConfig in 'FormConfig.pas' {Configs},
22   - CACIC_Library in '..\CACIC_Library.pas';
23   -
24   -{$R *.res}
25   -
26   -const
27   - CACIC_APP_NAME = 'chkcacic';
28   -
29   -var
30   - oCacic : TCACIC;
31   -
32   -begin
33   - oCacic := TCACIC.Create();
34   -
35   - if( not oCacic.isAppRunning( CACIC_APP_NAME ) )
36   - then begin
37   - Application.Initialize;
38   - Application.CreateForm(TForm1, Form1);
39   - Application.Run;
40   - end;
41   -
42   - oCacic.Free();
43   -
44   -end.
chkcacic/chkcacic.ico
View file @eda4e86
No preview for this file type
chkcacic/chkcacic.res
View file @eda4e86
No preview for this file type
chkcacic/chkcacic_icon.ico
View file @eda4e86
No preview for this file type
chkcacic/chkcacic_icon.ico.svg
View file @eda4e86
... ... @@ -1,53 +0,0 @@
1   -<?xml version="1.0" encoding="UTF-8" standalone="no"?>
2   -<!-- Created with Inkscape (http://www.inkscape.org/) -->
3   -<svg
4   - xmlns:dc="http://purl.org/dc/elements/1.1/"
5   - xmlns:cc="http://web.resource.org/cc/"
6   - xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
7   - xmlns:svg="http://www.w3.org/2000/svg"
8   - xmlns="http://www.w3.org/2000/svg"
9   - xmlns:xlink="http://www.w3.org/1999/xlink"
10   - xmlns:sodipodi="http://inkscape.sourceforge.net/DTD/sodipodi-0.dtd"
11   - xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape"
12   - id="svg2"
13   - sodipodi:version="0.32"
14   - inkscape:version="0.43"
15   - width="210mm"
16   - height="297mm"
17   - sodipodi:docbase="W:\chkcacic"
18   - sodipodi:docname="chkcacic_icon.ico.svg">
19   - <metadata
20   - id="metadata7">
21   - <rdf:RDF>
22   - <cc:Work
23   - rdf:about="">
24   - <dc:format>image/svg+xml</dc:format>
25   - <dc:type
26   - rdf:resource="http://purl.org/dc/dcmitype/StillImage" />
27   - </cc:Work>
28   - </rdf:RDF>
29   - </metadata>
30   - <defs
31   - id="defs5" />
32   - <sodipodi:namedview
33   - inkscape:window-height="540"
34   - inkscape:window-width="789"
35   - inkscape:pageshadow="2"
36   - inkscape:pageopacity="0.0"
37   - borderopacity="1.0"
38   - bordercolor="#666666"
39   - pagecolor="#ffffff"
40   - id="base"
41   - inkscape:zoom="0.35444071"
42   - inkscape:cx="372.04724"
43   - inkscape:cy="526.18109"
44   - inkscape:window-x="3"
45   - inkscape:window-y="26"
46   - inkscape:current-layer="svg2" />
47   - <image
48   - xlink:href="cacic_logo.GIF.gif"
49   - sodipodi:absref="W:\chkcacic\cacic_logo.GIF.gif"
50   - width="50"
51   - height="50"
52   - id="image9" />
53   -</svg>
chkcacic/main.ddp
View file @eda4e86
No preview for this file type
chkcacic/main.dfm
View file @eda4e86
... ... @@ -1,29 +0,0 @@
1   -object Form1: TForm1
2   - Left = 453
3   - Top = 340
4   - Width = 123
5   - Height = 157
6   - Caption = 'chkcacic'
7   - Color = clBtnFace
8   - Font.Charset = DEFAULT_CHARSET
9   - Font.Color = clWindowText
10   - Font.Height = -11
11   - Font.Name = 'MS Sans Serif'
12   - Font.Style = []
13   - OldCreateOrder = False
14   - OnCreate = FormCreate
15   - PixelsPerInch = 96
16   - TextHeight = 13
17   - object PJVersionInfo1: TPJVersionInfo
18   - end
19   - object IdFTP1: TIdFTP
20   - MaxLineAction = maException
21   - ReadTimeout = 0
22   - ProxySettings.ProxyType = fpcmNone
23   - ProxySettings.Port = 0
24   - Left = 32
25   - end
26   - object FS: TNTFileSecurity
27   - Left = 64
28   - end
29   -end
chkcacic/main.iip
View file @eda4e86
... ... @@ -1,7 +0,0 @@
1   -[Main]
2   -OutputDir=E:\Arquivos de programas\RemObjects Software\Pascal Script for Delphi\Bin\Import\
3   -SingleUnit=1
4   -UseUnitAtDT=0
5   -FilePrefix=uPSImport
6   -[Files]
7   -File0=K:\chkcacic\main.pas
chkcacic/main.pas
View file @eda4e86
... ... @@ -1,1873 +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   -ChkCacic.exe : Verificador/Instalador dos agentes principais Cacic2.exe, Ger_Cols.exe e SrCacicSrv.exe
19   -======================================================================================================
20   -
21   -v 2.2.0.38
22   -+ Acrescentado a obtenção de versão interna do S.O.
23   -+ Acrescentado a inserção dos agentes principais nas exceções do FireWall interno do MS-Windows VISTA...
24   -.
25   -Diversas rebuilds...
26   -.
27   -v 2.2.0.17
28   -+ Acrescentado o tratamento da passagem de opções em linha de comando
29   - * chkcacic /serv=<ip_server> /dir=<local_path>c:\%windir%\cacic
30   - Exemplo de uso: chkcacic /serv=UXbra001 /dir=Cacic
31   -
32   -v 2.2.0.16
33   -* Corrigido o fechamento do arquivo de configurações de ChkSis
34   -
35   -v 2.2.0.15
36   -* Substituída a mensagem "File System diferente de "NTFS" por 'File System: "<NomeFileSystem>" - Ok!'
37   -
38   -v 2.2.0.14
39   -+ Críticas/mensagens:
40   - "ATENÇÃO! Não foi possível estabelecer comunicação com o módulo Gerente WEB em <servidor>." e
41   - "ATENÇÃO: Não foi possível efetuar FTP para <agente>. Verifique o Servidor de Updates."
42   -+ Opção checkbox "Exibe informações sobre o processo de instalação" ao formulário de configuração;
43   -+ Botão "Sair" ao formulário de configuração;
44   -+ Execução automática do Agente Principal ao fim da instalação quando a unidade origem do ChkCacic não
45   - for mapeamento de rede ou unidade inválida.
46   -
47   -- Retirados os campos "Frase para Sucesso na Instalação" e "Frase para Insucesso na Instalação"
48   - do formulário de configuração, passando essas frases a serem fixas na aplicação.
49   -- Retirada a opção radiobutton "Remove Versão Anterior?";
50   -
51   -=====================================================================================================
52   -*)
53   -
54   -
55   -unit main;
56   -
57   -interface
58   -
59   -uses
60   - Windows,
61   - strUtils,
62   - SysUtils,
63   - Classes,
64   - Forms,
65   - Registry,
66   - Inifiles,
67   - idFTPCommon,
68   - XML,
69   - LibXmlParser,
70   - idHTTP,
71   - PJVersionInfo,
72   - Controls,
73   - StdCtrls,
74   - IdBaseComponent,
75   - IdComponent,
76   - IdTCPConnection,
77   - IdTCPClient,
78   - variants,
79   - NTFileSecurity,
80   - IdFTP,
81   - Tlhelp32,
82   - ExtCtrls,
83   - Dialogs,
84   - CACIC_Library,
85   - WinSvc;
86   -
87   -var
88   - v_ip_serv_cacic,
89   - v_te_instala_frase_sucesso,
90   - v_te_instala_frase_insucesso,
91   - v_te_instala_informacoes_extras,
92   - v_exibe_informacoes,
93   - v_versao_local,
94   - v_versao_remota,
95   - v_strCipherClosed,
96   - v_strCipherOpened,
97   - v_versao_REM,
98   - v_versao_LOC,
99   - v_retorno : String;
100   -
101   -var
102   - v_Debugs : boolean;
103   -
104   -var
105   - v_tstrCipherOpened : TStrings;
106   -
107   -var
108   - g_oCacic: TCACIC; /// Biblioteca CACIC_Library
109   -
110   -Procedure chkcacic;
111   -procedure ComunicaInsucesso(strIndicador : String); //2.2.0.32
112   -Procedure CriaFormConfigura;
113   -Procedure DelValorReg(Chave: String);
114   -Procedure GravaConfiguracoes;
115   -procedure GravaIni(strFullPath : STring);
116   -procedure KillProcess(hWindowHandle: HWND); // 2.2.0.15
117   -procedure LogDebug(p_msg:string);
118   -procedure LogDiario(strMsg : String);
119   -procedure Matar(v_dir,v_files: string); // 2.2.0.16
120   -Procedure MostraFormConfigura;
121   -
122   -Function ChecaVersoesAgentes(p_strNomeAgente : String) : integer; // 2.2.0.16
123   -Function FindWindowByTitle(WindowTitle: string): Hwnd;
124   -Function FTP(p_Host : String; p_Port : String; p_Username : String; p_Password : String; p_PathServer : String; p_File : String; p_Dest : String) : Boolean;
125   -function GetFolderDate(Folder: string): TDateTime;
126   -function GetNetworkUserName : String; // 2.2.0.32
127   -Function GetRootKey(strRootKey: String): HKEY;
128   -Function GetValorChaveRegEdit(Chave: String): Variant;
129   -Function GetValorChaveRegIni(p_Secao, p_Chave, p_File : String): String;
130   -Function GetVersionInfo(p_File: string):string;
131   -Function KillTask(ExeFileName: string): Integer;
132   -Function ListFileDir(Path: string):string;
133   -function Posso_Rodar_CACIC : boolean;
134   -Function SetValorChaveRegEdit(Chave: String; Dado: Variant): Variant;
135   -Function SetValorChaveRegIni(p_Secao, p_Chave, p_Valor, p_File : String): String;
136   -Function RemoveCaracteresEspeciais(Texto : String) : String;
137   -Function VerFmt(const MS, LS: DWORD): string;
138   -function ServiceStart(sService : string ) : boolean;
139   -function ServiceRunning(sMachine, sService: PChar): Boolean;
140   -function ServiceStopped(sMachine, sService: PChar): Boolean;
141   -
142   -type
143   - TForm1 = class(TForm)
144   - PJVersionInfo1: TPJVersionInfo;
145   - IdFTP1: TIdFTP;
146   - FS: TNTFileSecurity;
147   - procedure FormCreate(Sender: TObject);
148   - procedure FS_SetSecurity(p_Target : String);
149   - end;
150   -
151   -var
152   - Form1: TForm1;
153   - ENDERECO_SERV_CACIC : string;
154   -implementation
155   -
156   -uses FormConfig;
157   -
158   -{$R *.dfm}
159   -
160   -function ServiceGetStatus(sMachine, sService: PChar): DWORD;
161   - {******************************************}
162   - {*** Parameters: ***}
163   - {*** sService: specifies the name of the service to open
164   - {*** sMachine: specifies the name of the target computer
165   - {*** ***}
166   - {*** Return Values: ***}
167   - {*** -1 = Error opening service ***}
168   - {*** 1 = SERVICE_STOPPED ***}
169   - {*** 2 = SERVICE_START_PENDING ***}
170   - {*** 3 = SERVICE_STOP_PENDING ***}
171   - {*** 4 = SERVICE_RUNNING ***}
172   - {*** 5 = SERVICE_CONTINUE_PENDING ***}
173   - {*** 6 = SERVICE_PAUSE_PENDING ***}
174   - {*** 7 = SERVICE_PAUSED ***}
175   - {******************************************}
176   -var
177   - SCManHandle, SvcHandle: SC_Handle;
178   - SS: TServiceStatus;
179   - dwStat: DWORD;
180   -begin
181   - dwStat := 0;
182   - // Open service manager handle.
183   - LogDEBUG('Executando OpenSCManager.SC_MANAGER_CONNECT');
184   - SCManHandle := OpenSCManager(sMachine, nil, SC_MANAGER_CONNECT);
185   - if (SCManHandle > 0) then
186   - begin
187   - LogDEBUG('Executando OpenService.SERVICE_QUERY_STATUS');
188   - SvcHandle := OpenService(SCManHandle, sService, SERVICE_QUERY_STATUS);
189   - // if Service installed
190   - if (SvcHandle > 0) then
191   - begin
192   - LogDEBUG('O serviço "'+ sService +'" já está instalado.');
193   - // SS structure holds the service status (TServiceStatus);
194   - if (QueryServiceStatus(SvcHandle, SS)) then
195   - dwStat := ss.dwCurrentState;
196   - CloseServiceHandle(SvcHandle);
197   - end;
198   - CloseServiceHandle(SCManHandle);
199   - end;
200   - Result := dwStat;
201   -end;
202   -
203   -// start service
204   -//
205   -// return TRUE if successful
206   -//
207   -// sService
208   -// service name, ie: Alerter
209   -//
210   -function ServiceStart(sService : string ) : boolean;
211   -var schm,
212   - schs : SC_Handle;
213   -
214   - ss : TServiceStatus;
215   - psTemp : PChar;
216   - dwChkP : DWord;
217   -begin
218   - ss.dwCurrentState := 0;
219   -
220   - logDEBUG('Executando Service Start');
221   -
222   - // connect to the service control manager
223   - schm := OpenSCManager(Nil,Nil,SC_MANAGER_CONNECT);
224   -
225   - // if successful...
226   - if(schm > 0)then
227   - begin
228   - // open a handle to the specified service
229   - schs := OpenService(schm,PChar(sService),SERVICE_START or SERVICE_QUERY_STATUS);
230   -
231   - // if successful...
232   - if(schs > 0)then
233   - begin
234   - logDEBUG('Open Service OK');
235   - psTemp := Nil;
236   - if(StartService(schs,0,psTemp)) then
237   - begin
238   - logDEBUG('Entrando em Start Service');
239   - // check status
240   - if(QueryServiceStatus(schs,ss))then
241   - begin
242   - while(SERVICE_RUNNING <> ss.dwCurrentState)do
243   - begin
244   - // dwCheckPoint contains a value that the service increments periodically
245   - // to report its progress during a lengthy operation.
246   - dwChkP := ss.dwCheckPoint;
247   -
248   - // wait a bit before checking status again
249   - // dwWaitHint is the estimated amount of time the calling program should wait before calling
250   - // QueryServiceStatus() again idle events should be handled here...
251   -
252   - Sleep(ss.dwWaitHint);
253   -
254   - if(not QueryServiceStatus(schs,ss))then
255   - begin
256   - break;
257   - end;
258   -
259   - if(ss.dwCheckPoint < dwChkP)then
260   - begin
261   - // QueryServiceStatus didn't increment dwCheckPoint as it should have.
262   - // avoid an infinite loop by breaking
263   - break;
264   - end;
265   - end;
266   - end
267   - else
268   - logDEBUG('Oops! Problema com StartService!');
269   - end;
270   -
271   - // close service handle
272   - CloseServiceHandle(schs);
273   - end;
274   -
275   - // close service control manager handle
276   - CloseServiceHandle(schm);
277   - end
278   - else
279   - Configs.Memo_te_instala_informacoes_extras.Lines.Add('Oops! Problema com o Service Control Manager!');
280   - // return TRUE if the service status is running
281   - Result := SERVICE_RUNNING = ss.dwCurrentState;
282   -end;
283   -
284   -function GetNetworkUserName : String;
285   - // Gets the name of the user currently logged into the network on
286   - // the local PC
287   -var
288   - temp: PChar;
289   - Ptr: DWord;
290   -const
291   - buff = 255;
292   -begin
293   - ptr := buff;
294   - temp := StrAlloc(buff);
295   - GetUserName(temp, ptr);
296   - Result := string(temp);
297   - StrDispose(temp);
298   -end;
299   -
300   -procedure ComunicaInsucesso(strIndicador : String);
301   -var IdHTTP2: TIdHTTP;
302   - Request_Config : TStringList;
303   - Response_Config : TStringStream;
304   -begin
305   -
306   - // Envio notificação de insucesso para o Módulo Gerente Centralizado
307   - Request_Config := TStringList.Create;
308   - Request_Config.Values['cs_indicador'] := strIndicador;
309   - Request_Config.Values['id_usuario'] := GetNetworkUserName();
310   - Request_Config.Values['te_so'] := g_oCacic.getWindowsStrId();
311   - Response_Config := TStringStream.Create('');
312   - Try
313   - Try
314   - IdHTTP2 := TIdHTTP.Create(nil);
315   - IdHTTP2.Post('http://' + v_ip_serv_cacic + '/cacic2/ws/instalacacic.php', Request_Config, Response_Config);
316   - IdHTTP2.Free;
317   - Request_Config.Free;
318   - Response_Config.Free;
319   - Except
320   - End;
321   - finally
322   - Begin
323   - IdHTTP2.Free;
324   - Request_Config.Free;
325   - Response_Config.Free;
326   - End;
327   - End;
328   -end;
329   -
330   -procedure LogDiario(strMsg : String);
331   -var
332   - HistoricoLog : TextFile;
333   -begin
334   - try
335   - FileSetAttr (g_oCacic.getHomeDrive + 'chkcacic.log',0); // Retira os atributos do arquivo para evitar o erro FILE ACCESS DENIED em máquinas 2000
336   - AssignFile(HistoricoLog,g_oCacic.getHomeDrive + 'chkcacic.log'); {Associa o arquivo a uma variável do tipo TextFile}
337   -
338   - {$IOChecks off}
339   - Reset(HistoricoLog); {Abre o arquivo texto}
340   - {$IOChecks on}
341   -
342   - if (IOResult <> 0) then // Arquivo não existe, será recriado.
343   - begin
344   - Rewrite (HistoricoLog);
345   - Append(HistoricoLog);
346   - Writeln(HistoricoLog,FormatDateTime('dd/mm hh:nn:ss : ', Now) + '======================> Iniciando o Log <=======================');
347   - end;
348   - Append(HistoricoLog);
349   - Writeln(HistoricoLog,FormatDateTime('dd/mm hh:nn:ss : ', Now)+ '[Instalador] '+strMsg); {Grava a string Texto no arquivo texto}
350   - CloseFile(HistoricoLog); {Fecha o arquivo texto}
351   - except
352   - //Erro na gravação do log!
353   - end;
354   - try
355   - Configs.Memo_te_instala_informacoes_extras.Lines.Add(strMsg);
356   - except
357   - end;
358   -end;
359   -
360   -procedure LogDebug(p_msg:string);
361   -Begin
362   - if v_Debugs then
363   - Begin
364   - LogDiario('(v.'+getVersionInfo(ParamStr(0))+') DEBUG - '+p_msg);
365   - End;
366   -End;
367   -
368   -Function CipherClose(p_DatFileName : string) : String;
369   -var v_strCipherOpenImploded : string;
370   - v_DatFile : TextFile;
371   -begin
372   - try
373   - FileSetAttr (p_DatFileName,0); // Retira os atributos do arquivo para evitar o erro FILE ACCESS DENIED em máquinas 2000
374   - AssignFile(v_DatFile,p_DatFileName); {Associa o arquivo a uma variável do tipo TextFile}
375   -
376   - // Recriação do arquivo .DAT
377   - Rewrite (v_DatFile);
378   - Append(v_DatFile);
379   -
380   - v_strCipherOpenImploded := g_oCacic.implode(v_tstrCipherOpened,g_oCacic.getSeparatorKey);
381   - v_strCipherClosed := g_oCacic.enCrypt(v_strCipherOpenImploded);
382   -
383   - Writeln(v_DatFile,v_strCipherClosed); {Grava a string Texto no arquivo texto}
384   -
385   - CloseFile(v_DatFile);
386   - except
387   - end;
388   -end;
389   -
390   -Function CipherOpen(p_DatFileName : string) : TStrings;
391   -var v_DatFile : TextFile;
392   - v_strCipherOpened,
393   - v_strCipherClosed : string;
394   -begin
395   - LogDebug('Tentando acessar configurações em '+g_oCacic.getCacicPath + g_oCacic.getDatFileName);
396   - v_strCipherOpened := '';
397   - if FileExists(p_DatFileName) then
398   - begin
399   - AssignFile(v_DatFile,p_DatFileName);
400   - {$IOChecks off}
401   - Reset(v_DatFile);
402   - {$IOChecks on}
403   - if (IOResult <> 0) then // Arquivo não existe, será recriado.
404   - begin
405   - Rewrite (v_DatFile);
406   - Append(v_DatFile);
407   - end;
408   -
409   - Readln(v_DatFile,v_strCipherClosed);
410   - while not EOF(v_DatFile) do Readln(v_DatFile,v_strCipherClosed);
411   - CloseFile(v_DatFile);
412   - v_strCipherOpened:= g_oCacic.deCrypt(v_strCipherClosed);
413   - end;
414   - if (trim(v_strCipherOpened)<>'') then
415   - Result := g_oCacic.explode(v_strCipherOpened,g_oCacic.getSeparatorKey)
416   - else
417   - 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);
418   -
419   - if Result.Count mod 2 <> 0 then
420   - Result.Add('');
421   -end;
422   -
423   -Procedure SetValorDatMemoria(p_Chave : string; p_Valor : String);
424   -begin
425   - LogDebug('Setando Chave "'+p_Chave+'" com "'+p_Valor+'"');
426   - // Exemplo: p_Chave => Configs.nu_ip_servidor : p_Valor => 10.71.0.120
427   - if (v_tstrCipherOpened.IndexOf(p_Chave)<>-1) then
428   - v_tstrCipherOpened[v_tstrCipherOpened.IndexOf(p_Chave)+1] := p_Valor
429   - else
430   - Begin
431   - v_tstrCipherOpened.Add(p_Chave);
432   - v_tstrCipherOpened.Add(p_Valor);
433   - End;
434   -end;
435   -
436   -Function GetValorDatMemoria(p_Chave : String) : String;
437   -begin
438   - if (v_tstrCipherOpened.IndexOf(p_Chave)<>-1) then
439   - Result := v_tstrCipherOpened[v_tstrCipherOpened.IndexOf(p_Chave)+1]
440   - else
441   - Result := '';
442   -end;
443   -
444   -
445   -function VerFmt(const MS, LS: DWORD): string;
446   - // Format the version number from the given DWORDs containing the info
447   -begin
448   - Result := Format('%d.%d.%d.%d',
449   - [HiWord(MS), LoWord(MS), HiWord(LS), LoWord(LS)])
450   -end;
451   -
452   -
453   -
454   -function GetVersionInfo(p_File: string):string;
455   -begin
456   - Form1.PJVersionInfo1.FileName := PChar(p_File);
457   - Result := VerFmt(Form1.PJVersionInfo1.FixedFileInfo.dwFileVersionMS, Form1.PJVersionInfo1.FixedFileInfo.dwFileVersionLS);
458   -end;
459   -
460   -function GetRootKey(strRootKey: String): HKEY;
461   -begin
462   - /// Encontrar uma maneira mais elegante de fazer esses testes.
463   - if Trim(strRootKey) = 'HKEY_LOCAL_MACHINE' Then Result := HKEY_LOCAL_MACHINE
464   - else if Trim(strRootKey) = 'HKEY_CLASSES_ROOT' Then Result := HKEY_CLASSES_ROOT
465   - else if Trim(strRootKey) = 'HKEY_CURRENT_USER' Then Result := HKEY_CURRENT_USER
466   - else if Trim(strRootKey) = 'HKEY_USERS' Then Result := HKEY_USERS
467   - else if Trim(strRootKey) = 'HKEY_CURRENT_CONFIG' Then Result := HKEY_CURRENT_CONFIG
468   - else if Trim(strRootKey) = 'HKEY_DYN_DATA' Then Result := HKEY_DYN_DATA;
469   -end;
470   -
471   -function SetValorChaveRegEdit(Chave: String; Dado: Variant): Variant;
472   -var RegEditSet: TRegistry;
473   - RegDataType: TRegDataType;
474   - strRootKey, strKey, strValue : String;
475   - ListaAuxSet : TStrings;
476   - I : Integer;
477   -begin
478   - ListaAuxSet := g_oCacic.explode(Chave, '\');
479   - strRootKey := ListaAuxSet[0];
480   - For I := 1 To ListaAuxSet.Count - 2 do
481   - strKey := strKey + ListaAuxSet[I] + '\';
482   - strValue := ListaAuxSet[ListaAuxSet.Count - 1];
483   -
484   - RegEditSet := TRegistry.Create;
485   - try
486   - RegEditSet.Access := KEY_WRITE;
487   - RegEditSet.Rootkey := GetRootKey(strRootKey);
488   -
489   - if RegEditSet.OpenKey(strKey, True) then
490   - Begin
491   - RegDataType := RegEditSet.GetDataType(strValue);
492   - if RegDataType = rdString then
493   - begin
494   - RegEditSet.WriteString(strValue, Dado);
495   - end
496   - else if RegDataType = rdExpandString then
497   - begin
498   - RegEditSet.WriteExpandString(strValue, Dado);
499   - end
500   - else if RegDataType = rdInteger then
501   - begin
502   - RegEditSet.WriteInteger(strValue, Dado);
503   - end
504   - else
505   - begin
506   - RegEditSet.WriteString(strValue, Dado);
507   - end;
508   -
509   - end;
510   - finally
511   - RegEditSet.CloseKey;
512   - end;
513   - ListaAuxSet.Free;
514   - RegEditSet.Free;
515   - LogDebug('Setando valor "'+Dado+'" para chave "'+Chave+'"');
516   -end;
517   -
518   -Function RemoveCaracteresEspeciais(Texto : String) : String;
519   -var I : Integer;
520   - strAux : String;
521   -Begin
522   - For I := 0 To Length(Texto) Do
523   - if ord(Texto[I]) in [32..126] Then
524   - strAux := strAux + Texto[I]
525   - else strAux := strAux + ' '; // Coloca um espaço onde houver caracteres especiais
526   - Result := strAux;
527   -end;
528   -
529   -//Para buscar do RegEdit...
530   -function GetValorChaveRegEdit(Chave: String): Variant;
531   -var RegEditGet: TRegistry;
532   - RegDataType: TRegDataType;
533   - strRootKey, strKey, strValue, s: String;
534   - ListaAuxGet : TStrings;
535   - DataSize, Len, I : Integer;
536   -begin
537   - try
538   - ListaAuxGet := g_oCacic.Explode(Chave, '\');
539   -
540   - strRootKey := ListaAuxGet[0];
541   - For I := 1 To ListaAuxGet.Count - 2 Do strKey := strKey + ListaAuxGet[I] + '\';
542   - strValue := ListaAuxGet[ListaAuxGet.Count - 1];
543   - RegEditGet := TRegistry.Create;
544   -
545   - RegEditGet.Access := KEY_READ;
546   - RegEditGet.Rootkey := GetRootKey(strRootKey);
547   - if RegEditGet.OpenKeyReadOnly(strKey) then //teste
548   - Begin
549   - RegDataType := RegEditGet.GetDataType(strValue);
550   - if (RegDataType = rdString) or (RegDataType = rdExpandString) then Result := RegEditGet.ReadString(strValue)
551   - else if RegDataType = rdInteger then Result := RegEditGet.ReadInteger(strValue)
552   - else if (RegDataType = rdBinary) or (RegDataType = rdUnknown)
553   - then
554   - begin
555   - DataSize := RegEditGet.GetDataSize(strValue);
556   - if DataSize = -1 then exit;
557   - SetLength(s, DataSize);
558   - Len := RegEditGet.ReadBinaryData(strValue, PChar(s)^, DataSize);
559   - if Len <> DataSize then exit;
560   - Result := RemoveCaracteresEspeciais(s);
561   - end
562   - end;
563   - finally
564   - RegEditGet.CloseKey;
565   - RegEditGet.Free;
566   - ListaAuxGet.Free;
567   -
568   - end;
569   -end;
570   -
571   -//Para gravar no Arquivo INI...
572   -function SetValorChaveRegIni(p_Secao, p_Chave, p_Valor, p_File : String): String;
573   -var Reg_Ini : TIniFile;
574   -begin
575   - if (FileGetAttr(p_File) and faReadOnly) > 0 then
576   - FileSetAttr(p_File, FileGetAttr(p_File) xor faReadOnly);
577   -
578   - Reg_Ini := TIniFile.Create(p_File);
579   - Reg_Ini.WriteString(p_Secao, p_Chave, p_Valor);
580   - Reg_Ini.Free;
581   -end;
582   -
583   -function GetValorChaveRegIni(p_Secao, p_Chave, p_File : String): String;
584   -//Para buscar do Arquivo INI...
585   -// Marreta devido a limitações do KERNEL w9x no tratamento de arquivos texto e suas seções
586   -//function GetValorChaveRegIni(p_SectionName, p_KeyName, p_IniFileName : String) : String;
587   -var
588   - FileText : TStringList;
589   - i, j, v_Size_Section, v_Size_Key : integer;
590   - v_SectionName, v_KeyName : string;
591   - begin
592   - Result := '';
593   - v_SectionName := '[' + p_Secao + ']';
594   - v_Size_Section := strLen(PChar(v_SectionName));
595   - v_KeyName := p_Chave + '=';
596   - v_Size_Key := strLen(PChar(v_KeyName));
597   - FileText := TStringList.Create;
598   - try
599   - FileText.LoadFromFile(p_File);
600   - For i := 0 To FileText.Count - 1 Do
601   - Begin
602   - if (LowerCase(Trim(PChar(Copy(FileText[i],1,v_Size_Section)))) = LowerCase(Trim(PChar(v_SectionName)))) then
603   - Begin
604   - For j := i to FileText.Count - 1 Do
605   - Begin
606   - if (LowerCase(Trim(PChar(Copy(FileText[j],1,v_Size_Key)))) = LowerCase(Trim(PChar(v_KeyName)))) then
607   - Begin
608   - Result := PChar(Copy(FileText[j],v_Size_Key + 1,strLen(PChar(FileText[j]))-v_Size_Key));
609   - Break;
610   - End;
611   - End;
612   - End;
613   - if (Result <> '') then break;
614   - End;
615   - finally
616   - FileText.Free;
617   - end;
618   - end;
619   -
620   -Procedure DelValorReg(Chave: String);
621   -var RegDelValorReg: TRegistry;
622   - strRootKey, strKey, strValue : String;
623   - ListaAuxDel : TStrings;
624   - I : Integer;
625   -begin
626   - ListaAuxDel := g_oCacic.explode(Chave, '\');
627   - strRootKey := ListaAuxDel[0];
628   - For I := 1 To ListaAuxDel.Count - 2 Do strKey := strKey + ListaAuxDel[I] + '\';
629   - strValue := ListaAuxDel[ListaAuxDel.Count - 1];
630   - RegDelValorReg := TRegistry.Create;
631   -
632   - try
633   - RegDelValorReg.Access := KEY_WRITE;
634   - RegDelValorReg.Rootkey := GetRootKey(strRootKey);
635   -
636   - if RegDelValorReg.OpenKey(strKey, True) then
637   - RegDelValorReg.DeleteValue(strValue);
638   - finally
639   - RegDelValorReg.CloseKey;
640   - end;
641   - RegDelValorReg.Free;
642   - ListaAuxDel.Free;
643   -end;
644   -
645   -Procedure CriaFormConfigura;
646   -begin
647   - LogDebug('Chamando Criação do Formulário de Configurações - 1');
648   - Application.CreateForm(TConfigs, FormConfig.Configs);
649   - FormConfig.Configs.lbVersao.Caption := 'v: ' + getVersionInfo(ParamStr(0));
650   -end;
651   -
652   -Procedure MostraFormConfigura;
653   -begin
654   - LogDebug('Exibindo formulário de configurações');
655   - FormConfig.Configs.ShowModal;
656   -end;
657   -
658   -Function FTP(p_Host : String; p_Port : String; p_Username : String; p_Password : String; p_PathServer : String; p_File : String; p_Dest : String) : Boolean;
659   -var IdFTP : TIdFTP;
660   -begin
661   - Try
662   - LogDebug('FTP: Criando instance');
663   -
664   - IdFTP := TIdFTP.Create(nil);
665   -
666   - LogDebug('FTP: Host => "'+p_Host+'"');
667   - IdFTP.Host := p_Host;
668   -
669   - LogDebug('FTP: UserName => "'+p_Username+'"');
670   - IdFTP.Username := p_Username;
671   -
672   - LogDebug('FTP: PassWord => "**********"');
673   - IdFTP.Password := p_Password;
674   -
675   - LogDebug('FTP: PathServer => "'+p_PathServer+'"');
676   - IdFTP.Port := strtoint(p_Port);
677   -
678   - LogDebug('FTP: Setando TransferType para "ftBinary"');
679   - IdFTP.TransferType := ftBinary;
680   -
681   - LogDebug('FTP: Setando Passive para "true"');
682   - IdFTP.Passive := true;
683   -
684   - LogDebug('FTP: Change to "'+p_PathServer+'"');
685   - Try
686   - if IdFTP.Connected = true then
687   - begin
688   - LogDebug('FTP: Connected => Desconectando...');
689   - IdFTP.Disconnect;
690   - end;
691   - LogDebug('FTP: Efetuando Conexão...');
692   - IdFTP.Connect(true);
693   - LogDebug('FTP: Change to "'+p_PathServer+'"');
694   - IdFTP.ChangeDir(p_PathServer);
695   - Try
696   - LogDebug('Iniciando FTP de "'+p_Dest + p_File+'"');
697   - LogDebug('HashCode de "'+p_File+'" Antes do FTP => '+g_oCacic.GetFileHash(p_Dest + p_File));
698   - IdFTP.Get(p_File, p_Dest + p_File, True, True);
699   - LogDebug('HashCode de "'+p_Dest + p_File +'" Após o FTP => '+g_oCacic.GetFileHash(p_Dest + p_File));
700   - Finally
701   - LogDebug('HashCode de "'+p_Dest + p_File +'" Após o FTP em Finally => '+g_oCacic.GetFileHash(p_Dest + p_File));
702   - IdFTP.Disconnect;
703   - IdFTP.Free;
704   - result := true;
705   - End;
706   - Except
707   - Begin
708   - LogDebug('Oops! Problemas Sem Início de FTP...');
709   - result := false;
710   - End;
711   - end;
712   - Except
713   - result := false;
714   - End;
715   -end;
716   -
717   -// Função para fixar o HomeDrive como letra para a pasta do CACIC
718   -function TrataCacicDir(strCacicDir : String) : String;
719   -var tstrCacicDir1,
720   - tstrCacicDir2 : TStrings;
721   - intAUX : integer;
722   -Begin
723   - Result := strCacicDir;
724   - // Crio um array separado por ":" (Para o caso de ter sido informada a letra da unidade)
725   - tstrCacicDir1 := TStrings.Create;
726   - tstrCacicDir1 := g_oCacic.explode(strCacicDir,':');
727   -
728   - if (tstrCacicDir1.Count > 1) then
729   - Begin
730   - tstrCacicDir2 := TStrings.Create;
731   - // Ignoro a letra informada...
732   - // Certifico-me de que as barras são invertidas... (erros acontecem)
733   - // Crio um array quebrado por "\"
734   - Result := StringReplace(tstrCacicDir1[1],'/','\',[rfReplaceAll]);
735   - tstrCacicDir2 := g_oCacic.explode(Result,'\');
736   -
737   - // Inicializo retorno com a unidade raiz do Sistema Operacional
738   - // Concateno ao retorno as partes que formarão o caminho completo do CACIC
739   - Result := g_oCacic.getHomeDrive;
740   - for intAux := 0 to (tstrCacicDir2.Count-1) do
741   - if (tstrCacicDir2[intAux] <> '') then
742   - Result := Result + tstrCacicDir2[intAux] + '\';
743   - tstrCacicDir2.Free;
744   - End
745   - else
746   - Result := g_oCacic.getHomeDrive + strCacicDir + '\';
747   -
748   - tstrCacicDir1.Free;
749   -
750   - Result := StringReplace(Result,'\\','\',[rfReplaceAll]);
751   -End;
752   -
753   -procedure GravaConfiguracoes;
754   -var chkcacic_ini : TextFile;
755   -begin
756   - try
757   - LogDebug('g_ocacic => setCacicpath => '+Configs.Edit_cacic_dir.text+'\');
758   -
759   - FileSetAttr (ExtractFilePath(Application.Exename) + '\chkcacic.ini',0); // Retira os atributos do arquivo para evitar o erro FILE ACCESS DENIED em máquinas 2000
760   - AssignFile(chkcacic_ini,ExtractFilePath(Application.Exename) + '\chkcacic.ini'); {Associa o arquivo a uma variável do tipo TextFile}
761   - Rewrite (chkcacic_ini); // Recria o arquivo...
762   - Append(chkcacic_ini);
763   - Writeln(chkcacic_ini,'# ===================================================================================');
764   - Writeln(chkcacic_ini,'# A edição deste arquivo também pode ser feita com o comando "chkcacic.exe /config"');
765   - Writeln(chkcacic_ini,'# ===================================================================================');
766   - Writeln(chkcacic_ini,'');
767   - Writeln(chkcacic_ini,'');
768   - Writeln(chkcacic_ini,'# CHAVES E VALORES OBRIGATÓRIOS PARA USO DO CHKCACIC.EXE');
769   - Writeln(chkcacic_ini,'# ===================================================================================');
770   - Writeln(chkcacic_ini,'# ip_serv_cacic');
771   - Writeln(chkcacic_ini,'# Endereço IP ou Nome(DNS) do servidor onde o Módulo Gerente do CACIC foi instalado');
772   - Writeln(chkcacic_ini,'# Ex1.: ip_serv_cacic=10.xxx.yyy.zzz');
773   - Writeln(chkcacic_ini,'# Ex2.: ip_serv_cacic=uxesa001');
774   - Writeln(chkcacic_ini,'# cacic_dir');
775   - Writeln(chkcacic_ini,'# Pasta a ser criada na estação para instalação do CACIC agente');
776   - Writeln(chkcacic_ini,'# Ex.: cacic_dir=Cacic');
777   - Writeln(chkcacic_ini,'# exibe_informacoes');
778   - Writeln(chkcacic_ini,'# Indicador de exibicao de informações sobre o processo de instalação');
779   - Writeln(chkcacic_ini,'# Ex.: exibe_informacoes=N');
780   - Writeln(chkcacic_ini,'');
781   - Writeln(chkcacic_ini,'');
782   - Writeln(chkcacic_ini,'# CHAVES E VALORES OPCIONAIS PARA USO DO CHKCACIC.EXE');
783   - Writeln(chkcacic_ini,'# (ATENÇÃO: NÃO PREENCHER EM CASO DE CHKCACIC.INI PARA O NETLOGON!)');
784   - Writeln(chkcacic_ini,'# ===================================================================================');
785   - Writeln(chkcacic_ini,'# te_instala_informacoes_extras');
786   - Writeln(chkcacic_ini,'# Informações a serem mostradas na janela de Instalação/Recuperação');
787   - Writeln(chkcacic_ini,'# Ex.: Empresa-UF / Suporte Técnico');
788   - Writeln(chkcacic_ini,'# Emails: email_do_suporte@xxxxxx.yyy.zz, outro_email@outro_dominio.xxx.yy');
789   - Writeln(chkcacic_ini,'# Telefones: (xx) yyyy-zzzz / (xx) yyyy-zzzz');
790   - Writeln(chkcacic_ini,'# Endereço: Rua Nome_da_Rua, Nº 99999');
791   - Writeln(chkcacic_ini,'# Cidade/UF');
792   - Writeln(chkcacic_ini,'');
793   - Writeln(chkcacic_ini,'');
794   - Writeln(chkcacic_ini,'# Recomendação Importante:');
795   - Writeln(chkcacic_ini,'# =======================');
796   - Writeln(chkcacic_ini,'# Para benefício da rede local, criar uma pasta "modulos" no mesmo nível do chkcacic.exe, onde deverão');
797   - Writeln(chkcacic_ini,'# ser colocados todos os arquivos executáveis para uso do CACIC, pois, quando da necessidade de download');
798   - Writeln(chkcacic_ini,'# de módulo, o arquivo será apenas copiado e não será necessário o FTP:');
799   - Writeln(chkcacic_ini,'# cacic2.exe ............=> Agente Principal');
800   - Writeln(chkcacic_ini,'# cacicsvc.exe ..........=> Serviço para Sustentação do Agente Principal');
801   - Writeln(chkcacic_ini,'# ger_cols.exe ..........=> Gerente de Coletas');
802   - Writeln(chkcacic_ini,'# srcacicsrv.exe ........=> Suporte Remoto Seguro');
803   - Writeln(chkcacic_ini,'# chksis.exe ............=> Check System Routine (chkcacic residente)');
804   - Writeln(chkcacic_ini,'# ini_cols.exe ..........=> Inicializador de Coletas');
805   - Writeln(chkcacic_ini,'# wscript.exe ...........=> Motor de Execução de Scripts VBS');
806   - Writeln(chkcacic_ini,'# col_anvi.exe ..........=> Agente Coletor de Informações de Anti-Vírus');
807   - Writeln(chkcacic_ini,'# col_comp.exe ..........=> Agente Coletor de Informações de Compartilhamentos');
808   - Writeln(chkcacic_ini,'# col_hard.exe ..........=> Agente Coletor de Informações de Hardware');
809   - Writeln(chkcacic_ini,'# col_moni.exe ..........=> Agente Coletor de Informações de Sistemas Monitorados');
810   - Writeln(chkcacic_ini,'# col_patr.exe ..........=> Agente Coletor de Informações de Patrimônio e Localização Física');
811   - Writeln(chkcacic_ini,'# col_soft.exe ..........=> Agente Coletor de Informações de Software');
812   - Writeln(chkcacic_ini,'# col_undi.exe ..........=> Agente Coletor de Informações de Unidades de Disco');
813   - Writeln(chkcacic_ini,'# ===================================================================================================================');
814   - Writeln(chkcacic_ini,'');
815   - Writeln(chkcacic_ini,'');
816   - Writeln(chkcacic_ini,'# ===================================================================================================================');
817   - Writeln(chkcacic_ini,'# Exemplo de estrutura para KIT (CD) de instalação');
818   - Writeln(chkcacic_ini,'# ===================================================================================================================');
819   - Writeln(chkcacic_ini,'# d:\chkcacic.exe');
820   - Writeln(chkcacic_ini,'# d:\chkcacic.ini');
821   - Writeln(chkcacic_ini,'# \modulos');
822   - Writeln(chkcacic_ini,'# cacic2.exe');
823   - Writeln(chkcacic_ini,'# cacicsvc.exe');
824   - Writeln(chkcacic_ini,'# chksis.exe');
825   - Writeln(chkcacic_ini,'# col_anvi.exe');
826   - Writeln(chkcacic_ini,'# col_comp.exe');
827   - Writeln(chkcacic_ini,'# col_hard.exe');
828   - Writeln(chkcacic_ini,'# col_moni.exe');
829   - Writeln(chkcacic_ini,'# col_patr.exe');
830   - Writeln(chkcacic_ini,'# col_soft.exe');
831   - Writeln(chkcacic_ini,'# col_undi.exe');
832   - Writeln(chkcacic_ini,'# ger_cols.exe');
833   - Writeln(chkcacic_ini,'# srcacicsrv.exe');
834   - Writeln(chkcacic_ini,'# ini_cols.exe');
835   - Writeln(chkcacic_ini,'# wscript.exe');
836   - Writeln(chkcacic_ini,'# ===================================================================================================================');
837   - Writeln(chkcacic_ini,'# Obs.: Antes da gravação do CD ou imagem, é necessário executar "chkcacic.exe /config"');
838   - Writeln(chkcacic_ini,'# ===================================================================================================================');
839   - Writeln(chkcacic_ini,'');
840   - Writeln(chkcacic_ini,'[Cacic2]');
841   -
842   - // Atribuição dos valores do form FormConfig às variáveis...
843   - if Configs.ckboxExibeInformacoes.Checked then
844   - v_exibe_informacoes := 'S'
845   - else
846   - v_exibe_informacoes := 'N';
847   -
848   - v_ip_serv_cacic := Configs.Edit_ip_serv_cacic.text;
849   - v_te_instala_informacoes_extras := Configs.Memo_te_instala_informacoes_extras.Text;
850   -
851   - // Escrita dos parâmetros obrigatórios
852   - Writeln(chkcacic_ini,'ip_serv_cacic='+v_ip_serv_cacic);
853   - Writeln(chkcacic_ini,'cacic_dir='+TrataCacicDir(Configs.Edit_cacic_dir.text));
854   - Writeln(chkcacic_ini,'exibe_informacoes='+v_exibe_informacoes);
855   -
856   - // Escrita dos valores opcionais quando existirem
857   - if (v_te_instala_informacoes_extras <>'') then
858   - Writeln(chkcacic_ini,'te_instala_informacoes_extras='+ StringReplace(v_te_instala_informacoes_extras,#13#10,'*13*10',[rfReplaceAll]));
859   - CloseFile(chkcacic_ini); {Fecha o arquivo texto}
860   -
861   - g_oCacic.setCacicPath(TrataCacicDir(Configs.Edit_cacic_dir.text));
862   - except
863   - end;
864   -end;
865   -
866   -procedure GravaIni(strFullPath : STring);
867   -var iniFile : TextFile;
868   -begin
869   - try
870   - FileSetAttr (strFullPath,0); // Retira os atributos do arquivo para evitar o erro FILE ACCESS DENIED em máquinas 2000
871   - AssignFile(iniFile,strFullPath); {Associa o arquivo a uma variável do tipo TextFile}
872   - Rewrite (iniFile); // Recria o arquivo...
873   - Append(iniFile);
874   - Writeln(iniFile,'');
875   - Writeln(iniFile,'[Cacic2]');
876   - Writeln(iniFile,'ip_serv_cacic='+v_ip_serv_cacic);
877   - Writeln(iniFile,'cacic_dir='+g_oCacic.getCacicPath);
878   - CloseFile(iniFile); {Fecha o arquivo texto}
879   - except
880   - end;
881   -end;
882   -
883   -Function ListFileDir(Path: string):string;
884   -var
885   - SR: TSearchRec;
886   - FileList : string;
887   -begin
888   - if FindFirst(Path, faAnyFile, SR) = 0 then
889   - begin
890   - repeat
891   - if (SR.Attr <> faDirectory) then
892   - begin
893   - if (FileList<>'') then FileList := FileList + '#';
894   - FileList := FileList + SR.Name;
895   - end;
896   - until FindNext(SR) <> 0;
897   - FindClose(SR);
898   - Result := FileList;
899   - end;
900   -end;
901   -
902   -
903   -Function ChecaVersoesAgentes(p_strNomeAgente : String) : integer; // 2.2.0.16
904   -var strNomeAgente : String;
905   - v_array_NomeAgente : TStrings;
906   - intAux : integer;
907   -Begin
908   - v_array_NomeAgente := g_oCacic.explode(p_strNomeAgente,'\');
909   -
910   - v_versao_REM := XML_RetornaValor(StringReplace(StrUpper(PChar(v_array_NomeAgente[v_array_NomeAgente.count-1])),'.EXE','',[rfReplaceAll]), v_retorno);
911   - v_versao_LOC := GetVersionInfo(p_strNomeAgente);
912   -
913   - LogDebug('Checando versão de "'+p_strNomeAgente+'"');
914   -
915   - intAux := v_array_NomeAgente.Count;
916   -
917   - // V: 2.2.0.16
918   - // Verifico existência do arquivo "versoes_agentes.ini" para comparação das versões dos agentes principais
919   - if (v_versao_REM = '') AND FileExists(ExtractFilePath(Application.Exename)+'versoes_agentes.ini') then
920   - Begin
921   - if (GetValorChaveRegIni('versoes_agentes',v_array_NomeAgente[intAux-1],ExtractFilePath(Application.Exename)+'versoes_agentes.ini')<>'') then
922   - Begin
923   - LogDebug('Encontrado arquivo "'+(ExtractFilePath(Application.Exename)+'versoes_agentes.ini')+'"');
924   - v_versao_REM := GetValorChaveRegIni('versoes_agentes',v_array_NomeAgente[intAux-1],ExtractFilePath(Application.Exename)+'versoes_agentes.ini');
925   - End;
926   - End;
927   -
928   - LogDebug('Versão Remota: "'+v_versao_REM+'" - Versão Local: "'+v_versao_LOC+'"');
929   -
930   - if (v_versao_REM + v_versao_LOC <> '') and
931   - (v_versao_LOC <> '0000') then
932   - Begin
933   - if (v_versao_REM = v_versao_LOC) then
934   - Result := 1
935   - else
936   - Result := 2;
937   - End
938   - else
939   - Result := 0;
940   -End;
941   -
942   -// Dica baixada de http://procedure.blig.ig.com.br/
943   -// Adaptada por Anderson Peterle - v:2.2.0.16 - 03/2007
944   -procedure Matar(v_dir,v_files: string);
945   -var SearchRec: TSearchRec;
946   - Result: Integer;
947   - strFileName : String;
948   -begin
949   -
950   - strFileName := StringReplace(v_dir + '\' + v_files,'\\','\',[rfReplaceAll]);
951   - LogDebug('Matando: '+strFileName);
952   - Result:=FindFirst(strFileName, faAnyFile, SearchRec);
953   -
954   - while result=0 do
955   - begin
956   - strFileName := StringReplace(v_dir + '\' + SearchRec.Name,'\\','\',[rfReplaceAll]);
957   - LogDebug('Tentando Excluir: '+strFileName);
958   - if DeleteFile(strFileName) then
959   - LogDebug('Exclusão de ' + strFileName + ' efetuada com sucesso!')
960   - else
961   - Begin
962   - LogDebug('Exclusão não efetuada! Provavelmente já esteja sendo executado...');
963   - LogDebug('Tentarei finalizar Tarefa/Processo...');
964   - if (not g_oCacic.isWindowsNTPlataform()) then // Menor que NT Like
965   - KillTask(SearchRec.Name)
966   - else
967   - KillProcess(FindWindow(PChar(SearchRec.Name),nil));
968   -
969   - if DeleteFile(strFileName) then
970   - LogDebug('Exclusão Impossibilitada de ' + strFileName + '!');
971   - End;
972   -
973   - Result:=FindNext(SearchRec);
974   - end;
975   -end;
976   -
977   -function Posso_Rodar_CACIC : boolean;
978   -Begin
979   - result := false;
980   -
981   - // Se eu conseguir matar o arquivo abaixo é porque não há outra sessão deste agente aberta... (POG? Nããão! :) )
982   - Matar(g_oCacic.getCacicPath,'aguarde_CACIC.txt');
983   -
984   - // Se o aguarde_CACIC.txt existir é porque refere-se a uma versão mais atual: 2.2.0.20 ou maior
985   - if not (FileExists(g_oCacic.getCacicPath() + '\aguarde_CACIC.txt')) then
986   - result := true;
987   -End;
988   -function GetFolderDate(Folder: string): TDateTime;
989   -var
990   - Rec: TSearchRec;
991   - Found: Integer;
992   - Date: TDateTime;
993   -begin
994   - if Folder[Length(folder)] = '\' then
995   - Delete(Folder, Length(folder), 1);
996   - Result := 0;
997   - Found := FindFirst(Folder, faDirectory, Rec);
998   - try
999   - if Found = 0 then
1000   - begin
1001   - Date := FileDateToDateTime(Rec.Time);
1002   - Result := Date;
1003   - end;
1004   - finally
1005   - FindClose(Rec);
1006   - end;
1007   -end;
1008   -
1009   -procedure verifyAndGet(p_strModuleName,
1010   - p_strFileHash,
1011   - p_strDestinationFolderName : String);
1012   -var v_strFileHash,
1013   - v_strDestinationFolderName : String;
1014   -Begin
1015   - v_strDestinationFolderName := p_strDestinationFolderName + '\';
1016   - v_strDestinationFolderName := StringReplace(v_strDestinationFolderName,'\\','\',[rfReplaceAll]);
1017   -
1018   - LogDebug('Verificando módulo: '+v_strDestinationFolderName +p_strModuleName);
1019   - // Verifico validade do Módulo e mato-o em caso negativo.
1020   - v_strFileHash := g_oCacic.GetFileHash(v_strDestinationFolderName + p_strModuleName);
1021   -
1022   - LogDebug('verifyAndGet - HashCode Remot: "'+p_strFileHash+'"');
1023   - LogDebug('verifyAndGet - HashCode Local: "'+v_strFileHash+'"');
1024   -
1025   - If (v_strFileHash <> p_strFileHash) then
1026   - Matar(v_strDestinationFolderName, p_strModuleName);
1027   -
1028   - If not FileExists(v_strDestinationFolderName + p_strModuleName) Then
1029   - Begin
1030   - if (FileExists(ExtractFilePath(Application.Exename) + '\modulos\'+p_strModuleName)) then
1031   - Begin
1032   - LogDebug('Copiando '+p_strModuleName+' de '+ExtractFilePath(Application.Exename)+'modulos\');
1033   - CopyFile(PChar(ExtractFilePath(Application.Exename) + 'modulos\'+p_strModuleName), PChar(v_strDestinationFolderName + p_strModuleName),false);
1034   - FileSetAttr (PChar(v_strDestinationFolderName + p_strModuleName),0); // Retira os atributos do arquivo para evitar o erro FILE ACCESS DENIED
1035   - End
1036   - else
1037   - begin
1038   -
1039   - Try
1040   - if not FTP(XML_RetornaValor('te_serv_updates' , v_retorno),
1041   - XML_RetornaValor('nu_porta_serv_updates' , v_retorno),
1042   - XML_RetornaValor('nm_usuario_login_serv_updates', v_retorno),
1043   - XML_RetornaValor('te_senha_login_serv_updates' , v_retorno),
1044   - XML_RetornaValor('te_path_serv_updates' , v_retorno),
1045   - p_strModuleName,
1046   - v_strDestinationFolderName) then
1047   - Configs.Memo_te_instala_informacoes_extras.Lines.add(#13#10+'ATENÇÃO! Não foi possível efetuar FTP para "'+v_strDestinationFolderName + p_strModuleName+'".'+#13#10+'Verifique o Servidor de Updates.');
1048   - Except
1049   - LogDebug('FTP de "'+ v_strDestinationFolderName + p_strModuleName+'" Interrompido.');
1050   - End;
1051   -
1052   - if not FileExists(v_strDestinationFolderName + p_strModuleName) Then
1053   - Begin
1054   - LogDebug('Problemas Efetuando Download de '+ v_strDestinationFolderName + p_strModuleName+' (FTP)');
1055   - LogDebug('Conexão:');
1056   - LogDebug(XML_RetornaValor('te_serv_updates',v_retorno) +', '+
1057   - XML_RetornaValor('nu_porta_serv_updates' , v_retorno)+', '+
1058   - XML_RetornaValor('nm_usuario_login_serv_updates', v_retorno)+', '+
1059   - XML_RetornaValor('te_senha_login_serv_updates' , v_retorno)+', '+
1060   - XML_RetornaValor('te_path_serv_updates' , v_retorno));
1061   - End
1062   - else
1063   - LogDiario('Download Concluído de "'+p_strModuleName+'" (FTP)');
1064   - end;
1065   - End;
1066   - End;
1067   -
1068   -procedure chkcacic;
1069   -var bool_configura,
1070   - bool_ExistsAutoRun,
1071   - bool_ArquivoINI,
1072   - bool_CommandLine : boolean;
1073   -
1074   - v_cacic_dir,
1075   - v_te_serv_updates,
1076   - v_nu_porta_serv_updates,
1077   - v_nm_usuario_login_serv_updates,
1078   - v_te_senha_login_serv_updates,
1079   - v_te_path_serv_updates,
1080   - v_te_texto_janela_instalacao,
1081   - v_modulos,
1082   - strAux,
1083   - strDataHoraCACIC2_INI,
1084   - strDataHoraGERCOLS_INI,
1085   - strDataHoraCACIC2_FIM,
1086   - strDataHoraGERCOLS_FIM : String;
1087   -
1088   - Request_Config : TStringList;
1089   - v_array_modulos : TStrings;
1090   - Response_Config : TStringStream;
1091   - IdHTTP1: TIdHTTP;
1092   - intDownload_CACIC2,
1093   - intDownload_GER_COLS,
1094   - intAux : integer;
1095   -
1096   - wordServiceStatus : DWORD;
1097   -begin
1098   - strDataHoraCACIC2_INI := '';
1099   - strDataHoraCACIC2_FIM := '';
1100   - strDataHoraGERCOLS_INI := '';
1101   - strDataHoraGERCOLS_FIM := '';
1102   - v_te_instala_frase_sucesso := 'INSTALAÇÃO/ATUALIZAÇÃO EFETUADA COM SUCESSO!';
1103   - v_te_instala_frase_insucesso := '***** INSTALAÇÃO/ATUALIZAÇÃO NÃO EFETUADA COM SUCESSO *****';
1104   - bool_CommandLine := false;
1105   - bool_ArquivoINI := FileExists(ExtractFilePath(Application.Exename) + '\chkcacic.ini');
1106   -
1107   - g_oCacic := TCACIC.Create();
1108   - g_oCacic.setBoolCipher(true);
1109   - Try
1110   -
1111   - // 2.2.0.17 - Tratamento de opções passadas em linha de comando
1112   - // Grande dica do grande Cláudio Filho (OpenOffice.org)
1113   - if (ParamCount > 0) then
1114   - Begin
1115   - For intAux := 1 to ParamCount do
1116   - Begin
1117   - if LowerCase(Copy(ParamStr(intAux),1,6)) = '/serv=' then
1118   - begin
1119   - strAux := Trim(Copy(ParamStr(intAux),7,Length((ParamStr(intAux)))));
1120   - v_ip_serv_cacic := Trim(Copy(strAux,0,Pos('/', strAux) - 1));
1121   - If v_ip_serv_cacic = '' Then v_ip_serv_cacic := strAux;
1122   - end;
1123   - if LowerCase(Copy(ParamStr(intAux),1,5)) = '/dir=' then
1124   - begin
1125   - strAux := Trim(Copy(ParamStr(intAux),6,Length((ParamStr(intAux)))));
1126   - v_cacic_dir := Trim(Copy(strAux,0,Pos('/', strAux) - 1));
1127   - If v_cacic_dir = '' Then v_cacic_dir := strAux;
1128   - end;
1129   -
1130   - end;
1131   - if not(v_ip_serv_cacic='') and
1132   - not(v_cacic_dir='')then
1133   - bool_CommandLine := true;
1134   - End;
1135   -
1136   -
1137   - // ATENÇÃO: Trecho para uso exclusivo no âmbito da DATAPREV a nível Brasil, para internalização maciça.
1138   - // Para envio à Comunidade, retirar as chaves mais abaixo, para que o código padrão seja descomentado.
1139   - // Anderson Peterle - FEV2008
1140   - //v_ip_serv_cacic := 'UXRJO115';
1141   - //v_cacic_dir := 'Cacic';
1142   - //v_exibe_informacoes := 'N'; // Manter o "N", pois, esse mesmo ChkCacic será colocado em NetLogons!
1143   -
1144   - // Se a chamada ao chkCACIC não passou parâmetros de IP do Servidor nem Pasta Padrão...
1145   - // Obs.: Normalmente a chamada com passagem de parâmetros é feita por script em servidor de domínio, para automatização do processo
1146   - if not bool_CommandLine then
1147   - Begin
1148   - If not bool_ArquivoINI then
1149   - Begin
1150   - CriaFormConfigura;
1151   - MostraFormConfigura;
1152   - End;
1153   - v_ip_serv_cacic := GetValorChaveRegIni('Cacic2', 'ip_serv_cacic' , ExtractFilePath(Application.Exename) + '\chkcacic.ini');
1154   - v_cacic_dir := GetValorChaveRegIni('Cacic2', 'cacic_dir' , ExtractFilePath(Application.Exename) + '\chkcacic.ini');
1155   - v_exibe_informacoes := GetValorChaveRegIni('Cacic2', 'exibe_informacoes', ExtractFilePath(Application.Exename) + '\chkcacic.ini');
1156   - v_te_instala_informacoes_extras := StringReplace(GetValorChaveRegIni('Cacic2', 'te_instala_informacoes_extras', ExtractFilePath(Application.Exename) + '\chkcacic.ini'),'*13*10',#13#10,[rfReplaceAll]);
1157   - End;
1158   -
1159   - // Tratamento do diretório informado para o CACIC, para que seja na unidade HomeDrive
1160   - v_cacic_dir := TrataCacicDir(v_cacic_dir);
1161   -
1162   - g_oCacic.setCacicPath(v_cacic_dir);
1163   -
1164   - if DirectoryExists(g_oCacic.getCacicPath + 'Temp\Debugs') then
1165   - Begin
1166   - if (FormatDateTime('ddmmyyyy', GetFolderDate(g_oCacic.getCacicPath + 'Temp\Debugs')) = FormatDateTime('ddmmyyyy', date)) then
1167   - Begin
1168   - v_Debugs := true;
1169   - LogDebug('Pasta "' + g_oCacic.getCacicPath + 'Temp\Debugs" com data '+FormatDateTime('dd-mm-yyyy', GetFolderDate(g_oCacic.getCacicPath + 'Temp\Debugs'))+' encontrada. DEBUG ativado.');
1170   - End;
1171   - End;
1172   -
1173   - LogDebug('Tipo de Drive: '+intToStr(GetDriveType(nil)));
1174   -
1175   - if not (GetDriveType(nil) = DRIVE_REMOTE) then
1176   - Begin
1177   - CriaFormConfigura;
1178   - Configs.Visible := true;
1179   -
1180   - Configs.gbObrigatorio.BringToFront;
1181   - Configs.gbOpcional.BringToFront;
1182   -
1183   - Configs.Label_ip_serv_cacic.BringToFront;
1184   - Configs.Edit_ip_serv_cacic.Text := v_ip_serv_cacic;
1185   - Configs.Edit_ip_serv_cacic.ReadOnly := true;
1186   - Configs.Edit_ip_serv_cacic.BringToFront;
1187   -
1188   - Configs.Label_cacic_dir.BringToFront;
1189   - Configs.Edit_cacic_dir.Text := v_cacic_dir;
1190   - Configs.Edit_cacic_dir.ReadOnly := true;
1191   - configs.Edit_cacic_dir.BringToFront;
1192   -
1193   - Configs.Label_te_instala_informacoes_extras.Visible := false;
1194   -
1195   - Configs.ckboxExibeInformacoes.Checked := true;
1196   - Configs.ckboxExibeInformacoes.Visible := false;
1197   -
1198   - Configs.Height := 350;
1199   - Configs.lbMensagemNaoAplicavel.Visible := false;
1200   -
1201   - Configs.Memo_te_instala_informacoes_extras.Clear;
1202   - Configs.Memo_te_instala_informacoes_extras.Top := 15;
1203   - Configs.Memo_te_instala_informacoes_extras.Height := 196;
1204   -
1205   - Configs.gbObrigatorio.Caption := 'Configuração';
1206   - Configs.gbObrigatorio.Visible := true;
1207   -
1208   - Configs.gbOpcional.Caption := 'Andamento da Instalação/Atualização';
1209   - Configs.gbOpcional.Visible := true;
1210   -
1211   - Configs.Refresh;
1212   - Configs.Show;
1213   - End;
1214   -
1215   - // Verifica se o S.O. é NT Like e se o Usuário está com privilégio administrativo...
1216   - if (g_oCacic.isWindowsNTPlataform()) and (g_oCacic.isWindowsAdmin()) then
1217   - Begin
1218   - LogDebug(':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::');
1219   - LogDebug(':::::::::::::: OBTENDO VALORES DO "chkcacic.ini" ::::::::::::::');
1220   - LogDebug(':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::');
1221   - LogDebug('Drive de instalação......................: '+g_oCacic.getHomeDrive);
1222   - LogDebug('Pasta para instalação....................: '+g_oCacic.getCacicPath);
1223   - LogDebug('IP do servidor...........................: '+v_ip_serv_cacic);
1224   - LogDebug(':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::');
1225   - bool_configura := false;
1226   -
1227   - //chave AES. Recomenda-se que cada empresa/órgão altere a sua chave.
1228   - v_tstrCipherOpened := CipherOpen(g_oCacic.getCacicPath + g_oCacic.getDatFileName);
1229   -
1230   - if (g_oCacic.isWindowsGEXP()) then // Se >= Maior ou Igual ao WinXP...
1231   - Begin
1232   - Try
1233   - // Libero as policies do FireWall Interno
1234   - if (g_oCacic.isWindowsGEVista()) then // Maior ou Igual ao VISTA...
1235   - Begin
1236   - Try
1237   - Begin
1238   - // Liberando as conexões de Saída para o FTP
1239   - SetValorChaveRegEdit('HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\SharedAccess\Parameters\FirewallPolicy\FirewallRules\FTP-Out-TCP','v2.0|Action=Allow|Active=TRUE|Dir=Out|Protocol=6|Profile=Private|App='+g_oCacic.getHomeDrive+'system32\\ftp.exe|Name=FTP|Desc=Programa de transferência de arquivos|Edge=FALSE|');
1240   - SetValorChaveRegEdit('HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\SharedAccess\Parameters\FirewallPolicy\FirewallRules\FTP-Out-UDP','v2.0|Action=Allow|Active=TRUE|Dir=Out|Protocol=17|Profile=Private|App='+g_oCacic.getHomeDrive+'system32\\ftp.exe|Name=FTP|Desc=Programa de transferência de arquivos|Edge=FALSE|');
1241   - SetValorChaveRegEdit('HKEY_LOCAL_MACHINE\SYSTEM\ControlSet001\Services\SharedAccess\Parameters\FirewallPolicy\FirewallRules\FTP-Out-TCP','v2.0|Action=Allow|Active=TRUE|Dir=Out|Protocol=6|Profile=Private|App='+g_oCacic.getHomeDrive+'system32\\ftp.exe|Name=FTP|Desc=Programa de transferência de arquivos|Edge=FALSE|');
1242   - SetValorChaveRegEdit('HKEY_LOCAL_MACHINE\SYSTEM\ControlSet001\Services\SharedAccess\Parameters\FirewallPolicy\FirewallRules\FTP-Out-UDP','v2.0|Action=Allow|Active=TRUE|Dir=Out|Protocol=17|Profile=Private|App='+g_oCacic.getHomeDrive+'system32\\ftp.exe|Name=FTP|Desc=Programa de transferência de arquivos|Edge=FALSE|');
1243   -
1244   - // Liberando as conexões de Saída para o Ger_Cols
1245   - SetValorChaveRegEdit('HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\SharedAccess\Parameters\FirewallPolicy\FirewallRules\CACIC-GERCOLS-Out-TCP','v2.0|Action=Allow|Active=TRUE|Dir=Out|Protocol=6|Profile=Private|App='+g_oCacic.getCacicPath+'modulos\\ger_cols.exe|Name=GerCOLS|Desc=Módulo Gerente de Coletas do Sistema CACIC|Edge=FALSE|');
1246   - SetValorChaveRegEdit('HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\SharedAccess\Parameters\FirewallPolicy\FirewallRules\CACIC-GERCOLS-Out-UDP','v2.0|Action=Allow|Active=TRUE|Dir=Out|Protocol=17|Profile=Private|App='+g_oCacic.getCacicPath+'modulos\\ger_cols.exe|Name=GerCOLS|Desc=Módulo Gerente de Coletas do Sistema CACIC|Edge=FALSE|');
1247   - SetValorChaveRegEdit('HKEY_LOCAL_MACHINE\SYSTEM\ControlSet001\Services\SharedAccess\Parameters\FirewallPolicy\FirewallRules\CACIC-GERCOLS-Out-TCP','v2.0|Action=Allow|Active=TRUE|Dir=Out|Protocol=6|Profile=Private|App='+g_oCacic.getCacicPath+'modulos\\ger_cols.exe|Name=GerCOLS|Desc=Módulo Gerente de Coletas do Sistema CACIC|Edge=FALSE|');
1248   - SetValorChaveRegEdit('HKEY_LOCAL_MACHINE\SYSTEM\ControlSet001\Services\SharedAccess\Parameters\FirewallPolicy\FirewallRules\CACIC-GERCOLS-Out-UDP','v2.0|Action=Allow|Active=TRUE|Dir=Out|Protocol=17|Profile=Private|App='+g_oCacic.getCacicPath+'modulos\\ger_cols.exe|Name=GerCOLS|Desc=Módulo Gerente de Coletas do Sistema CACIC|Edge=FALSE|');
1249   -
1250   - // Liberando as conexões de Saída para o SrCACICsrv
1251   - SetValorChaveRegEdit('HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\SharedAccess\Parameters\FirewallPolicy\FirewallRules\CACIC-SRCACICSRV-Out-TCP','v2.0|Action=Allow|Active=TRUE|Dir=Out|Protocol=6|Profile=Private|App='+g_oCacic.getCacicPath+'modulos\\srcacicsrv.exe|Name=srCACICsrv|Desc=Módulo Suporte Remoto Seguro do Sistema CACIC|Edge=FALSE|');
1252   - SetValorChaveRegEdit('HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\SharedAccess\Parameters\FirewallPolicy\FirewallRules\CACIC-SRCACICSRV-Out-UDP','v2.0|Action=Allow|Active=TRUE|Dir=Out|Protocol=17|Profile=Private|App='+g_oCacic.getCacicPath+'modulos\\srcacicsrv.exe|Name=srCACICsrv|Desc=Módulo Suporte Remoto Seguro do Sistema CACIC|Edge=FALSE|');
1253   - SetValorChaveRegEdit('HKEY_LOCAL_MACHINE\SYSTEM\ControlSet001\Services\SharedAccess\Parameters\FirewallPolicy\FirewallRules\CACIC-SRCACICSRV-Out-TCP','v2.0|Action=Allow|Active=TRUE|Dir=Out|Protocol=6|Profile=Private|App='+g_oCacic.getCacicPath+'modulos\\srcacicsrv.exe|Name=srCACICsrv|Desc=Módulo Suporte Remoto Seguro do Sistema CACIC|Edge=FALSE|');
1254   - SetValorChaveRegEdit('HKEY_LOCAL_MACHINE\SYSTEM\ControlSet001\Services\SharedAccess\Parameters\FirewallPolicy\FirewallRules\CACIC-SRCACICSRV-Out-UDP','v2.0|Action=Allow|Active=TRUE|Dir=Out|Protocol=17|Profile=Private|App='+g_oCacic.getCacicPath+'modulos\\srcacicsrv.exe|Name=srCACICsrv|Desc=Módulo Suporte Remoto Seguro do Sistema CACIC|Edge=FALSE|');
1255   -
1256   - // Liberando as conexões de Saída para o ChkCacic
1257   - SetValorChaveRegEdit('HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\SharedAccess\Parameters\FirewallPolicy\FirewallRules\CACIC-CHKCACIC-Out-TCP','v2.0|Action=Allow|Active=TRUE|Dir=Out|Protocol=6|Profile=Private|App='+ExtractFilePath(Application.Exename) + '\chkcacic.exe|Name=chkCACIC|Desc=Módulo Verificador de Integridade e Instalador do Sistema CACIC|Edge=FALSE|');
1258   - SetValorChaveRegEdit('HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\SharedAccess\Parameters\FirewallPolicy\FirewallRules\CACIC-CHKCACIC-Out-UDP','v2.0|Action=Allow|Active=TRUE|Dir=Out|Protocol=17|Profile=Private|App='+ExtractFilePath(Application.Exename) + '\chkcacic.exe|Name=chkCACIC|Desc=Módulo Verificador de Integridade e Instalador do Sistema CACIC|Edge=FALSE|');
1259   - SetValorChaveRegEdit('HKEY_LOCAL_MACHINE\SYSTEM\ControlSet001\Services\SharedAccess\Parameters\FirewallPolicy\FirewallRules\CACIC-CHKCACIC-Out-TCP','v2.0|Action=Allow|Active=TRUE|Dir=Out|Protocol=6|Profile=Private|App='+ExtractFilePath(Application.Exename) + '\chkcacic.exe|Name=chkCACIC|Desc=Módulo Verificador de Integridade e Instalador do Sistema CACIC|Edge=FALSE|');
1260   - SetValorChaveRegEdit('HKEY_LOCAL_MACHINE\SYSTEM\ControlSet001\Services\SharedAccess\Parameters\FirewallPolicy\FirewallRules\CACIC-CHKCACIC-Out-UDP','v2.0|Action=Allow|Active=TRUE|Dir=Out|Protocol=17|Profile=Private|App='+ExtractFilePath(Application.Exename) + '\chkcacic.exe|Name=chkCACIC|Desc=Módulo Verificador de Integridade e Instalador do Sistema CACIC|Edge=FALSE|');
1261   -
1262   -
1263   - // Liberando as conexões de Saída para o ChkSis
1264   - SetValorChaveRegEdit('HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\SharedAccess\Parameters\FirewallPolicy\FirewallRules\CACIC-CHKSIS-Out-TCP','v2.0|Action=Allow|Active=TRUE|Dir=Out|Protocol=6|Profile=Private|App='+g_oCacic.getWinDir + 'chksis.exe|Name=chkSIS|Desc=Módulo Verificador de Integridade do Sistema CACIC|Edge=FALSE|');
1265   - SetValorChaveRegEdit('HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\SharedAccess\Parameters\FirewallPolicy\FirewallRules\CACIC-CHKSIS-Out-UDP','v2.0|Action=Allow|Active=TRUE|Dir=Out|Protocol=17|Profile=Private|App='+g_oCacic.getWinDir + 'chksis.exe|Name=chkSIS|Desc=Módulo Verificador de Integridade do Sistema CACIC|Edge=FALSE|');
1266   - SetValorChaveRegEdit('HKEY_LOCAL_MACHINE\SYSTEM\ControlSet001\Services\SharedAccess\Parameters\FirewallPolicy\FirewallRules\CACIC-CHKSIS-Out-TCP','v2.0|Action=Allow|Active=TRUE|Dir=Out|Protocol=6|Profile=Private|App='+g_oCacic.getWinDir + 'chksis.exe|Name=chkSIS|Desc=Módulo Verificador de Integridade do Sistema CACIC|Edge=FALSE|');
1267   - SetValorChaveRegEdit('HKEY_LOCAL_MACHINE\SYSTEM\ControlSet001\Services\SharedAccess\Parameters\FirewallPolicy\FirewallRules\CACIC-CHKSIS-Out-UDP','v2.0|Action=Allow|Active=TRUE|Dir=Out|Protocol=17|Profile=Private|App='+g_oCacic.getWinDir + 'chksis.exe|Name=chkSIS|Desc=Módulo Verificador de Integridade do Sistema CACIC|Edge=FALSE|');
1268   - End
1269   - Except
1270   - LogDebug('Problema Liberando Policies de FireWall!');
1271   - End;
1272   - End
1273   - else
1274   - Begin
1275   - // Acrescento o ChkCacic e srCACICsrv às exceções do FireWall nativo...
1276   - {chkcacic}
1277   - LogDebug('Inserindo "'+ExtractFilePath(Application.Exename) + 'chkcacic" nas exceções do FireWall!');
1278   - g_oCacic.addApplicationToFirewall('chkCACIC - Instalador do Sistema CACIC',ExtractFilePath(Application.Exename) + Application.Exename,true);
1279   - g_oCacic.addApplicationToFirewall('srCACICsrv - Módulo de Suporte Remoto Seguro do Sistema CACIC',g_oCacic.getCacicPath + 'modulos\srcacicsrv.exe',true);
1280   - End;
1281   - Except
1282   - End;
1283   - End;
1284   -
1285   -
1286   - if (ParamCount > 0) and (LowerCase(Copy(ParamStr(1),1,7)) = '/config') then bool_configura := true;
1287   -
1288   - while (v_ip_serv_cacic = '') or (v_cacic_dir = '') or bool_configura do
1289   - Begin
1290   - bool_configura := false;
1291   - CriaFormConfigura;
1292   -
1293   - Configs.Edit_ip_serv_cacic.text := v_ip_serv_cacic;
1294   - Configs.Edit_cacic_dir.text := v_cacic_dir;
1295   - if v_exibe_informacoes = 'S' then
1296   - Configs.ckboxExibeInformacoes.Checked := true
1297   - else
1298   - Configs.ckboxExibeInformacoes.Checked := false;
1299   - Configs.Memo_te_instala_informacoes_extras.text := v_te_instala_informacoes_extras;
1300   - MostraFormConfigura;
1301   - End;
1302   -
1303   - if (ParamCount > 0) and (LowerCase(Copy(ParamStr(1),1,7)) = '/config') then begin
1304   - try
1305   - g_oCacic.Free();
1306   - except
1307   - end;
1308   - Application.Terminate;
1309   - end;
1310   -
1311   - LogDebug('Verificando pasta "'+g_oCacic.getCacicPath+'"');
1312   - // Verifico a existência do diretório configurado para o Cacic, normalmente CACIC
1313   - if not DirectoryExists(g_oCacic.getCacicPath) then
1314   - begin
1315   - LogDiario('Criando pasta '+g_oCacic.getCacicPath);
1316   - ForceDirectories(g_oCacic.getCacicPath);
1317   - end;
1318   -
1319   - LogDebug('Verificando pasta "'+g_oCacic.getCacicPath+'modulos'+'"');
1320   - // Para eliminar versão 20014 e anteriores que provavelmente não fazem corretamente o AutoUpdate
1321   - if not DirectoryExists(g_oCacic.getCacicPath+'modulos') then
1322   - begin
1323   - Matar(g_oCacic.getCacicPath, 'cacic2.exe');
1324   - ForceDirectories(g_oCacic.getCacicPath + 'modulos');
1325   - LogDiario('Criando pasta '+g_oCacic.getCacicPath+'modulos');
1326   - end;
1327   -
1328   - LogDebug('Verificando pasta "'+g_oCacic.getCacicPath+'Temp'+'"');
1329   - // Crio o SubDiretório TEMP, caso não exista
1330   - if not DirectoryExists(g_oCacic.getCacicPath+'Temp') then
1331   - begin
1332   - ForceDirectories(g_oCacic.getCacicPath + 'Temp');
1333   - LogDiario('Criando pasta '+g_oCacic.getCacicPath+'Temp');
1334   - end;
1335   -
1336   -
1337   - // Tento o contato com o módulo gerente WEB para obtenção de
1338   - // dados para conexão FTP e relativos às versões atuais dos principais agentes
1339   - // Busco as configurações para acesso ao ambiente FTP - Updates
1340   - Request_Config := TStringList.Create;
1341   - Request_Config.Values['in_chkcacic'] := 'chkcacic';
1342   - Response_Config := TStringStream.Create('');
1343   -
1344   - Try
1345   - LogDiario('Iniciando comunicação com Servidor Gerente WEB do CACIC');
1346   - IdHTTP1 := TIdHTTP.Create(IdHTTP1);
1347   - idHTTP1.AllowCookies := true;
1348   - idHTTP1.ASCIIFilter := false;
1349   - idHTTP1.AuthRetries := 1;
1350   - idHTTP1.BoundPort := 0;
1351   - idHTTP1.HandleRedirects := false;
1352   - idHTTP1.ProxyParams.BasicAuthentication := false;
1353   - idHTTP1.ProxyParams.ProxyPort := 0;
1354   - idHTTP1.ReadTimeout := 0;
1355   - idHTTP1.RecvBufferSize := 32768;
1356   - idHTTP1.RedirectMaximum := 15;
1357   - idHTTP1.Request.Accept := 'text/html, */*';
1358   - idHTTP1.Request.BasicAuthentication := true;
1359   - idHTTP1.Request.ContentLength := -1;
1360   - idHTTP1.Request.ContentRangeStart := 0;
1361   - idHTTP1.Request.ContentRangeEnd := 0;
1362   - idHTTP1.Request.ContentType := 'text/html';
1363   - idHTTP1.SendBufferSize := 32768;
1364   - idHTTP1.Tag := 0;
1365   -
1366   - IdHTTP1.Post('http://' + v_ip_serv_cacic + '/cacic2/ws/get_config.php', Request_Config, Response_Config);
1367   - idHTTP1.Disconnect;
1368   - idHTTP1.Free;
1369   -
1370   - v_retorno := Response_Config.DataString;
1371   - LogDebug('Retorno de comunicação com servidor: '+v_retorno);
1372   -
1373   - LogDebug(':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::');
1374   - LogDebug(':::::::::::::::: VALORES OBTIDOS NO Gerente WEB :::::::::::::::');
1375   - LogDebug(':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::');
1376   - LogDebug('Servidor de updates......................: '+XML_RetornaValor('te_serv_updates' , v_retorno));
1377   - LogDebug('Porta do servidor de updates.............: '+XML_RetornaValor('nu_porta_serv_updates' , v_retorno));
1378   - LogDebug('Usuário para login no servidor de updates: '+XML_RetornaValor('nm_usuario_login_serv_updates', v_retorno));
1379   - LogDebug('Pasta no servidor de updates.............: '+XML_RetornaValor('te_path_serv_updates' , v_retorno));
1380   - LogDebug(' ');
1381   - LogDebug('Versões dos Agentes Principais:');
1382   - LogDebug('------------------------------');
1383   - LogDebug('Cacic2 - Agente do Systray.........: '+XML_RetornaValor('CACIC2', v_retorno));
1384   - LogDebug('Ger_Cols - Gerente de Coletas........: '+XML_RetornaValor('GER_COLS', v_retorno));
1385   - LogDebug('ChkSis - Verificador de Integridade: '+XML_RetornaValor('CHKSIS', v_retorno));
1386   - LogDebug(':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::');
1387   - Except
1388   - Begin
1389   - Configs.Memo_te_instala_informacoes_extras.Lines.Add(#13#10+'ATENÇÃO! Não foi possível estabelecer comunicação com o módulo Gerente WEB em "'+v_ip_serv_cacic+'".');
1390   - LogDiario('**********************************************************');
1391   - LogDiario('Oops! Não Foi Possível Comunicar com o Módulo Gerente WEB!');
1392   - LogDiario('**********************************************************');
1393   - End
1394   - End;
1395   - Request_Config.Free;
1396   - Response_Config.Free;
1397   -
1398   - // Se NTFS em NT/2K/XP...
1399   - // If NTFS on NT Like...
1400   - if (g_oCacic.isWindowsNTPlataform()) then
1401   - Begin
1402   - LogDebug(':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::');
1403   - LogDebug('::::::: VERIFICANDO FILE SYSTEM E ATRIBUINDO PERMISSÕES :::::::');
1404   - LogDebug(':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::');
1405   -
1406   - // Atribuição de acesso ao módulo principal e pastas
1407   - Form1.FS_SetSecurity(g_oCacic.getCacicPath);
1408   - Form1.FS_SetSecurity(g_oCacic.getCacicPath + 'cacic2.exe');
1409   - Form1.FS_SetSecurity(g_oCacic.getCacicPath + g_oCacic.getDatFileName);
1410   - Form1.FS_SetSecurity(g_oCacic.getCacicPath + 'cacic2.log');
1411   - Form1.FS_SetSecurity(g_oCacic.getCacicPath + 'modulos');
1412   - Form1.FS_SetSecurity(g_oCacic.getCacicPath + 'temp');
1413   -
1414   - // Atribuição de acesso aos módulos de gerenciamento de coletas e coletas para permissão de atualizações de versões
1415   - Form1.FS_SetSecurity(g_oCacic.getCacicPath + 'modulos\ger_cols.exe');
1416   - Form1.FS_SetSecurity(g_oCacic.getCacicPath + 'modulos\srcacicsrv.exe');
1417   - Form1.FS_SetSecurity(g_oCacic.getCacicPath + 'modulos\col_anvi.exe');
1418   - Form1.FS_SetSecurity(g_oCacic.getCacicPath + 'modulos\col_comp.exe');
1419   - Form1.FS_SetSecurity(g_oCacic.getCacicPath + 'modulos\col_hard.exe');
1420   - Form1.FS_SetSecurity(g_oCacic.getCacicPath + 'modulos\col_moni.exe');
1421   - Form1.FS_SetSecurity(g_oCacic.getCacicPath + 'modulos\col_patr.exe');
1422   - Form1.FS_SetSecurity(g_oCacic.getCacicPath + 'modulos\col_soft.exe');
1423   - Form1.FS_SetSecurity(g_oCacic.getCacicPath + 'modulos\col_undi.exe');
1424   - Form1.FS_SetSecurity(g_oCacic.getCacicPath + 'modulos\ini_cols.exe');
1425   - Form1.FS_SetSecurity(g_oCacic.getCacicPath + 'modulos\wscript.exe');
1426   -
1427   - // Atribuição de acesso para atualização do módulo verificador de integridade do sistema e seus arquivos
1428   - Form1.FS_SetSecurity(g_oCacic.getWinDir + 'chksis.exe');
1429   - Form1.FS_SetSecurity(g_oCacic.getWinDir + 'chksis.log');
1430   - Form1.FS_SetSecurity(g_oCacic.getWinDir + 'chksis.dat');
1431   -
1432   - // Atribuição de acesso para atualização/exclusão de log do instalador
1433   - Form1.FS_SetSecurity(g_oCacic.getHomeDrive + 'chkcacic.log');
1434   - LogDebug(':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::');
1435   - End;
1436   -
1437   - // Verificação de versão do cacic2.exe e exclusão em caso de versão antiga/diferente da atual
1438   - If (FileExists(g_oCacic.getCacicPath + 'cacic2.exe')) Then
1439   - Begin
1440   - // Pego as informações de dia/mês/ano/horas/minutos/segundos/milésimos que identificam o agente Cacic2
1441   - strDataHoraCACIC2_INI := FormatDateTime('ddmmyyyyhhnnsszzz', GetFolderDate(g_oCacic.getCacicPath + 'cacic2.exe'));
1442   -
1443   - intAux := ChecaVersoesAgentes(g_oCacic.getCacicPath + 'cacic2.exe');
1444   - // 0 => Arquivo de versões ou informação inexistente
1445   - // 1 => Versões iguais
1446   - // 2 => Versões diferentes
1447   - if (intAux = 0) then
1448   - Begin
1449   - v_versao_local := StringReplace(trim(GetVersionInfo(g_oCacic.getCacicPath + 'cacic2.exe')),'.','',[rfReplaceAll]);
1450   - v_versao_remota := StringReplace(XML_RetornaValor('CACIC2' , v_retorno),'0103','',[rfReplaceAll]);
1451   - End;
1452   -
1453   - if (intAux = 2) or // Caso haja diferença na comparação de versões com "versoes_agentes.ini"...
1454   - (v_versao_local ='0000') or // Provavelmente versão muito antiga ou corrompida
1455   - (v_versao_local ='2208') then
1456   - Matar(g_oCacic.getCacicPath, 'cacic2.exe');
1457   - End;
1458   -
1459   - // Verificação de versão do ger_cols.exe e exclusão em caso de versão antiga/diferente da atual
1460   - If (FileExists(g_oCacic.getCacicPath + 'modulos\ger_cols.exe')) Then
1461   - Begin
1462   - // Pego as informações de dia/mês/ano/horas/minutos/segundos/milésimos que identificam o agente Ger_Cols
1463   - strDataHoraGERCOLS_INI := FormatDateTime('ddmmyyyyhhnnsszzz', GetFolderDate(g_oCacic.getCacicPath + 'modulos\ger_cols.exe'));
1464   -
1465   - intAux := ChecaVersoesAgentes(g_oCacic.getCacicPath + 'modulos\ger_cols.exe');
1466   - // 0 => Arquivo de versões ou informação inexistente
1467   - // 1 => Versões iguais
1468   - // 2 => Versões diferentes
1469   - if (intAux = 0) then
1470   - Begin
1471   - v_versao_local := StringReplace(trim(GetVersionInfo(g_oCacic.getCacicPath + 'modulos\ger_cols.exe')),'.','',[rfReplaceAll]);
1472   - v_versao_remota := StringReplace(XML_RetornaValor('GER_COLS' , v_retorno),'0103','',[rfReplaceAll]);
1473   - End;
1474   -
1475   - if (intAux = 2) or // Caso haja diferença na comparação de versões com "versoes_agentes.ini"...
1476   - (v_versao_local ='0000') then // Provavelmente versão muito antiga ou corrompida
1477   - Matar(g_oCacic.getCacicPath + 'modulos\', 'ger_cols.exe');
1478   - End;
1479   -
1480   - // Verificação de versão do chksis.exe e exclusão em caso de versão antiga/diferente da atual
1481   - If (FileExists(g_oCacic.getWinDir + 'chksis.exe')) Then
1482   - Begin
1483   - intAux := ChecaVersoesAgentes(g_oCacic.getWinDir + 'chksis.exe');
1484   - // 0 => Arquivo de versões ou informação inexistente
1485   - // 1 => Versões iguais
1486   - // 2 => Versões diferentes
1487   - if (intAux = 0) then
1488   - Begin
1489   - v_versao_local := StringReplace(trim(GetVersionInfo(g_oCacic.getWinDir + 'chksis.exe')),'.','',[rfReplaceAll]);
1490   - v_versao_remota := StringReplace(XML_RetornaValor('CHKSIS' , v_retorno),'0103','',[rfReplaceAll]);
1491   - End;
1492   -
1493   - if (intAux = 2) or // Caso haja diferença na comparação de versões com "versoes_agentes.ini"...
1494   - (v_versao_local ='0000') then // Provavelmente versão muito antiga ou corrompida
1495   - Matar(g_oCacic.getWinDir,'chksis.exe');
1496   - End;
1497   -
1498   - // Tento detectar o ChkSis.EXE e copio ou faço FTP caso não exista
1499   - verifyAndGet('chksis.exe',
1500   - XML_RetornaValor('TE_HASH_CHKSIS', v_retorno),
1501   - g_oCacic.getWinDir);
1502   -
1503   - // Tento detectar o ChkSis.INI e crio-o caso necessário
1504   - If not FileExists(g_oCacic.getWinDir + 'chksis.ini') Then
1505   - begin
1506   - LogDebug('Criando '+g_oCacic.getWinDir + 'chksis.ini');
1507   - GravaIni(g_oCacic.getWinDir + 'chksis.ini');
1508   - FileSetAttr ( PChar(g_oCacic.getWinDir + 'chksis.ini'),0); // Retira os atributos do arquivo para evitar o erro FILE ACCESS DENIED em máquinas 2000
1509   - end;
1510   -
1511   -
1512   - // Verificação de existência do CacicSvc.exe
1513   - If (g_oCacic.isWindowsNTPlataform()) then
1514   - Begin
1515   - // Tento detectar o CACICsvc.EXE e copio ou faço FTP caso não exista
1516   - verifyAndGet('cacicsvc.exe',
1517   - XML_RetornaValor('TE_HASH_CACICSVC', v_retorno),
1518   - g_oCacic.getWinDir);
1519   -
1520   - // O CACICsvc usará o arquivo de configurações \Windows\chksis.ini
1521   - End;
1522   -
1523   - // Tento detectar o cacic2.INI e crio-o caso necessário
1524   - If not FileExists(g_oCacic.getCacicPath + 'cacic2.ini') Then
1525   - begin
1526   - LogDebug('Criando/Recriando '+g_oCacic.getCacicPath + 'cacic2.ini');
1527   - GravaIni(g_oCacic.getCacicPath + 'cacic2.ini');
1528   - end;
1529   -
1530   - // Verifico se existe a pasta "modulos"
1531   - v_modulos := ListFileDir(ExtractFilePath(Application.Exename)+'\modulos\*.exe');
1532   - if (v_modulos <> '') then LogDiario('Pasta "Modulos" encontrada..');
1533   -
1534   - // Tento detectar o Agente Principal e copio ou faço FTP caso não exista
1535   - verifyAndGet('cacic2.exe',
1536   - XML_RetornaValor('TE_HASH_CACIC2', v_retorno),
1537   - g_oCacic.getCacicPath);
1538   -
1539   - verifyAndGet('ger_cols.exe',
1540   - XML_RetornaValor('TE_HASH_GER_COLS', v_retorno),
1541   - g_oCacic.getCacicPath + 'modulos');
1542   -
1543   - // Caso exista a pasta "modulos", copio todos os executáveis para a pasta Cacic\modulos, exceto cacic2.exe, ger_cols.exe e chksis.exe
1544   - if (v_modulos <> '') then
1545   - Begin
1546   - v_array_modulos := g_oCacic.explode(v_modulos,'#');
1547   - For intAux := 0 To v_array_modulos.count -1 Do
1548   - Begin
1549   - if (v_array_modulos[intAux]<>'cacic2.exe') and
1550   - (v_array_modulos[intAux]<>'ger_cols.exe') and
1551   - (v_array_modulos[intAux]<>'chksis.exe') then
1552   - Begin
1553   - LogDiario('Copiando '+v_array_modulos[intAux]+' de '+ExtractFilePath(Application.Exename)+'modulos\');
1554   - CopyFile(PChar(ExtractFilePath(Application.Exename) + 'modulos\'+v_array_modulos[intAux]), PChar(g_oCacic.getCacicPath + 'modulos\'+v_array_modulos[intAux]),false);
1555   - FileSetAttr (PChar(g_oCacic.getCacicPath + 'modulos\'+v_array_modulos[intAux]),0); // Retira os atributos do arquivo para evitar o erro FILE ACCESS DENIED em máquinas 2000
1556   - End;
1557   - End;
1558   - End;
1559   -
1560   - // ATENÇÃO:
1561   - // Após testes no Vista, percebí que o firewall nativo interrompia o FTP e truncava o agente com tamanho zero...
1562   - // A nova tentativa abaixo ajudará a sobrepor o agente truncado e corrompido
1563   -
1564   - // Tento detectar (de novo) o ChkSis.EXE e copio ou faço FTP caso não exista
1565   - verifyAndGet('chksis.exe',
1566   - XML_RetornaValor('TE_HASH_CHKSIS', v_retorno),
1567   - g_oCacic.getWinDir);
1568   -
1569   - // Tento detectar (de novo) o Agente Principal e copio ou faço FTP caso não exista
1570   - verifyAndGet('cacic2.exe',
1571   - XML_RetornaValor('TE_HASH_CACIC2', v_retorno),
1572   - g_oCacic.getCacicPath);
1573   -
1574   - verifyAndGet('ger_cols.exe',
1575   - XML_RetornaValor('TE_HASH_GER_COLS', v_retorno),
1576   - g_oCacic.getCacicPath + 'modulos');
1577   -
1578   - if (g_oCacic.isWindowsNTPlataform) then
1579   - Begin
1580   - Try
1581   - // Acrescento o Ger_Cols e srCacicSrv às exceções do FireWall nativo...
1582   -
1583   - {chksis}
1584   - LogDebug('Inserindo "'+g_oCacic.getWinDir + 'chksis" nas exceções do FireWall!');
1585   - //LiberaFireWall(g_oCacic.getWinDir + 'chksis');
1586   - g_oCacic.addApplicationToFirewall('chkSIS - Módulo Verificador de Integridade do Sistema CACIC',g_oCacic.getWinDir + 'chksis.exe',true);
1587   -
1588   - {ger_cols}
1589   - LogDebug('Inserindo "'+g_oCacic.getCacicPath + 'modulos\ger_cols" nas exceções do FireWall!');
1590   -// LiberaFireWall(g_oCacic.getCacicPath + 'modulos\ger_cols');
1591   - g_oCacic.addApplicationToFirewall('gerCOLS - Módulo Gerente de Coletas do Sistema CACIC',g_oCacic.getCacicPath+'modulos\ger_cols.exe',true);
1592   -
1593   - {srcacicsrv}
1594   - LogDebug('Inserindo "'+g_oCacic.getCacicPath + 'modulos\srcacicsrv" nas exceções do FireWall!');
1595   - //LiberaFireWall(g_oCacic.getCacicPath + 'modulos\srcacicsrv');
1596   - g_oCacic.addApplicationToFirewall('srCACICsrv - Módulo Servidor de Suporte Remoto Seguro do Sistema CACIC',g_oCacic.getCacicPath+'modulos\srcacicsrv.exe',true);
1597   -
1598   - Except
1599   - End;
1600   - End;
1601   -
1602   - LogDebug('Gravando registros para auto-execução');
1603   -
1604   - // Somente para S.O. NOT NT LIKE
1605   - if NOT (g_oCacic.isWindowsNTPlataform) then
1606   - Begin
1607   - // Crio a chave/valor cacic2 para autoexecução do Cacic, caso não exista esta chave/valor
1608   - // Crio a chave/valor chksis para autoexecução do ChkSIS, caso não exista esta chave/valor
1609   - SetValorChaveRegEdit('HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run\CheckSystemRoutine', g_oCacic.getWinDir + 'chksis.exe');
1610   -
1611   - bool_ExistsAutoRun := false;
1612   - if (GetValorChaveRegEdit('HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run\cacic2')=g_oCacic.getCacicPath + 'cacic2.exe') then
1613   - bool_ExistsAutoRun := true
1614   - else
1615   - SetValorChaveRegEdit('HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run\cacic2', g_oCacic.getCacicPath + 'cacic2.exe');
1616   - End
1617   - else
1618   - Begin
1619   - DelValorReg('HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run\cacic2');
1620   - DelValorReg('HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run\CheckSystemRoutine');
1621   - End;
1622   -
1623   - // Igualo as chaves ip_serv_cacic dos arquivos chksis.ini e cacic2.ini!
1624   - SetValorDatMemoria('Configs.EnderecoServidor', v_ip_serv_cacic);
1625   - LogDebug('Fechando Arquivo de Configurações do Cacic');
1626   - CipherClose(g_oCacic.getCacicPath + g_oCacic.getDatFileName);
1627   -
1628   - LogDebug('Abrindo Arquivo de Configurações do ChkSis');
1629   - CipherOpen(g_oCacic.getWinDir + 'chksis.dat');
1630   - SetValorDatMemoria('Cacic2.ip_serv_cacic', v_ip_serv_cacic);
1631   - SetValorDatMemoria('Cacic2.cacic_dir' , g_oCacic.getCacicPath);
1632   - CipherClose(g_oCacic.getWinDir + 'chksis.dat');
1633   -
1634   - // Volto a gravar o chksis.ini para o difícil caso de leitura por versões antigas
1635   - SetValorChaveRegIni('Cacic2', 'ip_serv_cacic', v_ip_serv_cacic, g_oCacic.getWinDir + 'chksis.ini');
1636   - LogDebug('Fechando Arquivo de Configurações do ChkSis');
1637   -
1638   - LogDebug('Resgatando informações para identificação de alteração do agente CACIC2');
1639   - // Pego as informações de dia/mês/ano/horas/minutos/segundos/milésimos que identificam os agentes
1640   - strDataHoraCACIC2_FIM := FormatDateTime('ddmmyyyyhhnnsszzz', GetFolderDate(g_oCacic.getCacicPath + 'cacic2.exe'));
1641   - LogDebug('Inicial => "' + strDataHoraCACIC2_INI + '" Final => "' + strDataHoraCACIC2_FIM + '"');
1642   -
1643   - LogDebug('Resgatando informações para identificação de alteração do agente GER_COLS');
1644   - strDataHoraGERCOLS_FIM := FormatDateTime('ddmmyyyyhhnnsszzz', GetFolderDate(g_oCacic.getCacicPath + 'modulos\ger_cols.exe'));
1645   - LogDebug('Inicial => "' + strDataHoraGERCOLS_INI + '" Final => "' + strDataHoraGERCOLS_FIM + '"');
1646   -
1647   - // Caso o Cacic tenha sido baixado executo-o com parâmetro de configuração de servidor
1648   - if ((strDataHoraCACIC2_INI <> strDataHoraCACIC2_FIM) OR
1649   - (strDataHoraGERCOLS_INI <> strDataHoraGERCOLS_FIM)) then
1650   - Begin
1651   - v_te_texto_janela_instalacao := v_te_instala_informacoes_extras;
1652   -
1653   - if (GetValorChaveRegEdit('HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run\cacic2')=g_oCacic.getCacicPath + 'cacic2.exe') and
1654   - (not g_oCacic.isWindowsNTPlataform()) or
1655   - (g_oCacic.isWindowsNTPlataform()) then
1656   - Begin
1657   - configs.Memo_te_instala_informacoes_extras.Lines.Add(#13#10+#13#10+'Sistema CACIC'+#13#10+#13#10+v_te_instala_frase_sucesso);
1658   - End
1659   - else
1660   - Begin
1661   - Configs.Memo_te_instala_informacoes_extras.Lines.Add(#13#10+#13#10+'Sistema CACIC'+#13#10+#13#10+v_te_instala_frase_insucesso);
1662   - ComunicaInsucesso('1'); // O indicador "1" sinalizará que não foi devido a privilégio na estação
1663   - End;
1664   - End
1665   - else
1666   - LogDiario('ATENÇÃO: Instalação NÃO REALIZADA ou ATUALIZAÇÃO DESNECESSÁRIA!');
1667   -
1668   - if Posso_Rodar_CACIC or
1669   - not bool_ExistsAutoRun or
1670   - (strDataHoraCACIC2_INI <> strDataHoraCACIC2_FIM) then
1671   - Begin
1672   - // Se não for plataforma NT executo o agente principal
1673   - if not (g_oCacic.isWindowsNTPlataform()) then
1674   - Begin
1675   - LogDebug('Executando '+g_oCacic.getCacicPath + 'cacic2.exe /ip_serv_cacic=' + v_ip_serv_cacic);
1676   - if (strDataHoraCACIC2_INI <> strDataHoraCACIC2_FIM) then
1677   - g_oCacic.createSampleProcess(g_oCacic.getCacicPath + 'cacic2.exe /ip_serv_cacic=' + v_ip_serv_cacic+ ' /execute', false)
1678   - else
1679   - g_oCacic.createSampleProcess(g_oCacic.getCacicPath + 'cacic2.exe /ip_serv_cacic=' + v_ip_serv_cacic , false);
1680   - End
1681   - else
1682   - Begin
1683   -
1684   - {*** 1 = SERVICE_STOPPED ***}
1685   - {*** 2 = SERVICE_START_PENDING ***}
1686   - {*** 3 = SERVICE_STOP_PENDING ***}
1687   - {*** 4 = SERVICE_RUNNING ***}
1688   - {*** 5 = SERVICE_CONTINUE_PENDING ***}
1689   - {*** 6 = SERVICE_PAUSE_PENDING ***}
1690   - {*** 7 = SERVICE_PAUSED ***}
1691   -
1692   - // Verifico se o serviço está instalado/rodando,etc.
1693   - wordServiceStatus := ServiceGetStatus(nil,'cacicservice');
1694   - if (wordServiceStatus = 0) then
1695   - Begin
1696   - // Instalo e Habilito o serviço
1697   - LogDiario('Instalando/Iniciando CACICservice...');
1698   - g_oCacic.createSampleProcess(g_oCacic.getWinDir + 'cacicsvc.exe -install',false);
1699   - End
1700   - else if ((wordServiceStatus < 4) or
1701   - (wordServiceStatus > 4)) then
1702   - Begin
1703   - LogDiario('Iniciando CACICservice');
1704   - g_oCacic.createSampleProcess(g_oCacic.getWinDir + 'cacicsvc.exe -start', false);
1705   - End
1706   - else
1707   - LogDiario('Não instalei o CACICservice. Já está rodando...');
1708   - End;
1709   -
1710   - if Posso_Rodar_CACIC and not bool_CommandLine then
1711   - MessageDLG(#13#10+'ATENÇÃO! É recomendável a reinicialização do sistema para início de ações do CACIC.',mtError,[mbOK],0);
1712   -
1713   - End
1714   - else
1715   - LogDebug('Chave de Auto-Execução já existente ou Execução já iniciada...');
1716   - End
1717   - else
1718   - Begin // Se NT/2000/XP/...
1719   - if (v_exibe_informacoes = 'S') and not bool_CommandLine then
1720   - MessageDLG(#13#10+'ATENÇÃO! Essa aplicação requer execução com nível administrativo.',mtError,[mbOK],0);
1721   - LogDiario('Sem Privilégios: Necessário ser administrador "local" da estação');
1722   - ComunicaInsucesso('0'); // O indicador "0" (zero) sinalizará falta de privilégio na estação
1723   - End;
1724   - Except
1725   - LogDiario('Falha na Instalação/Atualização');
1726   - End;
1727   -
1728   - try
1729   - g_oCacic.Free;
1730   - except
1731   - end;
1732   -
1733   - Application.Terminate;
1734   -end;
1735   -
1736   -function ServiceRunning(sMachine, sService: PChar): Boolean;
1737   -begin
1738   - Result := SERVICE_RUNNING = ServiceGetStatus(sMachine, sService);
1739   -end;
1740   -
1741   -function ServiceStopped(sMachine, sService: PChar): Boolean;
1742   -begin
1743   - Result := SERVICE_STOPPED = ServiceGetStatus(sMachine, sService);
1744   -end;
1745   -
1746   -function FindWindowByTitle(WindowTitle: string): Hwnd;
1747   -var
1748   - NextHandle: Hwnd;
1749   - NextTitle: array[0..260] of char;
1750   -begin
1751   - // Get the first window
1752   - NextHandle := GetWindow(Application.Handle, GW_HWNDFIRST);
1753   - while NextHandle > 0 do
1754   - begin
1755   - // retrieve its text
1756   - GetWindowText(NextHandle, NextTitle, 255);
1757   -
1758   - if (trim(StrPas(NextTitle))<> '') and (Pos(strlower(pchar(WindowTitle)), strlower(PChar(StrPas(NextTitle)))) <> 0) then
1759   - begin
1760   - Result := NextHandle;
1761   - Exit;
1762   - end
1763   - else
1764   - // Get the next window
1765   - NextHandle := GetWindow(NextHandle, GW_HWNDNEXT);
1766   - end;
1767   - Result := 0;
1768   -end;
1769   -
1770   -// Rotina obtida em http://www.swissdelphicenter.ch/torry/showcode.php?id=266
1771   -{For Windows 9x/ME/2000/XP }
1772   -function KillTask(ExeFileName: string): Integer;
1773   -const
1774   - PROCESS_TERMINATE = $0001;
1775   -var
1776   - ContinueLoop: BOOL;
1777   - FSnapshotHandle: THandle;
1778   - FProcessEntry32: TProcessEntry32;
1779   -begin
1780   - Result := 0;
1781   - FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
1782   - FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
1783   - ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
1784   -
1785   - while Integer(ContinueLoop) <> 0 do
1786   - begin
1787   - if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
1788   - UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) =
1789   - UpperCase(ExeFileName))) then
1790   - Result := Integer(TerminateProcess(
1791   - OpenProcess(PROCESS_TERMINATE,
1792   - BOOL(0),
1793   - FProcessEntry32.th32ProcessID),
1794   - 0));
1795   - ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
1796   - end;
1797   - CloseHandle(FSnapshotHandle);
1798   -end;
1799   -
1800   -// Rotina obtida em http://www.swissdelphicenter.ch/torry/showcode.php?id=266
1801   -{ For Windows NT/2000/XP }
1802   -procedure KillProcess(hWindowHandle: HWND);
1803   -var
1804   - hprocessID: INTEGER;
1805   - processHandle: THandle;
1806   - DWResult: DWORD;
1807   -begin
1808   - SendMessageTimeout(hWindowHandle, WM_DDE_TERMINATE, 0, 0,
1809   - SMTO_ABORTIFHUNG or SMTO_NORMAL, 5000, DWResult);
1810   -
1811   - if isWindow(hWindowHandle) then
1812   - begin
1813   - // PostMessage(hWindowHandle, WM_QUIT, 0, 0);
1814   -
1815   - { Get the process identifier for the window}
1816   - GetWindowThreadProcessID(hWindowHandle, @hprocessID);
1817   - if hprocessID <> 0 then
1818   - begin
1819   - { Get the process handle }
1820   - processHandle := OpenProcess(PROCESS_TERMINATE or PROCESS_QUERY_INFORMATION,
1821   - False, hprocessID);
1822   - if processHandle <> 0 then
1823   - begin
1824   - { Terminate the process }
1825   - TerminateProcess(processHandle, 0);
1826   - CloseHandle(ProcessHandle);
1827   - end;
1828   - end;
1829   - end;
1830   -end;
1831   -
1832   -procedure TForm1.FormCreate(Sender: TObject);
1833   -begin
1834   - Application.ShowMainForm:=false;
1835   - v_Debugs := false;
1836   -
1837   - chkcacic;
1838   -
1839   - Application.Terminate;
1840   -end;
1841   -
1842   -procedure TForm1.FS_SetSecurity(p_Target : String);
1843   -var intAux : integer;
1844   - v_FS_Security : TNTFileSecurity;
1845   -begin
1846   - v_FS_Security := TNTFileSecurity.Create(nil);
1847   - v_FS_Security.FileName := '';
1848   - v_FS_Security.FileName := p_Target;
1849   - v_FS_Security.RefreshSecurity;
1850   -
1851   - if (v_FS_Security.FileSystemName='NTFS')then
1852   - Begin
1853   - for intAux := 0 to Pred(v_FS_Security.EntryCount) do
1854   - begin
1855   - case v_FS_Security.EntryType[intAux] of seAlias, seDomain, seGroup :
1856   - Begin // If local group, alias or user...
1857   - v_FS_Security.FileRights[intAux] := [faAll];
1858   - v_FS_Security.DirectoryRights[intAux] := [faAll];
1859   - LogDebug(p_Target + ' [Full Access] >> '+v_FS_Security.EntryName[intAux]);
1860   - //Setting total access on p_Target to local groups.
1861   - End;
1862   - End;
1863   - end;
1864   -
1865   - // Atribui permissão total aos grupos locais
1866   - // Set total permissions to local groups
1867   - v_FS_Security.SetSecurity;
1868   - end
1869   - else LogDiario('File System: "' + v_FS_Security.FileSystemName+'" - Ok!');
1870   -
1871   - v_FS_Security.Free;
1872   -end;
1873   -end.
chkcacic/rsFileVersion.pas
View file @eda4e86
... ... @@ -1,159 +0,0 @@
1   -unit rsFileVersion;
2   -{*******************************************************************************
3   -Unit: rsFileVersion
4   -Author: Michael Burton
5   - Copyright © 1999 Rimrock Software
6   - All rights reserved.
7   -Date: February 3, 1999
8   -Use with: Delphi 2, 3, 4 only
9   -Description: Describes an object called TrsFileVersion that will retrieve
10   - version and build information from 32-bit executable files (exe,
11   - dll, ocx, vbx, vxd, drv, pdr, mpd, etc), if that information is
12   - present in the file.
13   -Maintenance:
14   -********************************************************************************}
15   -
16   -interface
17   -
18   -uses Windows, Classes, SysUtils;
19   -
20   -type
21   - TrsFileVersion = class(TObject)
22   - private
23   - { Private declarations }
24   - FVersion: string; {concatenation of major.minor.release}
25   - FMajor: Word; {major version number}
26   - FMinor: Word; {minor version number}
27   - FRelease: Word; {release version number}
28   - FBuild: Word; {build number}
29   - function ReadVersionInfo(sProgram: string; Major, Minor,
30   - Release, Build : pWord) :Boolean;
31   - public
32   - { Public declarations }
33   - constructor Create;
34   - function GetFileVersion(sFile: string): boolean;
35   - procedure SetDefaultProperties;
36   - published
37   - { Published declarations }
38   - property Version: string read FVersion;
39   - property Major: Word read FMajor default 0;
40   - property Minor: Word read FMinor default 0;
41   - property Release: Word read FRelease default 0;
42   - property Build: Word read FBuild default 0;
43   - end;
44   -
45   -implementation
46   -
47   -{********************************************************************
48   -Function : Create
49   -Date : February 1, 1999
50   -Description : Initialize variables
51   -Inputs : None
52   -Outputs : None
53   -********************************************************************}
54   -constructor TrsFileVersion.Create;
55   -begin
56   - inherited Create;
57   - SetDefaultProperties;
58   -end;
59   -
60   -{********************************************************************
61   -Function : GetFileVersion
62   -Date : February 3, 1999
63   -Description : Get the version of an executable file
64   -Inputs : The path/filename of the file to get a version for
65   -Outputs : True if there was version info, else false.
66   - If true, the version info will be in the object
67   - properties.
68   -********************************************************************}
69   -function TrsFileVersion.GetFileVersion(sFile: string): boolean;
70   -var
71   - Major,Minor, Release, Build : Word;
72   -begin
73   - Result := ReadVersionInfo(sFile, @Major,@Minor, @Release, @Build);
74   - if Result then begin
75   - FMajor := Major;
76   - FMinor := Minor;
77   - FRelease := Release;
78   - FBuild := Build;
79   - FVersion := IntToStr(FMajor) + '.' + IntToStr(FMinor) + '.' +
80   - IntToStr(FRelease);
81   - end else begin
82   - SetDefaultProperties;
83   - end;
84   -end;
85   -
86   -{********************************************************************
87   -Function : SetDefaultProperties
88   -Date : February 1, 1999
89   -Description : set the properties to their default values
90   -Inputs : None.
91   -Outputs : None.
92   -********************************************************************}
93   -procedure TrsFileVersion.SetDefaultProperties;
94   -begin
95   - FVersion := '';
96   - FMajor := 0;
97   - FMinor := 0;
98   - FRelease := 0;
99   - FBuild := 0;
100   -end;
101   -
102   -{********************************************************************
103   -Function : ReadVersionInfo
104   -Date : February 1, 1999
105   -Description : Read the version and build info from an executable
106   -Inputs : sProgram - the name of the file to read
107   -Outputs : Major - the major version number
108   - Minor - the minor version number
109   - Release - the release number
110   - Build - the build number
111   -********************************************************************}
112   -function TrsFileVersion.ReadVersionInfo(sProgram: string; Major, Minor, Release, Build : pWord) :Boolean;
113   -var
114   - Info : PVSFixedFileInfo;
115   -{$ifdef VER120}
116   - InfoSize : Cardinal;
117   -{$else}
118   - InfoSize : UINT;
119   -{$endif}
120   - nHwnd : DWORD;
121   - BufferSize : DWORD;
122   - Buffer : Pointer;
123   -begin
124   - BufferSize := GetFileVersionInfoSize(pchar(sProgram),nHWnd); {Get buffer size}
125   - Result := True;
126   - if BufferSize <> 0 then begin {if zero, there is no version info}
127   - GetMem( Buffer, BufferSize); {allocate buffer memory}
128   - try
129   - if GetFileVersionInfo(PChar(sProgram),nHWnd,BufferSize,Buffer) then begin
130   - {got version info}
131   - if VerQueryValue(Buffer, '\', Pointer(Info), InfoSize) then begin
132   - {got root block version information}
133   - if Assigned(Major) then begin
134   - Major^ := HiWord(Info^.dwFileVersionMS); {extract major version}
135   - end;
136   - if Assigned(Minor) then begin
137   - Minor^ := LoWord(Info^.dwFileVersionMS); {extract minor version}
138   - end;
139   - if Assigned(Release) then begin
140   - Release^ := HiWord(Info^.dwFileVersionLS); {extract release version}
141   - end;
142   - if Assigned(Build) then begin
143   - Build^ := LoWord(Info^.dwFileVersionLS); {extract build version}
144   - end;
145   - end else begin
146   - Result := False; {no root block version info}
147   - end;
148   - end else begin
149   - Result := False; {couldn't get version info}
150   - end;
151   - finally
152   - FreeMem(Buffer, BufferSize); {release buffer memory}
153   - end;
154   - end else begin
155   - Result := False; {no version info at all}
156   - end;
157   -end;
158   -
159   -end.
chkcacic/xml.pas
View file @eda4e86
... ... @@ -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.