* Replaced fphttpclient with indy10.
* Added compression support
|
@ -103,6 +103,9 @@ Once the first none-empty line is unrecognized (no command found), the parser wi
|
||||||
This can be repeated multiple times but will only be used when Method == POST.
|
This can be repeated multiple times but will only be used when Method == POST.
|
||||||
The Content-Type header is set automatically too.
|
The Content-Type header is set automatically too.
|
||||||
|
|
||||||
|
`Compress[ed]`
|
||||||
|
: Adds support for gzip,deflate compression to the connection.
|
||||||
|
|
||||||
`Call <URL>`
|
`Call <URL>`
|
||||||
: This prepares the actual call by providing the URL to be called.
|
: This prepares the actual call by providing the URL to be called.
|
||||||
Variables in the form of `@<variablename>` are replaced accordingly.
|
Variables in the form of `@<variablename>` are replaced accordingly.
|
||||||
|
|
|
@ -24,11 +24,25 @@ interface
|
||||||
|
|
||||||
uses
|
uses
|
||||||
Classes, SysUtils, CustApp,
|
Classes, SysUtils, CustApp,
|
||||||
IniFiles, fphttpclient, jsonparser, JTemplate,
|
IniFiles, jsonparser, JTemplate,
|
||||||
UFilter;
|
UFilter, IdHTTP, IdMultipartFormData;
|
||||||
|
|
||||||
type
|
type
|
||||||
|
|
||||||
|
{ TRestHTTP }
|
||||||
|
|
||||||
|
TRestHTTP = class(TIdHTTP)
|
||||||
|
public
|
||||||
|
procedure Perform(AMethod, AURL: String; ARequest, AResponse: TStream);
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TRestRequest }
|
||||||
|
|
||||||
|
TRestRequest = class(TIdHTTPRequest)
|
||||||
|
public
|
||||||
|
procedure Prepare;
|
||||||
|
end;
|
||||||
|
|
||||||
{ TRestemplateApplication }
|
{ TRestemplateApplication }
|
||||||
|
|
||||||
TRestemplateApplication = class(TCustomApplication)
|
TRestemplateApplication = class(TCustomApplication)
|
||||||
|
@ -38,9 +52,10 @@ type
|
||||||
FSessionIni: TIniFile;
|
FSessionIni: TIniFile;
|
||||||
FTemplateName: String;
|
FTemplateName: String;
|
||||||
FParser: TJTemplateParser;
|
FParser: TJTemplateParser;
|
||||||
FHttp: TFPHTTPClient;
|
FHttp: TRestHTTP;
|
||||||
|
FRequest: TRestRequest;
|
||||||
FContent: TStringList;
|
FContent: TStringList;
|
||||||
FFormFields: TStringList;
|
FFormFields: TIdMultiPartFormDataStream;
|
||||||
FFilters: TFilterList;
|
FFilters: TFilterList;
|
||||||
FBeautify: Boolean;
|
FBeautify: Boolean;
|
||||||
FURL: String;
|
FURL: String;
|
||||||
|
@ -67,7 +82,8 @@ type
|
||||||
implementation
|
implementation
|
||||||
|
|
||||||
uses
|
uses
|
||||||
strutils, crt, UCRTHelper, fpjson, DOM, XMLRead, XMLWrite, vinfo;
|
strutils, crt, UCRTHelper, fpjson, DOM, XMLRead, XMLWrite, vinfo,
|
||||||
|
IdCompressorZLib;
|
||||||
|
|
||||||
type
|
type
|
||||||
TContentType = (ctOther, ctJSON, ctXML);
|
TContentType = (ctOther, ctJSON, ctXML);
|
||||||
|
@ -84,6 +100,22 @@ begin
|
||||||
Result := (ContentType <> ctOther);
|
Result := (ContentType <> ctOther);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
{ TRestRequest }
|
||||||
|
|
||||||
|
procedure TRestRequest.Prepare;
|
||||||
|
begin
|
||||||
|
//Parse RawHeaders, since they have precendence and should not be overridden!
|
||||||
|
ProcessHeaders;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TRestHTTP }
|
||||||
|
|
||||||
|
procedure TRestHTTP.Perform(AMethod, AURL: String; ARequest, AResponse: TStream
|
||||||
|
);
|
||||||
|
begin
|
||||||
|
DoRequest(AMethod, AURL, ARequest, AResponse, []);
|
||||||
|
end;
|
||||||
|
|
||||||
{ TRestemplateApplication }
|
{ TRestemplateApplication }
|
||||||
|
|
||||||
procedure TRestemplateApplication.DoRun;
|
procedure TRestemplateApplication.DoRun;
|
||||||
|
@ -199,6 +231,11 @@ begin
|
||||||
Result := True;
|
Result := True;
|
||||||
CmdFormField(Copy(ALine, 11, Length(ALine)));
|
CmdFormField(Copy(ALine, 11, Length(ALine)));
|
||||||
end else
|
end else
|
||||||
|
if AnsiStartsStr('Compress', ALine) then
|
||||||
|
begin
|
||||||
|
Result := True;
|
||||||
|
FHttp.Compressor := TIdCompressorZLib.Create(FHttp);
|
||||||
|
end else
|
||||||
if AnsiStartsStr('Call ', ALine) then
|
if AnsiStartsStr('Call ', ALine) then
|
||||||
begin
|
begin
|
||||||
Result := True;
|
Result := True;
|
||||||
|
@ -255,7 +292,11 @@ begin
|
||||||
varName := Trim(Copy(AHeader, 1, i - 1));
|
varName := Trim(Copy(AHeader, 1, i - 1));
|
||||||
varValue := Trim(Copy(AHeader, i + 1, Length(AHeader)));
|
varValue := Trim(Copy(AHeader, i + 1, Length(AHeader)));
|
||||||
|
|
||||||
FHttp.AddHeader(varName, varValue);
|
//Special handling is required for Indy
|
||||||
|
{if SameText(varName, 'Accept-Encoding') then
|
||||||
|
FHttp.Request.AcceptEncoding := varValue
|
||||||
|
else}
|
||||||
|
FRequest.RawHeaders.AddValue(varName, varValue);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure TRestemplateApplication.CmdBasicAuth(AData: String);
|
procedure TRestemplateApplication.CmdBasicAuth(AData: String);
|
||||||
|
@ -268,8 +309,9 @@ begin
|
||||||
while (i < Length(AData)) and (AData[i] <> separator) do
|
while (i < Length(AData)) and (AData[i] <> separator) do
|
||||||
Inc(i);
|
Inc(i);
|
||||||
|
|
||||||
FHttp.UserName := Copy(AData, 2, i - 2);
|
FRequest.Username := Copy(AData, 2, i - 2);
|
||||||
FHttp.Password := Copy(AData, i + 1, Length(AData));
|
FRequest.Password := Copy(AData, i + 1, Length(AData));
|
||||||
|
FRequest.BasicAuthentication := True;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure TRestemplateApplication.CmdHighlight(AData: String);
|
procedure TRestemplateApplication.CmdHighlight(AData: String);
|
||||||
|
@ -278,10 +320,18 @@ begin
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure TRestemplateApplication.CmdFormField(AData: String);
|
procedure TRestemplateApplication.CmdFormField(AData: String);
|
||||||
|
var
|
||||||
|
i: Integer;
|
||||||
begin
|
begin
|
||||||
|
i := 1;
|
||||||
FParser.Content := AData;
|
FParser.Content := AData;
|
||||||
FParser.Replace;
|
FParser.Replace;
|
||||||
FFormFields.Add(FParser.Content);
|
AData := FParser.Content;
|
||||||
|
|
||||||
|
while (i < Length(AData)) and (AData[i] <> '=') do
|
||||||
|
Inc(i);
|
||||||
|
|
||||||
|
FFormFields.AddFormField(Copy(AData, 1, i - 1), Copy(AData, i + 1, Length(AData)));
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure TRestemplateApplication.ProcessCall(AURL: String);
|
procedure TRestemplateApplication.ProcessCall(AURL: String);
|
||||||
|
@ -304,23 +354,24 @@ begin
|
||||||
if FContent.Count > 0 then
|
if FContent.Count > 0 then
|
||||||
begin
|
begin
|
||||||
request := TMemoryStream.Create;
|
request := TMemoryStream.Create;
|
||||||
|
|
||||||
// Variable replacement
|
// Variable replacement
|
||||||
FParser.Content := FContent.Text;
|
FParser.Content := FContent.Text;
|
||||||
FParser.Replace;
|
FParser.Replace;
|
||||||
FContent.Text := FParser.Content;
|
FContent.Text := FParser.Content;
|
||||||
|
|
||||||
FContent.SaveToStream(request);
|
FContent.SaveToStream(request);
|
||||||
request.Position := 0;
|
|
||||||
FHttp.RequestBody := request;
|
|
||||||
end;
|
end;
|
||||||
|
|
||||||
try
|
try
|
||||||
//Special handling for formdata
|
FRequest.Prepare;
|
||||||
if SameText('POST', FMethod) and (FFormFields.Count > 0) then
|
FHttp.Request := FRequest;
|
||||||
FHttp.FormPost(AURL, FFormFields, response)
|
FHttp.HTTPOptions := FHttp.HTTPOptions + [hoNoProtocolErrorException];
|
||||||
else
|
if FFormFields.Size > 0 then
|
||||||
FHttp.HTTPMethod(FMethod, AURL, response, []);
|
begin
|
||||||
|
FHttp.Request.ContentType := FFormFields.RequestContentType;
|
||||||
|
FHttp.Perform(FMethod, AURL, FFormFields, response);
|
||||||
|
end else
|
||||||
|
FHttp.Perform(FMethod, AURL, request, response);
|
||||||
except
|
except
|
||||||
on E: Exception do
|
on E: Exception do
|
||||||
begin
|
begin
|
||||||
|
@ -331,16 +382,16 @@ begin
|
||||||
end;
|
end;
|
||||||
|
|
||||||
writeln;
|
writeln;
|
||||||
writeln('Status: ', FHttp.ResponseStatusCode, ' (', FHttp.ResponseStatusText, ')');
|
writeln('Status: ', FHttp.ResponseCode, ' (', FHttp.ResponseText, ')');
|
||||||
writeln;
|
writeln;
|
||||||
writeln('Headers:');
|
writeln('Headers:');
|
||||||
for s in FHttp.ResponseHeaders do
|
for s in FHttp.Response.RawHeaders do
|
||||||
writeln(' ', s);
|
writeln(' ', s);
|
||||||
writeln;
|
writeln;
|
||||||
|
|
||||||
response.Position := 0;
|
response.Position := 0;
|
||||||
|
|
||||||
if FBeautify and IdentifyContentType(FHttp.GetHeader(FHttp.ResponseHeaders, 'Content-Type'), contentType) then
|
if FBeautify and IdentifyContentType(FHttp.Response.ContentType, contentType) then
|
||||||
begin
|
begin
|
||||||
case contentType of
|
case contentType of
|
||||||
ctJSON:
|
ctJSON:
|
||||||
|
@ -474,8 +525,10 @@ begin
|
||||||
|
|
||||||
FSessionIni := TIniFile.Create(FConfigDir + 'session.ini');
|
FSessionIni := TIniFile.Create(FConfigDir + 'session.ini');
|
||||||
FContent := TStringList.Create;
|
FContent := TStringList.Create;
|
||||||
FFormFields := TStringList.Create;
|
FFormFields := TIdMultiPartFormDataStream.Create;
|
||||||
FHttp := TFPHTTPClient.Create(Self);
|
FHttp := TRestHTTP.Create(nil);
|
||||||
|
FRequest := TRestRequest.Create(FHttp);
|
||||||
|
FRequest.RawHeaders.AddValue('User-Agent', 'Mozilla/4.0 (compatible; restemplate ' + VersionInfo.GetProductVersionString + ')');
|
||||||
FFilters := TFilterList.Create;
|
FFilters := TFilterList.Create;
|
||||||
FParser := TJTemplateParser.Create;
|
FParser := TJTemplateParser.Create;
|
||||||
end;
|
end;
|
||||||
|
@ -486,6 +539,7 @@ begin
|
||||||
FContent.Free;
|
FContent.Free;
|
||||||
FFormFields.Free;
|
FFormFields.Free;
|
||||||
FHttp.Free;
|
FHttp.Free;
|
||||||
|
//TODO Owned? FRequest.Free;
|
||||||
FFilters.Free;
|
FFilters.Free;
|
||||||
FParser.Free;
|
FParser.Free;
|
||||||
inherited Destroy;
|
inherited Destroy;
|
||||||
|
|
After Width: | Height: | Size: 546 KiB |
After Width: | Height: | Size: 1.1 KiB |
After Width: | Height: | Size: 1.1 KiB |
After Width: | Height: | Size: 1.1 KiB |
After Width: | Height: | Size: 1.1 KiB |
After Width: | Height: | Size: 1.1 KiB |
After Width: | Height: | Size: 1.1 KiB |
After Width: | Height: | Size: 1.1 KiB |
After Width: | Height: | Size: 1.1 KiB |
After Width: | Height: | Size: 1.1 KiB |
After Width: | Height: | Size: 1.1 KiB |
After Width: | Height: | Size: 1.1 KiB |
After Width: | Height: | Size: 1.1 KiB |
After Width: | Height: | Size: 1.1 KiB |
After Width: | Height: | Size: 1.1 KiB |
After Width: | Height: | Size: 1.1 KiB |
After Width: | Height: | Size: 1.1 KiB |
After Width: | Height: | Size: 1.1 KiB |
After Width: | Height: | Size: 1.1 KiB |
After Width: | Height: | Size: 1.1 KiB |
After Width: | Height: | Size: 1.1 KiB |
After Width: | Height: | Size: 822 B |
After Width: | Height: | Size: 1.1 KiB |
After Width: | Height: | Size: 1.1 KiB |
After Width: | Height: | Size: 822 B |
After Width: | Height: | Size: 1.1 KiB |
After Width: | Height: | Size: 1.1 KiB |
|
@ -0,0 +1,37 @@
|
||||||
|
unit IdAbout;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
{$I IdCompilerDefines.inc}
|
||||||
|
|
||||||
|
uses
|
||||||
|
{$IFDEF DOTNET}
|
||||||
|
IdAboutDotNET;
|
||||||
|
{$ELSE}
|
||||||
|
IdAboutVCL;
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
//we have a procedure for providing a product name and version in case
|
||||||
|
//we ever want to make another product.
|
||||||
|
procedure ShowAboutBox(const AProductName, AProductName2, AProductVersion : String);
|
||||||
|
procedure ShowDlg;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
{$IFDEF DOTNET}
|
||||||
|
//for some reason, the Winforms designer doesn't like this in the same unit
|
||||||
|
//as the class it's for
|
||||||
|
{$R 'IdAboutDotNET.TfrmAbout.resources' 'IdAboutDotNET.resx'}
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
procedure ShowAboutBox(const AProductName, AProductName2, AProductVersion : String);
|
||||||
|
begin
|
||||||
|
TfrmAbout.ShowAboutBox(AProductName, AProductName2, AProductVersion);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure ShowDlg;
|
||||||
|
begin
|
||||||
|
TfrmAbout.ShowDlg;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
|
@ -0,0 +1,184 @@
|
||||||
|
<?xml version="1.0" encoding="utf-8"?>
|
||||||
|
<root>
|
||||||
|
<!--
|
||||||
|
Microsoft ResX Schema
|
||||||
|
|
||||||
|
Version 1.3
|
||||||
|
|
||||||
|
The primary goals of this format is to allow a simple XML format
|
||||||
|
that is mostly human readable. The generation and parsing of the
|
||||||
|
various data types are done through the TypeConverter classes
|
||||||
|
associated with the data types.
|
||||||
|
|
||||||
|
Example:
|
||||||
|
|
||||||
|
... ado.net/XML headers & schema ...
|
||||||
|
<resheader name="resmimetype">text/microsoft-resx</resheader>
|
||||||
|
<resheader name="version">1.3</resheader>
|
||||||
|
<resheader name="reader">System.Resources.ResXResourceReader, System.Windows.Forms, ...</resheader>
|
||||||
|
<resheader name="writer">System.Resources.ResXResourceWriter, System.Windows.Forms, ...</resheader>
|
||||||
|
<data name="Name1">this is my long string</data>
|
||||||
|
<data name="Color1" type="System.Drawing.Color, System.Drawing">Blue</data>
|
||||||
|
<data name="Bitmap1" mimetype="application/x-microsoft.net.object.binary.base64">
|
||||||
|
[base64 mime encoded serialized .NET Framework object]
|
||||||
|
</data>
|
||||||
|
<data name="Icon1" type="System.Drawing.Icon, System.Drawing" mimetype="application/x-microsoft.net.object.bytearray.base64">
|
||||||
|
[base64 mime encoded string representing a byte array form of the .NET Framework object]
|
||||||
|
</data>
|
||||||
|
|
||||||
|
There are any number of "resheader" rows that contain simple
|
||||||
|
name/value pairs.
|
||||||
|
|
||||||
|
Each data row contains a name, and value. The row also contains a
|
||||||
|
type or mimetype. Type corresponds to a .NET class that support
|
||||||
|
text/value conversion through the TypeConverter architecture.
|
||||||
|
Classes that don't support this are serialized and stored with the
|
||||||
|
mimetype set.
|
||||||
|
|
||||||
|
The mimetype is used forserialized objects, and tells the
|
||||||
|
ResXResourceReader how to depersist the object. This is currently not
|
||||||
|
extensible. For a given mimetype the value must be set accordingly:
|
||||||
|
|
||||||
|
Note - application/x-microsoft.net.object.binary.base64 is the format
|
||||||
|
that the ResXResourceWriter will generate, however the reader can
|
||||||
|
read any of the formats listed below.
|
||||||
|
|
||||||
|
mimetype: application/x-microsoft.net.object.binary.base64
|
||||||
|
value : The object must be serialized with
|
||||||
|
: System.Serialization.Formatters.Binary.BinaryFormatter
|
||||||
|
: and then encoded with base64 encoding.
|
||||||
|
|
||||||
|
mimetype: application/x-microsoft.net.object.soap.base64
|
||||||
|
value : The object must be serialized with
|
||||||
|
: System.Runtime.Serialization.Formatters.Soap.SoapFormatter
|
||||||
|
: and then encoded with base64 encoding.
|
||||||
|
|
||||||
|
mimetype: application/x-microsoft.net.object.bytearray.base64
|
||||||
|
value : The object must be serialized into a byte array
|
||||||
|
: using a System.ComponentModel.TypeConverter
|
||||||
|
: and then encoded with base64 encoding.
|
||||||
|
-->
|
||||||
|
<xsd:schema id="root" xmlns="" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:msdata="urn:schemas-microsoft-com:xml-msdata">
|
||||||
|
<xsd:element name="root" msdata:IsDataSet="true">
|
||||||
|
<xsd:complexType>
|
||||||
|
<xsd:choice maxOccurs="unbounded">
|
||||||
|
<xsd:element name="data">
|
||||||
|
<xsd:complexType>
|
||||||
|
<xsd:sequence>
|
||||||
|
<xsd:element name="value" type="xsd:string" minOccurs="0" msdata:Ordinal="1" />
|
||||||
|
<xsd:element name="comment" type="xsd:string" minOccurs="0" msdata:Ordinal="2" />
|
||||||
|
</xsd:sequence>
|
||||||
|
<xsd:attribute name="name" type="xsd:string" msdata:Ordinal="1" />
|
||||||
|
<xsd:attribute name="type" type="xsd:string" msdata:Ordinal="3" />
|
||||||
|
<xsd:attribute name="mimetype" type="xsd:string" msdata:Ordinal="4" />
|
||||||
|
</xsd:complexType>
|
||||||
|
</xsd:element>
|
||||||
|
<xsd:element name="resheader">
|
||||||
|
<xsd:complexType>
|
||||||
|
<xsd:sequence>
|
||||||
|
<xsd:element name="value" type="xsd:string" minOccurs="0" msdata:Ordinal="1" />
|
||||||
|
</xsd:sequence>
|
||||||
|
<xsd:attribute name="name" type="xsd:string" use="required" />
|
||||||
|
</xsd:complexType>
|
||||||
|
</xsd:element>
|
||||||
|
</xsd:choice>
|
||||||
|
</xsd:complexType>
|
||||||
|
</xsd:element>
|
||||||
|
</xsd:schema>
|
||||||
|
<resheader name="resmimetype">
|
||||||
|
<value>text/microsoft-resx</value>
|
||||||
|
</resheader>
|
||||||
|
<resheader name="version">
|
||||||
|
<value>1.3</value>
|
||||||
|
</resheader>
|
||||||
|
<resheader name="reader">
|
||||||
|
<value>System.Resources.ResXResourceReader, System.Windows.Forms, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
|
||||||
|
</resheader>
|
||||||
|
<resheader name="writer">
|
||||||
|
<value>System.Resources.ResXResourceWriter, System.Windows.Forms, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
|
||||||
|
</resheader>
|
||||||
|
<data name="imgLogo.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="imgLogo.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblName.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblName.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblName2.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblName2.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblVersion.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblVersion.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblCopyright.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblCopyright.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblBuiltFor.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblBuiltFor.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblLicense.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblLicense.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblPleaseVisitUs.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblPleaseVisitUs.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblURL.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblURL.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="bbtnOk.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="bbtnOk.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="$this.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="$this.Language" type="System.Globalization.CultureInfo, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>(Default)</value>
|
||||||
|
</data>
|
||||||
|
<data name="$this.TrayLargeIcon" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="$this.Localizable" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="$this.GridSize" type="System.Drawing.Size, System.Drawing, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a">
|
||||||
|
<value>8, 8</value>
|
||||||
|
</data>
|
||||||
|
<data name="$this.DrawGrid" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>True</value>
|
||||||
|
</data>
|
||||||
|
<data name="$this.TrayHeight" type="System.Int32, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>80</value>
|
||||||
|
</data>
|
||||||
|
<data name="$this.SnapToGrid" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>True</value>
|
||||||
|
</data>
|
||||||
|
</root>
|
|
@ -0,0 +1,332 @@
|
||||||
|
unit IdAboutDotNET;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
System.Drawing, System.Collections, System.ComponentModel,
|
||||||
|
System.Windows.Forms, System.Data;
|
||||||
|
|
||||||
|
type
|
||||||
|
TfrmAbout = class(System.Windows.Forms.Form)
|
||||||
|
{$REGION 'Designer Managed Code'}
|
||||||
|
strict private
|
||||||
|
/// <summary>
|
||||||
|
/// Required designer variable.
|
||||||
|
/// </summary>
|
||||||
|
Components: System.ComponentModel.Container;
|
||||||
|
imgLogo: System.Windows.Forms.PictureBox;
|
||||||
|
bbtnOk: System.Windows.Forms.Button;
|
||||||
|
lblName: System.Windows.Forms.Label;
|
||||||
|
lblName2: System.Windows.Forms.Label;
|
||||||
|
lblVersion: System.Windows.Forms.Label;
|
||||||
|
lblCopyright: System.Windows.Forms.Label;
|
||||||
|
lblBuiltFor: System.Windows.Forms.Label;
|
||||||
|
lblLicense: System.Windows.Forms.Label;
|
||||||
|
lblPleaseVisitUs: System.Windows.Forms.Label;
|
||||||
|
lblURL: System.Windows.Forms.LinkLabel;
|
||||||
|
/// <summary>
|
||||||
|
/// Required method for Designer support - do not modify
|
||||||
|
/// the contents of this method with the code editor.
|
||||||
|
/// </summary>
|
||||||
|
procedure InitializeComponent;
|
||||||
|
procedure lblURL_LinkClicked(sender: System.Object; e: System.Windows.Forms.LinkLabelLinkClickedEventArgs);
|
||||||
|
{$ENDREGION}
|
||||||
|
strict protected
|
||||||
|
/// <summary>
|
||||||
|
/// Clean up any resources being used.
|
||||||
|
/// </summary>
|
||||||
|
procedure Dispose(Disposing: Boolean); override;
|
||||||
|
protected
|
||||||
|
{ Private Declarations }
|
||||||
|
function GetProductName: string;
|
||||||
|
procedure SetProductName(const AValue: string);
|
||||||
|
function GetProductName2: string;
|
||||||
|
procedure SetProductName2(const AValue: string);
|
||||||
|
function GetVersion: string;
|
||||||
|
procedure SetVersion(const AValue: string);
|
||||||
|
function LoadBitmap(AResName: string): Bitmap;
|
||||||
|
public
|
||||||
|
constructor Create;
|
||||||
|
//we have a method for providing a product name and version in case
|
||||||
|
//we ever want to make another product.
|
||||||
|
class Procedure ShowAboutBox(const AProductName, AProductName2, AProductVersion : String);
|
||||||
|
class Procedure ShowDlg;
|
||||||
|
property ProductName : String read GetProductName write SetProductName;
|
||||||
|
property ProductName2 : String read GetProductName2 write SetProductName2;
|
||||||
|
property Version : String read GetVersion write SetVersion;
|
||||||
|
|
||||||
|
end;
|
||||||
|
|
||||||
|
[assembly: RuntimeRequiredAttribute(TypeOf(TfrmAbout))]
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
IdDsnCoreResourceStrings, System.Diagnostics,
|
||||||
|
IdGlobal, System.Reflection, System.Resources, SysUtils;
|
||||||
|
|
||||||
|
const
|
||||||
|
ResourceBaseName = 'IdAboutNET';
|
||||||
|
{$R 'AboutIndyNET.resources'}
|
||||||
|
|
||||||
|
{$AUTOBOX ON}
|
||||||
|
|
||||||
|
{$REGION 'Windows Form Designer generated code'}
|
||||||
|
/// <summary>
|
||||||
|
/// Required method for Designer support -- do not modify
|
||||||
|
/// the contents of this method with the code editor.
|
||||||
|
/// </summary>
|
||||||
|
procedure TfrmAbout.InitializeComponent;
|
||||||
|
begin
|
||||||
|
Self.imgLogo := System.Windows.Forms.PictureBox.Create;
|
||||||
|
Self.bbtnOk := System.Windows.Forms.Button.Create;
|
||||||
|
Self.lblName := System.Windows.Forms.Label.Create;
|
||||||
|
Self.lblName2 := System.Windows.Forms.Label.Create;
|
||||||
|
Self.lblVersion := System.Windows.Forms.Label.Create;
|
||||||
|
Self.lblCopyright := System.Windows.Forms.Label.Create;
|
||||||
|
Self.lblBuiltFor := System.Windows.Forms.Label.Create;
|
||||||
|
Self.lblLicense := System.Windows.Forms.Label.Create;
|
||||||
|
Self.lblPleaseVisitUs := System.Windows.Forms.Label.Create;
|
||||||
|
Self.lblURL := System.Windows.Forms.LinkLabel.Create;
|
||||||
|
Self.SuspendLayout;
|
||||||
|
//
|
||||||
|
// imgLogo
|
||||||
|
//
|
||||||
|
Self.imgLogo.Location := System.Drawing.Point.Create(0, 0);
|
||||||
|
Self.imgLogo.Name := 'imgLogo';
|
||||||
|
Self.imgLogo.Size := System.Drawing.Size.Create(388, 240);
|
||||||
|
Self.imgLogo.TabIndex := 0;
|
||||||
|
Self.imgLogo.TabStop := False;
|
||||||
|
//
|
||||||
|
// bbtnOk
|
||||||
|
//
|
||||||
|
Self.bbtnOk.Anchor := (System.Windows.Forms.AnchorStyles((System.Windows.Forms.AnchorStyles.Bottom
|
||||||
|
or System.Windows.Forms.AnchorStyles.Right)));
|
||||||
|
Self.bbtnOk.DialogResult := System.Windows.Forms.DialogResult.Cancel;
|
||||||
|
Self.bbtnOk.Location := System.Drawing.Point.Create(475, 302);
|
||||||
|
Self.bbtnOk.Name := 'bbtnOk';
|
||||||
|
Self.bbtnOk.TabIndex := 0;
|
||||||
|
Self.bbtnOk.Text := 'Button1';
|
||||||
|
//
|
||||||
|
// lblName
|
||||||
|
//
|
||||||
|
Self.lblName.Font := System.Drawing.Font.Create('Arial Black', 14.25, System.Drawing.FontStyle.Regular,
|
||||||
|
System.Drawing.GraphicsUnit.Point, (Byte(0)));
|
||||||
|
Self.lblName.Location := System.Drawing.Point.Create(51, 28);
|
||||||
|
Self.lblName.Name := 'lblName';
|
||||||
|
Self.lblName.Size := System.Drawing.Size.Create(200, 101);
|
||||||
|
Self.lblName.TabIndex := 1;
|
||||||
|
Self.lblName.Text := 'Label1';
|
||||||
|
Self.lblName.TextAlign := System.Drawing.ContentAlignment.TopCenter;
|
||||||
|
//
|
||||||
|
// lblName2
|
||||||
|
//
|
||||||
|
Self.lblName.Font := System.Drawing.Font.Create('Arial', 14.25, System.Drawing.FontStyle.Regular,
|
||||||
|
System.Drawing.GraphicsUnit.Point, (Byte(0)));
|
||||||
|
Self.lblName.Location := System.Drawing.Point.Create(54, 110);
|
||||||
|
Self.lblName.Name := 'lblName';
|
||||||
|
Self.lblName.Size := System.Drawing.Size.Create(192, 35);
|
||||||
|
Self.lblName.TabIndex := 2;
|
||||||
|
Self.lblName.Text := 'Label2';
|
||||||
|
Self.lblName.TextAlign := System.Drawing.ContentAlignment.TopCenter;
|
||||||
|
//
|
||||||
|
// lblVersion
|
||||||
|
//
|
||||||
|
Self.lblVersion.Font := System.Drawing.Font.Create('Arial', 14.25,
|
||||||
|
System.Drawing.FontStyle.Bold, System.Drawing.GraphicsUnit.Point, (Byte(0)));
|
||||||
|
Self.lblVersion.Location := System.Drawing.Point.Create(300, 170);
|
||||||
|
Self.lblVersion.Name := 'lblVersion';
|
||||||
|
Self.lblVersion.Size := System.Drawing.Size.Create(200, 17);
|
||||||
|
Self.lblVersion.TabIndex := 3;
|
||||||
|
Self.lblVersion.Text := 'Label3';
|
||||||
|
Self.lblVersion.TextAlign := System.Drawing.ContentAlignment.TopRight;
|
||||||
|
//
|
||||||
|
// lblCopyright
|
||||||
|
//
|
||||||
|
Self.lblCopyright.Font := System.Drawing.Font.Create('Arial', 14.25,
|
||||||
|
System.Drawing.FontStyle.Regular, System.Drawing.GraphicsUnit.Point, (Byte(0)));
|
||||||
|
Self.lblCopyright.Location := System.Drawing.Point.Create(58, 171);
|
||||||
|
Self.lblCopyright.Name := 'lblCopyright';
|
||||||
|
Self.lblCopyright.Size := System.Drawing.Size.Create(138, 15);
|
||||||
|
Self.lblCopyright.TabIndex := 6;
|
||||||
|
Self.lblCopyright.Text := 'Label6';
|
||||||
|
Self.lblCopyright.TextAlign := System.Drawing.ContentAlignment.TopCenter;
|
||||||
|
//
|
||||||
|
// lblBuiltFor
|
||||||
|
//
|
||||||
|
Self.lblBuiltFor.Anchor := (System.Windows.Forms.AnchorStyles(((System.Windows.Forms.AnchorStyles.Top
|
||||||
|
or System.Windows.Forms.AnchorStyles.Right)));
|
||||||
|
Self.lblBuiltFor.Font := System.Drawing.Font.Create('Arial', 14.25,
|
||||||
|
System.Drawing.FontStyle.Regular, System.Drawing.GraphicsUnit.Point, (Byte(0)));
|
||||||
|
Self.lblBuiltFor.Location := System.Drawing.Point.Create(300, 188);
|
||||||
|
Self.lblBuiltFor.Name := 'lblBuiltFor';
|
||||||
|
Self.lblBuiltFor.Size := System.Drawing.Size.Create(200, 17);
|
||||||
|
Self.lblBuiltFor.TabIndex := 4;
|
||||||
|
Self.lblBuiltFor.Text := 'Label4';
|
||||||
|
Self.lblBuiltFor.TextAlign := System.Drawing.ContentAlignment.TopRight;
|
||||||
|
//
|
||||||
|
// lblLicense
|
||||||
|
//
|
||||||
|
Self.lblLicense.Anchor := (System.Windows.Forms.AnchorStyles(((System.Windows.Forms.AnchorStyles.Top
|
||||||
|
or System.Windows.Forms.AnchorStyles.Right)));
|
||||||
|
Self.lblLicense.Font := System.Drawing.Font.Create('Arial', 14.25,
|
||||||
|
System.Drawing.FontStyle.Regular, System.Drawing.GraphicsUnit.Point, (Byte(0)));
|
||||||
|
Self.lblLicense.Location := System.Drawing.Point.Create(300, 227);
|
||||||
|
Self.lblLicense.Name := 'lblLicense';
|
||||||
|
Self.lblLicense.Size := System.Drawing.Size.Create(200, 45);
|
||||||
|
Self.lblLicense.TabIndex := 5;
|
||||||
|
Self.lblLicense.Text := 'Label5';
|
||||||
|
Self.lblBuiltFor.TextAlign := System.Drawing.ContentAlignment.TopRight;
|
||||||
|
//
|
||||||
|
// lblPleaseVisitUs
|
||||||
|
//
|
||||||
|
Self.lblPleaseVisitUs.Font := System.Drawing.Font.Create('Arial', 14.25,
|
||||||
|
System.Drawing.FontStyle.Regular, System.Drawing.GraphicsUnit.Point, (Byte(0)));
|
||||||
|
Self.lblPleaseVisitUs.Location := System.Drawing.Point.Create(58, 278);
|
||||||
|
Self.lblPleaseVisitUs.Name := 'lblPleaseVisitUs';
|
||||||
|
Self.lblPleaseVisitUs.Size := System.Drawing.Size.Create(276, 15);
|
||||||
|
Self.lblPleaseVisitUs.TabIndex := 7;
|
||||||
|
Self.lblPleaseVisitUs.Text := 'Label7';
|
||||||
|
Self.lblPleaseVisitUs.TextAlign := System.Drawing.ContentAlignment.TopCenter;
|
||||||
|
//
|
||||||
|
// lblURL
|
||||||
|
//
|
||||||
|
Self.lblCopyright.Font := System.Drawing.Font.Create('Arial', 14.25,
|
||||||
|
System.Drawing.FontStyle.Regular, System.Drawing.GraphicsUnit.Point, (Byte(0)));
|
||||||
|
Self.lblURL.Location := System.Drawing.Point.Create(58, 292);
|
||||||
|
Self.lblURL.Name := 'lblURL';
|
||||||
|
Self.lblURL.Size := System.Drawing.Size.Create(141, 15);
|
||||||
|
Self.lblURL.TabIndex := 8;
|
||||||
|
Self.lblURL.TabStop := True;
|
||||||
|
Self.lblURL.Text := 'LinkLabel8';
|
||||||
|
Self.lblURL.TextAlign := System.Drawing.ContentAlignment.TopCenter;
|
||||||
|
Include(Self.lblURL.LinkClicked, Self.lblURL_LinkClicked);
|
||||||
|
//
|
||||||
|
// TfrmAbout
|
||||||
|
//
|
||||||
|
Self.AcceptButton := Self.bbtnOk;
|
||||||
|
Self.AutoScaleBaseSize := System.Drawing.Size.Create(5, 13);
|
||||||
|
Self.CancelButton := Self.bbtnOk;
|
||||||
|
Self.ClientSize := System.Drawing.Size.Create(336, 554);
|
||||||
|
Self.Controls.Add(Self.lblURL);
|
||||||
|
Self.Controls.Add(Self.lblPleaseVisitUs);
|
||||||
|
Self.Controls.Add(Self.lblCopyright);
|
||||||
|
Self.Controls.Add(Self.lblVersion);
|
||||||
|
Self.Controls.Add(Self.lblName);
|
||||||
|
Self.Controls.Add(Self.lblName2);
|
||||||
|
Self.Controls.Add(Self.lblBuiltFor);
|
||||||
|
Self.Controls.Add(Self.lblLicense);
|
||||||
|
Self.Controls.Add(Self.bbtnOk);
|
||||||
|
Self.Controls.Add(Self.imgLogo);
|
||||||
|
Self.FormBorderStyle := System.Windows.Forms.FormBorderStyle.FixedDialog;
|
||||||
|
Self.MaximizeBox := False;
|
||||||
|
Self.MinimizeBox := False;
|
||||||
|
Self.Name := 'TfrmAbout';
|
||||||
|
Self.ShowInTaskbar := False;
|
||||||
|
Self.StartPosition := System.Windows.Forms.FormStartPosition.CenterScreen;
|
||||||
|
Self.Text := 'WinForm';
|
||||||
|
Self.ResumeLayout(False);
|
||||||
|
end;
|
||||||
|
{$ENDREGION}
|
||||||
|
|
||||||
|
procedure TfrmAbout.Dispose(Disposing: Boolean);
|
||||||
|
begin
|
||||||
|
if Disposing then
|
||||||
|
begin
|
||||||
|
if Components <> nil then
|
||||||
|
Components.Dispose();
|
||||||
|
end;
|
||||||
|
inherited Dispose(Disposing);
|
||||||
|
end;
|
||||||
|
|
||||||
|
constructor TfrmAbout.Create;
|
||||||
|
begin
|
||||||
|
inherited Create;
|
||||||
|
//
|
||||||
|
// Required for Windows Form Designer support
|
||||||
|
//
|
||||||
|
InitializeComponent;
|
||||||
|
//
|
||||||
|
// TODO: Add any constructor code after InitializeComponent call
|
||||||
|
//
|
||||||
|
Self.Text := RSAAboutFormCaption;
|
||||||
|
lblName.Text := RSAAboutBoxTitle1;
|
||||||
|
lblName2.Text := RSAAboutBoxTitle2;
|
||||||
|
lblBuiltFor.Text := IndyFormat(RSAAboutBoxBuiltFor, ['DotNET']);
|
||||||
|
lblLicense.Text := RSAAboutBoxLicences;
|
||||||
|
lblCopyright.Text := RSAAboutBoxCopyright;
|
||||||
|
lblPleaseVisitUs.Text := RSAAboutBoxPleaseVisit;
|
||||||
|
lblURL.Text := RSAAboutBoxIndyWebsite;
|
||||||
|
lblURL.Links.Add(0, Length(RSAABoutBoxIndyWebsite), RSAAboutBoxIndyWebsite);
|
||||||
|
bbtnOk.Text := RSOk;
|
||||||
|
imgLogo.Image := LoadBitmap('AboutBackground.bmp');
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TfrmAbout.SetProductName(const AValue : String);
|
||||||
|
begin
|
||||||
|
Self.lblName.Text := AValue;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TfrmAbout.SetProductName2(const AValue : String);
|
||||||
|
begin
|
||||||
|
Self.lblName2.Text := AValue;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TfrmAbout.SetVersion(const AValue: string);
|
||||||
|
begin
|
||||||
|
Self.lblVersion.Text := AValue;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TfrmAbout.GetVersion: string;
|
||||||
|
begin
|
||||||
|
Result := Self.lblVersion.Text;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TfrmAbout.GetProductName: string;
|
||||||
|
begin
|
||||||
|
Result := Self.lblName.Text;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TfrmAbout.GetProductName2: string;
|
||||||
|
begin
|
||||||
|
Result := Self.lblName2.Text;
|
||||||
|
end;
|
||||||
|
|
||||||
|
class procedure TfrmAbout.ShowAboutBox(const AProductName, AProductName2,
|
||||||
|
AProductVersion: String);
|
||||||
|
begin
|
||||||
|
with TfrmAbout.Create do
|
||||||
|
try
|
||||||
|
Version := IndyFormat(RSAAboutBoxVersion, [AProductVersion]);
|
||||||
|
ProductName := AProductName;
|
||||||
|
ProductName2 := AProductName2;
|
||||||
|
Text := AProductName;
|
||||||
|
ShowDialog;
|
||||||
|
finally
|
||||||
|
Dispose;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
class procedure TfrmAbout.ShowDlg;
|
||||||
|
begin
|
||||||
|
ShowAboutBox(RSAAboutBoxTitle1, RSAAboutBoxTitle2, gsIdVersion);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TfrmAbout.lblURL_LinkClicked(sender: System.Object; e: System.Windows.Forms.LinkLabelLinkClickedEventArgs);
|
||||||
|
var
|
||||||
|
LDest : String;
|
||||||
|
begin
|
||||||
|
LDest := e.Link.LinkData as string;
|
||||||
|
System.Diagnostics.Process.Start(LDest);
|
||||||
|
e.Link.Visited := True;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TfrmAbout.LoadBitmap(AResName: string): Bitmap;
|
||||||
|
var
|
||||||
|
LR: System.Resources.ResourceManager;
|
||||||
|
begin
|
||||||
|
LR := System.Resources.ResourceManager.Create('AboutIndyNET', System.Reflection.Assembly.GetExecutingAssembly);
|
||||||
|
Result := (Bitmap(LR.GetObject(AResName)));
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
|
@ -0,0 +1,184 @@
|
||||||
|
<?xml version="1.0" encoding="utf-8"?>
|
||||||
|
<root>
|
||||||
|
<!--
|
||||||
|
Microsoft ResX Schema
|
||||||
|
|
||||||
|
Version 1.3
|
||||||
|
|
||||||
|
The primary goals of this format is to allow a simple XML format
|
||||||
|
that is mostly human readable. The generation and parsing of the
|
||||||
|
various data types are done through the TypeConverter classes
|
||||||
|
associated with the data types.
|
||||||
|
|
||||||
|
Example:
|
||||||
|
|
||||||
|
... ado.net/XML headers & schema ...
|
||||||
|
<resheader name="resmimetype">text/microsoft-resx</resheader>
|
||||||
|
<resheader name="version">1.3</resheader>
|
||||||
|
<resheader name="reader">System.Resources.ResXResourceReader, System.Windows.Forms, ...</resheader>
|
||||||
|
<resheader name="writer">System.Resources.ResXResourceWriter, System.Windows.Forms, ...</resheader>
|
||||||
|
<data name="Name1">this is my long string</data>
|
||||||
|
<data name="Color1" type="System.Drawing.Color, System.Drawing">Blue</data>
|
||||||
|
<data name="Bitmap1" mimetype="application/x-microsoft.net.object.binary.base64">
|
||||||
|
[base64 mime encoded serialized .NET Framework object]
|
||||||
|
</data>
|
||||||
|
<data name="Icon1" type="System.Drawing.Icon, System.Drawing" mimetype="application/x-microsoft.net.object.bytearray.base64">
|
||||||
|
[base64 mime encoded string representing a byte array form of the .NET Framework object]
|
||||||
|
</data>
|
||||||
|
|
||||||
|
There are any number of "resheader" rows that contain simple
|
||||||
|
name/value pairs.
|
||||||
|
|
||||||
|
Each data row contains a name, and value. The row also contains a
|
||||||
|
type or mimetype. Type corresponds to a .NET class that support
|
||||||
|
text/value conversion through the TypeConverter architecture.
|
||||||
|
Classes that don't support this are serialized and stored with the
|
||||||
|
mimetype set.
|
||||||
|
|
||||||
|
The mimetype is used forserialized objects, and tells the
|
||||||
|
ResXResourceReader how to depersist the object. This is currently not
|
||||||
|
extensible. For a given mimetype the value must be set accordingly:
|
||||||
|
|
||||||
|
Note - application/x-microsoft.net.object.binary.base64 is the format
|
||||||
|
that the ResXResourceWriter will generate, however the reader can
|
||||||
|
read any of the formats listed below.
|
||||||
|
|
||||||
|
mimetype: application/x-microsoft.net.object.binary.base64
|
||||||
|
value : The object must be serialized with
|
||||||
|
: System.Serialization.Formatters.Binary.BinaryFormatter
|
||||||
|
: and then encoded with base64 encoding.
|
||||||
|
|
||||||
|
mimetype: application/x-microsoft.net.object.soap.base64
|
||||||
|
value : The object must be serialized with
|
||||||
|
: System.Runtime.Serialization.Formatters.Soap.SoapFormatter
|
||||||
|
: and then encoded with base64 encoding.
|
||||||
|
|
||||||
|
mimetype: application/x-microsoft.net.object.bytearray.base64
|
||||||
|
value : The object must be serialized into a byte array
|
||||||
|
: using a System.ComponentModel.TypeConverter
|
||||||
|
: and then encoded with base64 encoding.
|
||||||
|
-->
|
||||||
|
<xsd:schema id="root" xmlns="" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:msdata="urn:schemas-microsoft-com:xml-msdata">
|
||||||
|
<xsd:element name="root" msdata:IsDataSet="true">
|
||||||
|
<xsd:complexType>
|
||||||
|
<xsd:choice maxOccurs="unbounded">
|
||||||
|
<xsd:element name="data">
|
||||||
|
<xsd:complexType>
|
||||||
|
<xsd:sequence>
|
||||||
|
<xsd:element name="value" type="xsd:string" minOccurs="0" msdata:Ordinal="1" />
|
||||||
|
<xsd:element name="comment" type="xsd:string" minOccurs="0" msdata:Ordinal="2" />
|
||||||
|
</xsd:sequence>
|
||||||
|
<xsd:attribute name="name" type="xsd:string" msdata:Ordinal="1" />
|
||||||
|
<xsd:attribute name="type" type="xsd:string" msdata:Ordinal="3" />
|
||||||
|
<xsd:attribute name="mimetype" type="xsd:string" msdata:Ordinal="4" />
|
||||||
|
</xsd:complexType>
|
||||||
|
</xsd:element>
|
||||||
|
<xsd:element name="resheader">
|
||||||
|
<xsd:complexType>
|
||||||
|
<xsd:sequence>
|
||||||
|
<xsd:element name="value" type="xsd:string" minOccurs="0" msdata:Ordinal="1" />
|
||||||
|
</xsd:sequence>
|
||||||
|
<xsd:attribute name="name" type="xsd:string" use="required" />
|
||||||
|
</xsd:complexType>
|
||||||
|
</xsd:element>
|
||||||
|
</xsd:choice>
|
||||||
|
</xsd:complexType>
|
||||||
|
</xsd:element>
|
||||||
|
</xsd:schema>
|
||||||
|
<resheader name="resmimetype">
|
||||||
|
<value>text/microsoft-resx</value>
|
||||||
|
</resheader>
|
||||||
|
<resheader name="version">
|
||||||
|
<value>1.3</value>
|
||||||
|
</resheader>
|
||||||
|
<resheader name="reader">
|
||||||
|
<value>System.Resources.ResXResourceReader, System.Windows.Forms, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
|
||||||
|
</resheader>
|
||||||
|
<resheader name="writer">
|
||||||
|
<value>System.Resources.ResXResourceWriter, System.Windows.Forms, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
|
||||||
|
</resheader>
|
||||||
|
<data name="imgLogo.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="imgLogo.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="bbtnOk.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="bbtnOk.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblName.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblName.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblName2.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblName2.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblVersion.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblVersion.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblCopyright.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblCopyright.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblBuiltFor.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblBuiltFor.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblLicense.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblLicense.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblPleaseVisitUs.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblPleaseVisitUs.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblURL.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblURL.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="$this.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="$this.Language" type="System.Globalization.CultureInfo, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>(Default)</value>
|
||||||
|
</data>
|
||||||
|
<data name="$this.TrayLargeIcon" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="$this.Localizable" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="$this.GridSize" type="System.Drawing.Size, System.Drawing, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a">
|
||||||
|
<value>8, 8</value>
|
||||||
|
</data>
|
||||||
|
<data name="$this.DrawGrid" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>True</value>
|
||||||
|
</data>
|
||||||
|
<data name="$this.TrayHeight" type="System.Int32, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>80</value>
|
||||||
|
</data>
|
||||||
|
<data name="$this.SnapToGrid" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>True</value>
|
||||||
|
</data>
|
||||||
|
</root>
|
|
@ -0,0 +1,420 @@
|
||||||
|
unit IdAboutVCL;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
{$I IdCompilerDefines.inc}
|
||||||
|
|
||||||
|
uses
|
||||||
|
{$IFDEF WIDGET_KYLIX}
|
||||||
|
QStdCtrls, QForms, QExtCtrls, QControls, QComCtrls, QGraphics, Qt,
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF WIDGET_VCL_LIKE}
|
||||||
|
StdCtrls, Buttons, ExtCtrls, Graphics, Controls, ComCtrls, Forms,
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF HAS_UNIT_Types}
|
||||||
|
Types,
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF WIDGET_LCL}
|
||||||
|
LResources,
|
||||||
|
{$ENDIF}
|
||||||
|
Classes, SysUtils;
|
||||||
|
|
||||||
|
type
|
||||||
|
TfrmAbout = class(TForm)
|
||||||
|
protected
|
||||||
|
FimLogo : TImage;
|
||||||
|
FlblCopyRight : TLabel;
|
||||||
|
FlblName : TLabel;
|
||||||
|
FlblName2 : TLabel;
|
||||||
|
FlblVersion : TLabel;
|
||||||
|
FlblBuiltFor : TLabel;
|
||||||
|
FlblLicense : TLabel;
|
||||||
|
FlblPleaseVisitUs : TLabel;
|
||||||
|
FlblURL : TLabel;
|
||||||
|
//for LCL, we use a TBitBtn to be consistant with some GUI interfaces
|
||||||
|
//and the Lazarus IDE.
|
||||||
|
{$IFDEF USE_TBitBtn}
|
||||||
|
FbbtnOk : TBitBtn;
|
||||||
|
{$ELSE}
|
||||||
|
FbbtnOk : TButton;
|
||||||
|
{$ENDIF}
|
||||||
|
procedure lblURLClick(Sender: TObject);
|
||||||
|
function GetProductName: String;
|
||||||
|
procedure SetProductName(const AValue: String);
|
||||||
|
function GetProductName2: String;
|
||||||
|
procedure SetProductName2(const AValue: String);
|
||||||
|
function GetVersion: String;
|
||||||
|
procedure SetVersion(const AValue: String);
|
||||||
|
public
|
||||||
|
//we have a method for providing a product name and version in case
|
||||||
|
//we ever want to make another product.
|
||||||
|
class procedure ShowDlg;
|
||||||
|
class procedure ShowAboutBox(const AProductName, AProductName2, AProductVersion: String);
|
||||||
|
constructor Create(AOwner : TComponent); overload; override;
|
||||||
|
constructor Create; reintroduce; overload;
|
||||||
|
property ProductName : String read GetProductName write SetProductName;
|
||||||
|
property ProductName2 : String read GetProductName2 write SetProductName2;
|
||||||
|
property Version : String read GetVersion write SetVersion;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
{$IFNDEF WIDGET_LCL}
|
||||||
|
{$IFDEF WIN32_OR_WIN64}
|
||||||
|
{$R IdAboutVCL.RES}
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF KYLIX}
|
||||||
|
{$R IdAboutVCL.RES}
|
||||||
|
{$ENDIF}
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
uses
|
||||||
|
{$IFDEF WIN32_OR_WIN64}ShellApi, {$ENDIF}
|
||||||
|
{$IFNDEF WIDGET_LCL}
|
||||||
|
//done this way because we reference HInstance in Delphi for loading
|
||||||
|
//resources. Lazarus does something different.
|
||||||
|
{$IFDEF WIN32_OR_WIN64}
|
||||||
|
Windows,
|
||||||
|
{$ENDIF}
|
||||||
|
{$ENDIF}
|
||||||
|
IdDsnCoreResourceStrings,
|
||||||
|
IdGlobal;
|
||||||
|
|
||||||
|
{$IFNDEF WIDGET_LCL}
|
||||||
|
function RGBToColor(R, G, B: Byte): TColor;
|
||||||
|
begin
|
||||||
|
Result := RGB(R, G, B);
|
||||||
|
end;
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
{ TfrmAbout }
|
||||||
|
|
||||||
|
constructor TfrmAbout.Create(AOwner: TComponent);
|
||||||
|
begin
|
||||||
|
inherited CreateNew(AOwner,0);
|
||||||
|
|
||||||
|
FimLogo := TImage.Create(Self);
|
||||||
|
FlblCopyRight := TLabel.Create(Self);
|
||||||
|
FlblName := TLabel.Create(Self);
|
||||||
|
FlblName2 := TLabel.Create(Self);
|
||||||
|
FlblVersion := TLabel.Create(Self);
|
||||||
|
FlblBuiltFor := TLabel.Create(Self);
|
||||||
|
FlblLicense := TLabel.Create(Self);
|
||||||
|
FlblPleaseVisitUs := TLabel.Create(Self);
|
||||||
|
FlblURL := TLabel.Create(Self);
|
||||||
|
{$IFDEF USE_TBitBtn}
|
||||||
|
FbbtnOk := TBitBtn.Create(Self);
|
||||||
|
{$ELSE}
|
||||||
|
FbbtnOk := TButton.Create(Self);
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
Name := 'formAbout';
|
||||||
|
Left := 0;
|
||||||
|
Top := 0;
|
||||||
|
Anchors := [];//[akLeft, akTop, akRight,akBottom];
|
||||||
|
BorderIcons := [biSystemMenu];
|
||||||
|
BorderStyle := bsDialog;
|
||||||
|
|
||||||
|
Caption := RSAAboutFormCaption;
|
||||||
|
ClientHeight := 336;
|
||||||
|
ClientWidth := 554;
|
||||||
|
Color := 2520226; // RGBToColor(38, 116, 162)
|
||||||
|
|
||||||
|
Font.Color := 16776138; // RGBToColor(202, 251, 255)
|
||||||
|
Font.Height := -12;
|
||||||
|
Font.Size := 9;
|
||||||
|
Font.Name := 'Arial';
|
||||||
|
Font.Style := [];
|
||||||
|
Position := poScreenCenter;
|
||||||
|
{$IFDEF WIDGET_VCL}
|
||||||
|
Scaled := True;
|
||||||
|
{$ENDIF}
|
||||||
|
Constraints.MinHeight := Height;
|
||||||
|
Constraints.MinWidth := Width;
|
||||||
|
// PixelsPerInch := 96;
|
||||||
|
|
||||||
|
FimLogo.Name := 'imLogo';
|
||||||
|
FimLogo.Parent := Self;
|
||||||
|
FimLogo.Left := 0;
|
||||||
|
FimLogo.Top := 0;
|
||||||
|
FimLogo.Width := 388;
|
||||||
|
FimLogo.Height := 240;
|
||||||
|
|
||||||
|
{$IFDEF WIDGET_LCL}
|
||||||
|
FimLogo.Picture.Pixmap.LoadFromLazarusResource('IndyAboutBkgnd'); //this is XPM format, so Pixmap is used
|
||||||
|
FimLogo.Align := alClient;
|
||||||
|
FimLogo.Stretch := True;
|
||||||
|
{$ELSE} // Because Lazarus is also WIDGET_VCL_LIKE_OR_KYLIX
|
||||||
|
{$IFDEF WIDGET_VCL_LIKE_OR_KYLIX}
|
||||||
|
FimLogo.Picture.Bitmap.LoadFromResourceName(HInstance, 'INDY_ABOUT_BACKGROUND'); {Do not Localize}
|
||||||
|
FimLogo.Align := alClient;
|
||||||
|
FimLogo.Stretch := True;
|
||||||
|
{$ENDIF}
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
FlblName.Name := 'lblName';
|
||||||
|
FlblName.Parent := Self;
|
||||||
|
FlblName.Left := 51;
|
||||||
|
FlblName.Top := 28;
|
||||||
|
FlblName.Width := 200;
|
||||||
|
FlblName.Height := 101;
|
||||||
|
FlblName.Anchors := [akLeft, akTop];
|
||||||
|
{$IFDEF WIDGET_VCL}
|
||||||
|
FlblName.Font.Charset := DEFAULT_CHARSET;
|
||||||
|
FlblName.Transparent := True;
|
||||||
|
{$ENDIF}
|
||||||
|
FlblName.Font.Color := clWhite;
|
||||||
|
FlblName.Font.Height := -72;
|
||||||
|
FlblName.Font.Name := 'Arial Black';
|
||||||
|
FlblName.Font.Style := [];
|
||||||
|
FlblName.ParentFont := False;
|
||||||
|
FlblName.WordWrap := False;
|
||||||
|
FlblName.Caption := RSAAboutBoxTitle1;
|
||||||
|
|
||||||
|
FlblName2.Name := 'lblName2';
|
||||||
|
FlblName2.Parent := Self;
|
||||||
|
FlblName2.Left := 54;
|
||||||
|
FlblName2.Top := 110;
|
||||||
|
FlblName2.Width := 192;
|
||||||
|
FlblName2.Height := 35;
|
||||||
|
FlblName2.Anchors := [akLeft, akTop];
|
||||||
|
{$IFDEF WIDGET_VCL}
|
||||||
|
FlblName2.Font.Charset := DEFAULT_CHARSET;
|
||||||
|
FlblName2.Transparent := True;
|
||||||
|
{$ENDIF}
|
||||||
|
FlblName2.Font.Color := clWhite;
|
||||||
|
FlblName2.Font.Height := -31;
|
||||||
|
FlblName2.Font.Name := 'Arial';
|
||||||
|
FlblName2.Font.Style := [];
|
||||||
|
FlblName2.ParentFont := False;
|
||||||
|
FlblName2.WordWrap := False;
|
||||||
|
FlblName2.Caption := RSAAboutBoxTitle2;
|
||||||
|
|
||||||
|
FlblVersion.Name := 'lblVersion';
|
||||||
|
FlblVersion.Parent := Self;
|
||||||
|
FlblVersion.Left := 300;
|
||||||
|
FlblVersion.Top := 170;
|
||||||
|
FlblVersion.Width := 200;
|
||||||
|
FlblVersion.Height := 17;
|
||||||
|
FlblVersion.Alignment := taRightJustify;
|
||||||
|
FlblVersion.AutoSize := False;
|
||||||
|
{$IFDEF WIDGET_VCL}
|
||||||
|
FlblVersion.Font.Charset := DEFAULT_CHARSET;
|
||||||
|
FlblVersion.Transparent := True;
|
||||||
|
{$ENDIF}
|
||||||
|
FlblVersion.Font.Color := 16776138; // RGBToColor(202, 251, 255)
|
||||||
|
FlblVersion.Font.Height := -15;
|
||||||
|
FlblVersion.Font.Name := 'Arial';
|
||||||
|
FlblVersion.Font.Style := [fsBold];
|
||||||
|
FlblVersion.ParentFont := False;
|
||||||
|
FlblVersion.Anchors := [akTop, akRight];
|
||||||
|
|
||||||
|
FlblBuiltFor.Name := 'lblBuiltFor';
|
||||||
|
FlblBuiltFor.Parent := Self;
|
||||||
|
FlblBuiltFor.Left := 300;
|
||||||
|
FlblBuiltFor.Top := 188;
|
||||||
|
FlblBuiltFor.Width := 200;
|
||||||
|
FlblBuiltFor.Height := 17;
|
||||||
|
FlblBuiltFor.Alignment := taRightJustify;
|
||||||
|
FlblBuiltFor.AutoSize := False;
|
||||||
|
{$IFDEF WIDGET_VCL}
|
||||||
|
FlblBuiltFor.Font.Charset := DEFAULT_CHARSET;
|
||||||
|
FlblBuiltFor.Transparent := True;
|
||||||
|
{$ENDIF}
|
||||||
|
FlblBuiltFor.Font.Color := 16776138; // RGBToColor(202, 251, 255)
|
||||||
|
FlblBuiltFor.Font.Height := -14;
|
||||||
|
FlblBuiltFor.Font.Name := 'Arial';
|
||||||
|
FlblBuiltFor.Font.Style := [];
|
||||||
|
FlblBuiltFor.ParentFont := False;
|
||||||
|
FlblBuiltFor.Anchors := [akTop, akRight];
|
||||||
|
|
||||||
|
// RLebeau: not using resouce strings for the product names because:
|
||||||
|
// 1. the names are pretty specific and not likely to change with localization;
|
||||||
|
// 2. we are trying to avoid using IFDEFs in resource units, per Embarcadero's request;
|
||||||
|
// 3. I don't want to create more product-specific resource units unless we really need them;
|
||||||
|
{$IFDEF WIDGET_KYLIX}
|
||||||
|
FlblBuiltFor.Caption := IndyFormat(RSAAboutBoxBuiltFor, ['Kylix']);
|
||||||
|
{$ELSE}
|
||||||
|
{$IFDEF WIDGET_VCL}
|
||||||
|
FlblBuiltFor.Caption := IndyFormat(RSAAboutBoxBuiltFor, ['VCL']);
|
||||||
|
{$ELSE}
|
||||||
|
{$IFDEF WIDGET_LCL}
|
||||||
|
FlblBuiltFor.Caption := IndyFormat(RSAAboutBoxBuiltFor, ['Lazarus']);
|
||||||
|
{$ELSE}
|
||||||
|
FlblBuiltFor.Caption := IndyFormat(RSAAboutBoxBuiltFor, ['Unknown']);
|
||||||
|
{$ENDIF}
|
||||||
|
{$ENDIF}
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
FlblLicense.Name := 'lblLicense';
|
||||||
|
FlblLicense.Parent := Self;
|
||||||
|
FlblLicense.Left := 300;
|
||||||
|
FlblLicense.Top := 227;
|
||||||
|
FlblLicense.Width := 200;
|
||||||
|
FlblLicense.Height := 45;
|
||||||
|
FlblLicense.Alignment := taRightJustify;
|
||||||
|
FlblLicense.AutoSize := False;
|
||||||
|
{$IFDEF WIDGET_VCL}
|
||||||
|
FlblLicense.Font.Charset := DEFAULT_CHARSET;
|
||||||
|
FlblLicense.Transparent := True;
|
||||||
|
{$ENDIF}
|
||||||
|
FlblLicense.Font.Color := 16776138; // RGBToColor(202, 251, 255)
|
||||||
|
FlblLicense.Font.Height := -12;
|
||||||
|
FlblLicense.Font.Name := 'Arial';
|
||||||
|
FlblLicense.Font.Style := [];
|
||||||
|
FlblLicense.ParentFont := False;
|
||||||
|
FlblLicense.WordWrap := True;
|
||||||
|
FlblLicense.Anchors := [akTop, akRight];
|
||||||
|
FlblLicense.Caption := RSAAboutBoxLicences;
|
||||||
|
|
||||||
|
FlblCopyRight.Name := 'lblCopyRight';
|
||||||
|
FlblCopyRight.Parent := Self;
|
||||||
|
FlblCopyRight.Left := 58;
|
||||||
|
FlblCopyRight.Top := 171;
|
||||||
|
FlblCopyRight.Width := 138;
|
||||||
|
FlblCopyRight.Height := 15;
|
||||||
|
FlblCopyRight.Caption := RSAAboutBoxCopyright;
|
||||||
|
{$IFDEF WIDGET_VCL}
|
||||||
|
FlblCopyRight.Font.Charset := DEFAULT_CHARSET;
|
||||||
|
FlblCopyRight.Transparent := True;
|
||||||
|
{$ENDIF}
|
||||||
|
FlblCopyRight.Font.Color := 16776138; // RGBToColor(202, 251, 255)
|
||||||
|
FlblCopyRight.Font.Height := -12;
|
||||||
|
FlblCopyRight.Font.Name := 'Arial';
|
||||||
|
FlblCopyRight.Font.Style := [];
|
||||||
|
FlblCopyRight.ParentFont := False;
|
||||||
|
FlblCopyRight.WordWrap := True;
|
||||||
|
|
||||||
|
FlblPleaseVisitUs.Name := 'lblPleaseVisitUs';
|
||||||
|
FlblPleaseVisitUs.Parent := Self;
|
||||||
|
FlblPleaseVisitUs.Left := 58;
|
||||||
|
FlblPleaseVisitUs.Top := 278;
|
||||||
|
FlblPleaseVisitUs.Width := 276;
|
||||||
|
FlblPleaseVisitUs.Height := 15;
|
||||||
|
{$IFDEF WIDGET_VCL}
|
||||||
|
FlblPleaseVisitUs.Font.Charset := DEFAULT_CHARSET;
|
||||||
|
FlblPleaseVisitUs.Transparent := True;
|
||||||
|
{$ENDIF}
|
||||||
|
FlblPleaseVisitUs.Font.Color := 16776138; // RGBToColor(202, 251, 255)
|
||||||
|
FlblPleaseVisitUs.Font.Height := -12;
|
||||||
|
FlblPleaseVisitUs.Font.Name := 'Arial';
|
||||||
|
FlblPleaseVisitUs.ParentFont := False;
|
||||||
|
FlblPleaseVisitUs.Caption := RSAAboutBoxPleaseVisit;
|
||||||
|
FlblPleaseVisitUs.Anchors := [akLeft, akTop];
|
||||||
|
|
||||||
|
FlblURL.Name := 'lblURL';
|
||||||
|
FlblURL.Left := 58;
|
||||||
|
FlblURL.Top := 292;
|
||||||
|
FlblURL.Width := 141;
|
||||||
|
FlblURL.Height := 15;
|
||||||
|
FlblURL.Cursor := crHandPoint;
|
||||||
|
{$IFDEF WIDGET_VCL}
|
||||||
|
FlblURL.Font.Charset := DEFAULT_CHARSET;
|
||||||
|
FlblURL.Transparent := True;
|
||||||
|
{$ENDIF}
|
||||||
|
FlblURL.Font.Color := 16776138; // RGBToColor(202, 251, 255)
|
||||||
|
FlblURL.Font.Height := -12;
|
||||||
|
FlblURL.Font.Name := 'Arial';
|
||||||
|
FlblURL.ParentFont := False;
|
||||||
|
FlblURL.OnClick := lblURLClick;
|
||||||
|
FlblURL.Caption := RSAAboutBoxIndyWebsite;
|
||||||
|
FlblURL.Anchors := [akLeft, akTop];
|
||||||
|
FlblURL.Parent := Self;
|
||||||
|
|
||||||
|
FbbtnOk.Name := 'bbtnOk';
|
||||||
|
FbbtnOk.Left := 475;
|
||||||
|
{$IFDEF USE_TBitBtn}
|
||||||
|
FbbtnOk.Top := 297;
|
||||||
|
{$ELSE}
|
||||||
|
FbbtnOk.Top := 302;
|
||||||
|
FbbtnOk.Height := 25;
|
||||||
|
{$ENDIF}
|
||||||
|
FbbtnOk.Width := 75;
|
||||||
|
FbbtnOk.Anchors := [akRight, akBottom];
|
||||||
|
{$IFDEF USE_TBitBtn}
|
||||||
|
FbbtnOk.Font.Color := clBlack;
|
||||||
|
FbbtnOk.ParentFont := False;
|
||||||
|
FbbtnOk.Kind := bkOk;
|
||||||
|
{$ELSE}
|
||||||
|
FbbtnOk.Caption := RSOk;
|
||||||
|
{$ENDIF}
|
||||||
|
FbbtnOk.Cancel := True;
|
||||||
|
FbbtnOk.Default := True;
|
||||||
|
FbbtnOk.ModalResult := 1;
|
||||||
|
FbbtnOk.TabOrder := 0;
|
||||||
|
FbbtnOk.Anchors := [akLeft, akTop, akRight];
|
||||||
|
FbbtnOk.Parent := Self;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TfrmAbout.GetVersion: String;
|
||||||
|
begin
|
||||||
|
Result := FlblVersion.Caption;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TfrmAbout.GetProductName: String;
|
||||||
|
begin
|
||||||
|
Result := FlblName.Caption;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TfrmAbout.GetProductName2: String;
|
||||||
|
begin
|
||||||
|
Result := FlblName2.Caption;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TfrmAbout.lblURLClick(Sender: TObject);
|
||||||
|
begin
|
||||||
|
{$IFDEF WIN32_OR_WIN64}
|
||||||
|
ShellAPI.ShellExecute(Handle, nil, PChar(FlblURL.Caption), nil, nil, 0); {Do not Localize}
|
||||||
|
FlblURL.Font.Color := clPurple;
|
||||||
|
{$ENDIF}
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TfrmAbout.SetVersion(const AValue: String);
|
||||||
|
begin
|
||||||
|
FlblVersion.Caption := AValue;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TfrmAbout.SetProductName(const AValue: String);
|
||||||
|
begin
|
||||||
|
FlblName.Caption := AValue;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TfrmAbout.SetProductName2(const AValue: String);
|
||||||
|
begin
|
||||||
|
FlblName2.Caption := AValue;
|
||||||
|
end;
|
||||||
|
|
||||||
|
class procedure TfrmAbout.ShowAboutBox(const AProductName, AProductName2, AProductVersion: String);
|
||||||
|
var
|
||||||
|
LFrm: TfrmAbout;
|
||||||
|
begin
|
||||||
|
LFrm := TfrmAbout.Create;
|
||||||
|
{$IFNDEF USE_OBJECT_ARC}
|
||||||
|
try
|
||||||
|
{$ENDIF}
|
||||||
|
LFrm.Version := IndyFormat(RSAAboutBoxVersion, [AProductVersion]);
|
||||||
|
LFrm.ProductName := AProductName;
|
||||||
|
LFrm.ProductName2 := AProductName2;
|
||||||
|
LFrm.ShowModal;
|
||||||
|
{$IFNDEF USE_OBJECT_ARC}
|
||||||
|
finally
|
||||||
|
LFrm.Free;
|
||||||
|
end;
|
||||||
|
{$ENDIF}
|
||||||
|
end;
|
||||||
|
|
||||||
|
class procedure TfrmAbout.ShowDlg;
|
||||||
|
begin
|
||||||
|
ShowAboutBox(RSAAboutBoxTitle1, RSAAboutBoxTitle2, gsIdVersion);
|
||||||
|
end;
|
||||||
|
|
||||||
|
constructor TfrmAbout.Create;
|
||||||
|
begin
|
||||||
|
Create(nil);
|
||||||
|
end;
|
||||||
|
|
||||||
|
{$IFDEF WIDGET_LCL}
|
||||||
|
initialization
|
||||||
|
{$i IdAboutVCL.lrs}
|
||||||
|
{$ENDIF}
|
||||||
|
end.
|
|
@ -0,0 +1 @@
|
||||||
|
INDY_ABOUT_BACKGROUND BITMAP AboutBackground.bmp
|
|
@ -0,0 +1,161 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.6 2004.02.03 4:16:42 PM czhower
|
||||||
|
For unit name changes.
|
||||||
|
|
||||||
|
Rev 1.5 2004.01.01 3:13:32 PM czhower
|
||||||
|
Updated comment.
|
||||||
|
|
||||||
|
Rev 1.4 2003.12.31 10:30:24 PM czhower
|
||||||
|
Comment update.
|
||||||
|
|
||||||
|
Rev 1.3 2003.12.31 7:25:14 PM czhower
|
||||||
|
Now works in .net
|
||||||
|
|
||||||
|
Rev 1.2 10/4/2003 9:52:08 AM GGrieve
|
||||||
|
add IdCoreGlobal to uses list
|
||||||
|
|
||||||
|
Rev 1.1 2003.10.01 1:12:30 AM czhower
|
||||||
|
.Net
|
||||||
|
|
||||||
|
Rev 1.0 11/13/2002 08:37:36 AM JPMugaas
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdAntiFreeze;
|
||||||
|
|
||||||
|
{
|
||||||
|
NOTE - This unit must NOT appear in any Indy uses clauses. This is a ONE way
|
||||||
|
relationship and is linked in IF the user uses this component. This is done to
|
||||||
|
preserve the isolation from the massive FORMS unit.
|
||||||
|
|
||||||
|
Because it links to Forms:
|
||||||
|
|
||||||
|
- The Application.ProcessMessages cannot be done in IdCoreGlobal as an OS
|
||||||
|
independent function, and thus this unit is allowed to violate the IFDEF
|
||||||
|
restriction.
|
||||||
|
}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
{$I IdCompilerDefines.inc}
|
||||||
|
uses
|
||||||
|
Classes,
|
||||||
|
IdAntiFreezeBase,
|
||||||
|
IdBaseComponent;
|
||||||
|
|
||||||
|
{ Directive needed for C++Builder HPP and OBJ files for this that will force it
|
||||||
|
to be statically compiled into the code }
|
||||||
|
|
||||||
|
{$IFDEF HAS_DIRECTIVE_HPPEMIT_LINKUNIT}
|
||||||
|
{$HPPEMIT LINKUNIT}
|
||||||
|
{$ELSE}
|
||||||
|
{$IFDEF WINDOWS}
|
||||||
|
{$HPPEMIT '#pragma link "IdAntiFreeze"'} {Do not Localize}
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF UNIX}
|
||||||
|
{$HPPEMIT '#pragma link "IdAntiFreeze.o"'} {Do not Localize}
|
||||||
|
{$ENDIF}
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
type
|
||||||
|
{$IFDEF HAS_ComponentPlatformsAttribute}
|
||||||
|
[ComponentPlatformsAttribute(
|
||||||
|
pidWin32
|
||||||
|
{$IFDEF HAS_ComponentPlatformsAttribute_Win32} or pidWin32{$ENDIF}
|
||||||
|
{$IFDEF HAS_ComponentPlatformsAttribute_Win64} or pidWin64{$ENDIF}
|
||||||
|
{$IFDEF HAS_ComponentPlatformsAttribute_OSX32} or pidOSX32{$ENDIF}
|
||||||
|
{$IFDEF HAS_ComponentPlatformsAttribute_iOS_Simulator} or pidiOSSimulator{$ENDIF}
|
||||||
|
{$IFDEF HAS_ComponentPlatformsAttribute_Android} or pidAndroid{$ENDIF}
|
||||||
|
{$IFDEF HAS_ComponentPlatformsAttribute_Linux32} or pidLinux32{$ENDIF}
|
||||||
|
{$IFDEF HAS_ComponentPlatformsAttribute_iOS_Device32} or pidiOSDevice32{$ELSE}
|
||||||
|
{$IFDEF HAS_ComponentPlatformsAttribute_iOS_Device} or pidiOSDevice{$ENDIF}{$ENDIF}
|
||||||
|
{$IFDEF HAS_ComponentPlatformsAttribute_WinNX32} or pidWinNX32{$ENDIF}
|
||||||
|
{$IFDEF HAS_ComponentPlatformsAttribute_Linux64} or pidLinux64{$ENDIF}
|
||||||
|
{$IFDEF HAS_ComponentPlatformsAttribute_WinIoT32} or pidWinIoT32{$ENDIF}
|
||||||
|
{$IFDEF HAS_ComponentPlatformsAttribute_iOS_Device64} or pidiOSDevice64{$ENDIF}
|
||||||
|
)]
|
||||||
|
{$ENDIF}
|
||||||
|
TIdAntiFreeze = class(TIdAntiFreezeBase)
|
||||||
|
public
|
||||||
|
procedure Process; override;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
{$IFDEF WIDGET_KYLIX}
|
||||||
|
QForms,
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF WIDGET_VCL_LIKE}
|
||||||
|
Forms,
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF WINDOWS}
|
||||||
|
{$IFNDEF FMX}
|
||||||
|
Messages,
|
||||||
|
Windows,
|
||||||
|
{$ENDIF}
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF WIDGET_WINFORMS}
|
||||||
|
System.Windows.Forms,
|
||||||
|
{$ENDIF}
|
||||||
|
IdGlobal;
|
||||||
|
|
||||||
|
{$IFDEF UNIX}
|
||||||
|
procedure TIdAntiFreeze.Process;
|
||||||
|
begin
|
||||||
|
//TODO: Handle ApplicationHasPriority
|
||||||
|
Application.ProcessMessages;
|
||||||
|
end;
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
{$IFDEF WINDOWS}
|
||||||
|
|
||||||
|
{$IFNDEF FMX}
|
||||||
|
procedure TIdAntiFreeze.Process;
|
||||||
|
var
|
||||||
|
LMsg: TMsg;
|
||||||
|
begin
|
||||||
|
if ApplicationHasPriority then begin
|
||||||
|
Application.ProcessMessages;
|
||||||
|
end else begin
|
||||||
|
// This guarantees it will not ever call Application.Idle
|
||||||
|
if PeekMessage(LMsg, 0, 0, 0, PM_NOREMOVE) then begin
|
||||||
|
Application.HandleMessage;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
{$ELSE}
|
||||||
|
procedure TIdAntiFreeze.Process;
|
||||||
|
begin
|
||||||
|
//TODO: Handle ApplicationHasPriority
|
||||||
|
Application.ProcessMessages;
|
||||||
|
end;
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
{$IFDEF WIDGET_WINFORMS}
|
||||||
|
procedure TIdAntiFreeze.Process;
|
||||||
|
begin
|
||||||
|
//TODO: Handle ApplicationHasPriority
|
||||||
|
Application.DoEvents;
|
||||||
|
end;
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
end.
|
|
@ -0,0 +1,305 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.18 2/8/05 5:24:48 PM RLebeau
|
||||||
|
Updated Disconnect() to not wait for the listening thread to terminate until
|
||||||
|
after the inherited Disconnect() is called, so that the socket is actually
|
||||||
|
disconnected and the thread can terminate properly.
|
||||||
|
|
||||||
|
Rev 1.17 2/1/05 12:38:30 AM RLebeau
|
||||||
|
Removed unused CommandHandlersEnabled property
|
||||||
|
|
||||||
|
Rev 1.16 6/11/2004 8:48:16 AM DSiders
|
||||||
|
Added "Do not Localize" comments.
|
||||||
|
|
||||||
|
Rev 1.15 5/18/04 9:12:26 AM RLebeau
|
||||||
|
Bug fix for SetExceptionReply() property setter
|
||||||
|
|
||||||
|
Rev 1.14 5/16/04 5:18:04 PM RLebeau
|
||||||
|
Added setter method to ExceptionReply property
|
||||||
|
|
||||||
|
Rev 1.13 5/10/2004 6:10:38 PM DSiders
|
||||||
|
Removed unused member var FCommandHandlersInitialized.
|
||||||
|
|
||||||
|
Rev 1.12 2004.03.06 1:33:00 PM czhower
|
||||||
|
-Change to disconnect
|
||||||
|
-Addition of DisconnectNotifyPeer
|
||||||
|
-WriteHeader now write bufers
|
||||||
|
|
||||||
|
Rev 1.11 2004.03.01 5:12:24 PM czhower
|
||||||
|
-Bug fix for shutdown of servers when connections still existed (AV)
|
||||||
|
-Implicit HELP support in CMDserver
|
||||||
|
-Several command handler bugs
|
||||||
|
-Additional command handler functionality.
|
||||||
|
|
||||||
|
Rev 1.10 2004.02.03 4:17:10 PM czhower
|
||||||
|
For unit name changes.
|
||||||
|
|
||||||
|
Rev 1.9 2004.01.20 10:03:22 PM czhower
|
||||||
|
InitComponent
|
||||||
|
|
||||||
|
Rev 1.8 1/4/04 8:46:16 PM RLebeau
|
||||||
|
Added OnBeforeCommandHandler and OnAfterCommandHandler events
|
||||||
|
|
||||||
|
Rev 1.7 11/4/2003 10:25:40 PM DSiders
|
||||||
|
Removed duplicate FReplyClass member in TIdCmdTCPClient (See
|
||||||
|
TIdTCPConnection).
|
||||||
|
|
||||||
|
Rev 1.6 10/21/2003 10:54:20 AM JPMugaas
|
||||||
|
Fix for new API change.
|
||||||
|
|
||||||
|
Rev 1.5 2003.10.18 9:33:24 PM czhower
|
||||||
|
Boatload of bug fixes to command handlers.
|
||||||
|
|
||||||
|
Rev 1.4 2003.10.02 10:16:26 AM czhower
|
||||||
|
.Net
|
||||||
|
|
||||||
|
Rev 1.3 2003.09.19 11:54:26 AM czhower
|
||||||
|
-Completed more features necessary for servers
|
||||||
|
-Fixed some bugs
|
||||||
|
|
||||||
|
Rev 1.2 7/9/2003 10:55:24 PM BGooijen
|
||||||
|
Restored all features
|
||||||
|
|
||||||
|
Rev 1.1 7/9/2003 04:36:06 PM JPMugaas
|
||||||
|
You now can override the TIdReply with your own type. This should illiminate
|
||||||
|
some warnings about some serious issues. TIdReply is ONLY a base class with
|
||||||
|
virtual methods.
|
||||||
|
|
||||||
|
Rev 1.0 7/7/2003 7:06:40 PM SPerry
|
||||||
|
Component that uses command handlers
|
||||||
|
|
||||||
|
Rev 1.0 7/6/2003 4:47:26 PM SPerry
|
||||||
|
Units that use Command handlers
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdCmdTCPClient;
|
||||||
|
|
||||||
|
{
|
||||||
|
Original author: Sergio Perry
|
||||||
|
Description: TCP client that uses CommandHandlers
|
||||||
|
}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
{$I IdCompilerDefines.inc}
|
||||||
|
|
||||||
|
uses
|
||||||
|
IdContext,
|
||||||
|
IdException,
|
||||||
|
IdGlobal,
|
||||||
|
IdReply,
|
||||||
|
IdResourceStringsCore,
|
||||||
|
IdThread,
|
||||||
|
IdTCPClient,
|
||||||
|
IdCommandHandlers;
|
||||||
|
|
||||||
|
type
|
||||||
|
TIdCmdTCPClient = class;
|
||||||
|
|
||||||
|
{ Events }
|
||||||
|
TIdCmdTCPClientAfterCommandHandlerEvent = procedure(ASender: TIdCmdTCPClient;
|
||||||
|
AContext: TIdContext) of object;
|
||||||
|
TIdCmdTCPClientBeforeCommandHandlerEvent = procedure(ASender: TIdCmdTCPClient;
|
||||||
|
var AData: string; AContext: TIdContext) of object;
|
||||||
|
|
||||||
|
{ Listening Thread }
|
||||||
|
|
||||||
|
TIdCmdClientContext = class(TIdContext)
|
||||||
|
protected
|
||||||
|
FClient: TIdCmdTCPClient;
|
||||||
|
public
|
||||||
|
property Client: TIdCmdTCPClient read FClient;
|
||||||
|
end;
|
||||||
|
|
||||||
|
TIdCmdTCPClientListeningThread = class(TIdThread)
|
||||||
|
protected
|
||||||
|
FContext: TIdCmdClientContext;
|
||||||
|
FClient: TIdCmdTCPClient;
|
||||||
|
FRecvData: String;
|
||||||
|
//
|
||||||
|
procedure Run; override;
|
||||||
|
public
|
||||||
|
constructor Create(AClient: TIdCmdTCPClient); reintroduce;
|
||||||
|
destructor Destroy; override;
|
||||||
|
//
|
||||||
|
property Client: TIdCmdTCPClient read FClient;
|
||||||
|
property RecvData: String read FRecvData write FRecvData;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TIdCmdTCPClient }
|
||||||
|
TIdCmdTCPClient = class(TIdTCPClient)
|
||||||
|
protected
|
||||||
|
FExceptionReply: TIdReply;
|
||||||
|
FListeningThread: TIdCmdTCPClientListeningThread;
|
||||||
|
FCommandHandlers: TIdCommandHandlers;
|
||||||
|
FOnAfterCommandHandler: TIdCmdTCPClientAfterCommandHandlerEvent;
|
||||||
|
FOnBeforeCommandHandler: TIdCmdTCPClientBeforeCommandHandlerEvent;
|
||||||
|
//
|
||||||
|
procedure DoAfterCommandHandler(ASender: TIdCommandHandlers; AContext: TIdContext);
|
||||||
|
procedure DoBeforeCommandHandler(ASender: TIdCommandHandlers; var AData: string;
|
||||||
|
AContext: TIdContext);
|
||||||
|
procedure DoReplyUnknownCommand(AContext: TIdContext; ALine: string); virtual;
|
||||||
|
function GetCmdHandlerClass: TIdCommandHandlerClass; virtual;
|
||||||
|
procedure InitComponent; override;
|
||||||
|
procedure SetCommandHandlers(AValue: TIdCommandHandlers);
|
||||||
|
procedure SetExceptionReply(AValue: TIdReply);
|
||||||
|
public
|
||||||
|
procedure Connect; override;
|
||||||
|
destructor Destroy; override;
|
||||||
|
procedure Disconnect(ANotifyPeer: Boolean); override;
|
||||||
|
published
|
||||||
|
property CommandHandlers: TIdCommandHandlers read FCommandHandlers write SetCommandHandlers;
|
||||||
|
property ExceptionReply: TIdReply read FExceptionReply write SetExceptionReply;
|
||||||
|
//
|
||||||
|
property OnAfterCommandHandler: TIdCmdTCPClientAfterCommandHandlerEvent
|
||||||
|
read FOnAfterCommandHandler write FOnAfterCommandHandler;
|
||||||
|
property OnBeforeCommandHandler: TIdCmdTCPClientBeforeCommandHandlerEvent
|
||||||
|
read FOnBeforeCommandHandler write FOnBeforeCommandHandler;
|
||||||
|
end;
|
||||||
|
|
||||||
|
EIdCmdTCPClientError = class(EIdException);
|
||||||
|
EIdCmdTCPClientConnectError = class(EIdCmdTCPClientError);
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
IdReplyRFC, SysUtils;
|
||||||
|
|
||||||
|
type
|
||||||
|
TIdCmdClientContextAccess = class(TIdCmdClientContext)
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ Listening Thread }
|
||||||
|
|
||||||
|
constructor TIdCmdTCPClientListeningThread.Create(AClient: TIdCmdTCPClient);
|
||||||
|
begin
|
||||||
|
FClient := AClient;
|
||||||
|
FContext := TIdCmdClientContext.Create(AClient, nil, nil);
|
||||||
|
FContext.FClient := AClient;
|
||||||
|
TIdCmdClientContextAccess(FContext).FOwnsConnection := False;
|
||||||
|
//
|
||||||
|
inherited Create(False);
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TIdCmdTCPClientListeningThread.Destroy;
|
||||||
|
begin
|
||||||
|
inherited Destroy;
|
||||||
|
FreeAndNil(FContext);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCmdTCPClientListeningThread.Run;
|
||||||
|
begin
|
||||||
|
FRecvData := FClient.IOHandler.ReadLn;
|
||||||
|
if not FClient.CommandHandlers.HandleCommand(FContext, FRecvData) then begin
|
||||||
|
FClient.DoReplyUnknownCommand(FContext, FRecvData);
|
||||||
|
end;
|
||||||
|
//Synchronize(?);
|
||||||
|
if not Terminated then begin
|
||||||
|
FClient.IOHandler.CheckForDisconnect;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TIdCmdTCPClient }
|
||||||
|
|
||||||
|
destructor TIdCmdTCPClient.Destroy;
|
||||||
|
begin
|
||||||
|
Disconnect;
|
||||||
|
FreeAndNil(FExceptionReply);
|
||||||
|
FreeAndNil(FCommandHandlers);
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCmdTCPClient.Connect;
|
||||||
|
begin
|
||||||
|
inherited Connect;
|
||||||
|
//
|
||||||
|
try
|
||||||
|
FListeningThread := TIdCmdTCPClientListeningThread.Create(Self);
|
||||||
|
except
|
||||||
|
Disconnect(True);
|
||||||
|
IndyRaiseOuterException(EIdCmdTCPClientConnectError.Create(RSNoCreateListeningThread));
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCmdTCPClient.Disconnect(ANotifyPeer: Boolean);
|
||||||
|
begin
|
||||||
|
if Assigned(FListeningThread) then begin
|
||||||
|
FListeningThread.Terminate;
|
||||||
|
end;
|
||||||
|
try
|
||||||
|
inherited Disconnect(ANotifyPeer);
|
||||||
|
finally
|
||||||
|
if Assigned(FListeningThread) and not IsCurrentThread(FListeningThread) then begin
|
||||||
|
FListeningThread.WaitFor;
|
||||||
|
FreeAndNil(FListeningThread);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCmdTCPClient.DoAfterCommandHandler(ASender: TIdCommandHandlers;
|
||||||
|
AContext: TIdContext);
|
||||||
|
begin
|
||||||
|
if Assigned(OnAfterCommandHandler) then begin
|
||||||
|
OnAfterCommandHandler(Self, AContext);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCmdTCPClient.DoBeforeCommandHandler(ASender: TIdCommandHandlers;
|
||||||
|
var AData: string; AContext: TIdContext);
|
||||||
|
begin
|
||||||
|
if Assigned(OnBeforeCommandHandler) then begin
|
||||||
|
OnBeforeCommandHandler(Self, AData, AContext);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCmdTCPClient.DoReplyUnknownCommand(AContext: TIdContext; ALine: string);
|
||||||
|
begin
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdCmdTCPClient.GetCmdHandlerClass: TIdCommandHandlerClass;
|
||||||
|
begin
|
||||||
|
Result := TIdCommandHandler;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCmdTCPClient.InitComponent;
|
||||||
|
var
|
||||||
|
LHandlerClass: TIdCommandHandlerClass;
|
||||||
|
begin
|
||||||
|
inherited InitComponent;
|
||||||
|
|
||||||
|
FExceptionReply := FReplyClass.Create(nil);
|
||||||
|
ExceptionReply.SetReply(500, 'Unknown Internal Error'); {do not localize}
|
||||||
|
|
||||||
|
LHandlerClass := GetCmdHandlerClass;
|
||||||
|
FCommandHandlers := TIdCommandHandlers.Create(Self, FReplyClass, nil, ExceptionReply, LHandlerClass);
|
||||||
|
FCommandHandlers.OnAfterCommandHandler := DoAfterCommandHandler;
|
||||||
|
FCommandHandlers.OnBeforeCommandHandler := DoBeforeCommandHandler;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCmdTCPClient.SetCommandHandlers(AValue: TIdCommandHandlers);
|
||||||
|
begin
|
||||||
|
FCommandHandlers.Assign(AValue);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCmdTCPClient.SetExceptionReply(AValue: TIdReply);
|
||||||
|
begin
|
||||||
|
FExceptionReply.Assign(AValue);
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
|
@ -0,0 +1,535 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.42 2/1/05 12:36:36 AM RLebeau
|
||||||
|
Removed CommandHandlersEnabled property, no longer used
|
||||||
|
|
||||||
|
Rev 1.41 12/2/2004 9:26:42 PM JPMugaas
|
||||||
|
Bug fix.
|
||||||
|
|
||||||
|
Rev 1.40 2004.10.27 9:20:04 AM czhower
|
||||||
|
For TIdStrings
|
||||||
|
|
||||||
|
Rev 1.39 10/26/2004 8:42:58 PM JPMugaas
|
||||||
|
Should be more portable with new references to TIdStrings and TIdStringList.
|
||||||
|
|
||||||
|
Rev 1.38 6/21/04 10:07:14 PM RLebeau
|
||||||
|
Updated .DoConnect() to make sure the connection is still connected before
|
||||||
|
then sending the Greeting
|
||||||
|
|
||||||
|
Rev 1.37 6/20/2004 12:01:44 AM DSiders
|
||||||
|
Added "Do Not Localize" comments.
|
||||||
|
|
||||||
|
Rev 1.36 6/16/04 12:37:06 PM RLebeau
|
||||||
|
more compiler errors
|
||||||
|
|
||||||
|
Rev 1.35 6/16/04 12:30:32 PM RLebeau
|
||||||
|
compiler errors
|
||||||
|
|
||||||
|
Rev 1.34 6/16/04 12:12:26 PM RLebeau
|
||||||
|
Updated ExceptionReply, Greeting, HelpReply, MaxConnectionReply, and
|
||||||
|
ReplyUnknownCommand properties to use getter methods that call virtual Create
|
||||||
|
methods which descendants can override for class-specific initializations
|
||||||
|
|
||||||
|
Rev 1.33 5/16/04 5:16:52 PM RLebeau
|
||||||
|
Added setter methods to ExceptionReply, HelpReply, and ReplyTexts properties
|
||||||
|
|
||||||
|
Rev 1.32 4/19/2004 5:39:58 PM BGooijen
|
||||||
|
Added comment
|
||||||
|
|
||||||
|
Rev 1.31 4/18/2004 11:58:44 PM BGooijen
|
||||||
|
Wasn't thread safe
|
||||||
|
|
||||||
|
Rev 1.30 3/3/2004 4:59:38 AM JPMugaas
|
||||||
|
Updated for new properties.
|
||||||
|
|
||||||
|
Rev 1.29 2004.03.01 5:12:24 PM czhower
|
||||||
|
-Bug fix for shutdown of servers when connections still existed (AV)
|
||||||
|
-Implicit HELP support in CMDserver
|
||||||
|
-Several command handler bugs
|
||||||
|
-Additional command handler functionality.
|
||||||
|
|
||||||
|
Rev 1.28 2004.02.29 9:43:08 PM czhower
|
||||||
|
Added ReadCommandLine.
|
||||||
|
|
||||||
|
Rev 1.27 2004.02.29 8:17:18 PM czhower
|
||||||
|
Minor cosmetic changes to code.
|
||||||
|
|
||||||
|
Rev 1.26 2004.02.03 4:17:08 PM czhower
|
||||||
|
For unit name changes.
|
||||||
|
|
||||||
|
Rev 1.25 03/02/2004 01:49:22 CCostelloe
|
||||||
|
Added DoReplyUnknownCommand to allow TIdIMAP4Server set a correct reply for
|
||||||
|
unknown commands
|
||||||
|
|
||||||
|
Rev 1.24 1/29/04 9:43:16 PM RLebeau
|
||||||
|
Added setter methods to various TIdReply properties
|
||||||
|
|
||||||
|
Rev 1.23 2004.01.20 10:03:22 PM czhower
|
||||||
|
InitComponent
|
||||||
|
|
||||||
|
Rev 1.22 1/5/2004 2:35:36 PM JPMugaas
|
||||||
|
Removed of object in method declarations.
|
||||||
|
|
||||||
|
Rev 1.21 1/5/04 10:12:58 AM RLebeau
|
||||||
|
Fixed Typos in OnBeforeCommandHandler and OnAfterCommandHandler events
|
||||||
|
|
||||||
|
Rev 1.20 1/4/04 8:45:34 PM RLebeau
|
||||||
|
Added OnBeforeCommandHandler and OnAfterCommandHandler events
|
||||||
|
|
||||||
|
Rev 1.19 1/1/2004 9:33:22 PM BGooijen
|
||||||
|
the abstract class TIdReply was created sometimes, fixed that
|
||||||
|
|
||||||
|
Rev 1.18 2003.10.18 9:33:26 PM czhower
|
||||||
|
Boatload of bug fixes to command handlers.
|
||||||
|
|
||||||
|
Rev 1.17 2003.10.18 8:03:58 PM czhower
|
||||||
|
Defaults for codes
|
||||||
|
|
||||||
|
Rev 1.16 8/31/2003 11:49:40 AM BGooijen
|
||||||
|
removed FReplyClass, this was also in TIdTCPServer
|
||||||
|
|
||||||
|
Rev 1.15 7/9/2003 10:55:24 PM BGooijen
|
||||||
|
Restored all features
|
||||||
|
|
||||||
|
Rev 1.14 7/9/2003 04:36:08 PM JPMugaas
|
||||||
|
You now can override the TIdReply with your own type. This should illiminate
|
||||||
|
some warnings about some serious issues. TIdReply is ONLY a base class with
|
||||||
|
virtual methods.
|
||||||
|
|
||||||
|
Rev 1.13 2003.07.08 2:26:02 PM czhower
|
||||||
|
Sergio's update
|
||||||
|
|
||||||
|
Rev 1.0 7/7/2003 7:06:44 PM SPerry
|
||||||
|
Component that uses command handlers
|
||||||
|
|
||||||
|
Rev 1.0 7/6/2003 4:47:32 PM SPerry
|
||||||
|
Units that use Command handlers
|
||||||
|
|
||||||
|
Adapted to IdCommandHandlers.pas SPerry
|
||||||
|
|
||||||
|
Rev 1.7 4/4/2003 8:08:00 PM BGooijen
|
||||||
|
moved some consts from tidtcpserver here
|
||||||
|
|
||||||
|
Rev 1.6 3/23/2003 11:22:24 PM BGooijen
|
||||||
|
Moved some code to HandleCommand
|
||||||
|
|
||||||
|
Rev 1.5 3/22/2003 1:46:36 PM BGooijen
|
||||||
|
Removed unused variables
|
||||||
|
|
||||||
|
Rev 1.4 3/20/2003 12:18:30 PM BGooijen
|
||||||
|
Moved ReplyExceptionCode from TIdTCPServer to TIdCmdTCPServer
|
||||||
|
|
||||||
|
Rev 1.3 3/20/2003 12:14:18 PM BGooijen
|
||||||
|
Re-enabled Server.ReplyException
|
||||||
|
|
||||||
|
Rev 1.2 2/24/2003 07:21:50 PM JPMugaas
|
||||||
|
Now compiles with new core code restructures.
|
||||||
|
|
||||||
|
Rev 1.1 1/23/2003 11:06:10 AM BGooijen
|
||||||
|
|
||||||
|
Rev 1.0 1/20/2003 12:48:40 PM BGooijen
|
||||||
|
Tcpserver with command handlers, these were originally in TIdTcpServer, but
|
||||||
|
are now moved here
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdCmdTCPServer;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
{$I IdCompilerDefines.inc}
|
||||||
|
//Put FPC into Delphi mode
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes,
|
||||||
|
IdCommandHandlers,
|
||||||
|
IdContext,
|
||||||
|
IdIOHandler,
|
||||||
|
IdReply,
|
||||||
|
IdTCPServer,
|
||||||
|
SysUtils;
|
||||||
|
|
||||||
|
type
|
||||||
|
TIdCmdTCPServer = class;
|
||||||
|
|
||||||
|
{ Events }
|
||||||
|
TIdCmdTCPServerAfterCommandHandlerEvent = procedure(ASender: TIdCmdTCPServer;
|
||||||
|
AContext: TIdContext) of object;
|
||||||
|
TIdCmdTCPServerBeforeCommandHandlerEvent = procedure(ASender: TIdCmdTCPServer;
|
||||||
|
var AData: string; AContext: TIdContext) of object;
|
||||||
|
|
||||||
|
TIdCmdTCPServer = class(TIdTCPServer)
|
||||||
|
protected
|
||||||
|
FCommandHandlers: TIdCommandHandlers;
|
||||||
|
FCommandHandlersInitialized: Boolean;
|
||||||
|
FExceptionReply: TIdReply;
|
||||||
|
FHelpReply: TIdReply;
|
||||||
|
FGreeting: TIdReply;
|
||||||
|
FMaxConnectionReply: TIdReply;
|
||||||
|
FOnAfterCommandHandler: TIdCmdTCPServerAfterCommandHandlerEvent;
|
||||||
|
FOnBeforeCommandHandler: TIdCmdTCPServerBeforeCommandHandlerEvent;
|
||||||
|
FReplyClass: TIdReplyClass;
|
||||||
|
FReplyTexts: TIdReplies;
|
||||||
|
FReplyUnknownCommand: TIdReply;
|
||||||
|
//
|
||||||
|
procedure CheckOkToBeActive; override;
|
||||||
|
function CreateExceptionReply: TIdReply; virtual;
|
||||||
|
function CreateGreeting: TIdReply; virtual;
|
||||||
|
function CreateHelpReply: TIdReply; virtual;
|
||||||
|
function CreateMaxConnectionReply: TIdReply; virtual;
|
||||||
|
function CreateReplyUnknownCommand: TIdReply; virtual;
|
||||||
|
procedure DoAfterCommandHandler(ASender: TIdCommandHandlers; AContext: TIdContext);
|
||||||
|
procedure DoBeforeCommandHandler(ASender: TIdCommandHandlers; var AData: string;
|
||||||
|
AContext: TIdContext);
|
||||||
|
procedure DoConnect(AContext: TIdContext); override;
|
||||||
|
function DoExecute(AContext: TIdContext): Boolean; override;
|
||||||
|
procedure DoMaxConnectionsExceeded(AIOHandler: TIdIOHandler); override;
|
||||||
|
// This is here to allow servers to override this functionality, such as IMAP4 server
|
||||||
|
procedure DoReplyUnknownCommand(AContext: TIdContext; ALine: string); virtual;
|
||||||
|
function GetExceptionReply: TIdReply;
|
||||||
|
function GetGreeting: TIdReply;
|
||||||
|
function GetHelpReply: TIdReply;
|
||||||
|
function GetMaxConnectionReply: TIdReply;
|
||||||
|
function GetRepliesClass: TIdRepliesClass; virtual;
|
||||||
|
function GetReplyClass: TIdReplyClass; virtual;
|
||||||
|
function GetReplyUnknownCommand: TIdReply;
|
||||||
|
procedure InitializeCommandHandlers; virtual;
|
||||||
|
procedure InitComponent; override;
|
||||||
|
// This is used by command handlers as the only input. This can be overriden to filter, modify,
|
||||||
|
// or preparse the input.
|
||||||
|
function ReadCommandLine(AContext: TIdContext): string; virtual;
|
||||||
|
procedure Startup; override;
|
||||||
|
procedure SetCommandHandlers(AValue: TIdCommandHandlers);
|
||||||
|
procedure SetExceptionReply(AValue: TIdReply);
|
||||||
|
procedure SetGreeting(AValue: TIdReply);
|
||||||
|
procedure SetHelpReply(AValue: TIdReply);
|
||||||
|
procedure SetMaxConnectionReply(AValue: TIdReply);
|
||||||
|
procedure SetReplyUnknownCommand(AValue: TIdReply);
|
||||||
|
procedure SetReplyTexts(AValue: TIdReplies);
|
||||||
|
public
|
||||||
|
destructor Destroy; override;
|
||||||
|
published
|
||||||
|
property CommandHandlers: TIdCommandHandlers read FCommandHandlers
|
||||||
|
write SetCommandHandlers;
|
||||||
|
property ExceptionReply: TIdReply read GetExceptionReply write SetExceptionReply;
|
||||||
|
property Greeting: TIdReply read GetGreeting write SetGreeting;
|
||||||
|
property HelpReply: TIdReply read GetHelpReply write SetHelpReply;
|
||||||
|
property MaxConnectionReply: TIdReply read GetMaxConnectionReply
|
||||||
|
write SetMaxConnectionReply;
|
||||||
|
property ReplyTexts: TIdReplies read FReplyTexts write SetReplyTexts;
|
||||||
|
property ReplyUnknownCommand: TIdReply read GetReplyUnknownCommand
|
||||||
|
write SetReplyUnknownCommand;
|
||||||
|
//
|
||||||
|
property OnAfterCommandHandler: TIdCmdTCPServerAfterCommandHandlerEvent
|
||||||
|
read FOnAfterCommandHandler write FOnAfterCommandHandler;
|
||||||
|
property OnBeforeCommandHandler: TIdCmdTCPServerBeforeCommandHandlerEvent
|
||||||
|
read FOnBeforeCommandHandler write FOnBeforeCommandHandler;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
IdGlobal,
|
||||||
|
IdResourceStringsCore,
|
||||||
|
IdReplyRFC;
|
||||||
|
|
||||||
|
function TIdCmdTCPServer.GetReplyClass: TIdReplyClass;
|
||||||
|
begin
|
||||||
|
Result := TIdReplyRFC;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdCmdTCPServer.GetRepliesClass: TIdRepliesClass;
|
||||||
|
begin
|
||||||
|
Result := TIdRepliesRFC;
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TIdCmdTCPServer.Destroy;
|
||||||
|
begin
|
||||||
|
inherited Destroy;
|
||||||
|
FreeAndNil(FReplyUnknownCommand);
|
||||||
|
FreeAndNil(FReplyTexts);
|
||||||
|
FreeAndNil(FMaxConnectionReply);
|
||||||
|
FreeAndNil(FHelpReply);
|
||||||
|
FreeAndNil(FGreeting);
|
||||||
|
FreeAndNil(FExceptionReply);
|
||||||
|
FreeAndNil(FCommandHandlers);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCmdTCPServer.DoAfterCommandHandler(ASender: TIdCommandHandlers;
|
||||||
|
AContext: TIdContext);
|
||||||
|
begin
|
||||||
|
if Assigned(OnAfterCommandHandler) then begin
|
||||||
|
OnAfterCommandHandler(Self, AContext);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCmdTCPServer.DoBeforeCommandHandler(ASender: TIdCommandHandlers;
|
||||||
|
var AData: string; AContext: TIdContext);
|
||||||
|
begin
|
||||||
|
if Assigned(OnBeforeCommandHandler) then begin
|
||||||
|
OnBeforeCommandHandler(Self, AData, AContext);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdCmdTCPServer.DoExecute(AContext: TIdContext): Boolean;
|
||||||
|
var
|
||||||
|
LLine: string;
|
||||||
|
begin
|
||||||
|
if CommandHandlers.Count > 0 then begin
|
||||||
|
Result := True;
|
||||||
|
if AContext.Connection.Connected then begin
|
||||||
|
LLine := ReadCommandLine(AContext);
|
||||||
|
// OLX sends blank lines during reset groups (NNTP) and expects no response.
|
||||||
|
// Not sure what the RFCs say about blank lines.
|
||||||
|
// I telnetted to some newsservers, and they dont respond to blank lines.
|
||||||
|
// This unit is core and not NNTP, but we should be consistent.
|
||||||
|
if LLine <> '' then begin
|
||||||
|
if not FCommandHandlers.HandleCommand(AContext, LLine) then begin
|
||||||
|
DoReplyUnknownCommand(AContext, LLine);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end else begin
|
||||||
|
Result := inherited DoExecute(AContext);
|
||||||
|
end;
|
||||||
|
if Result and Assigned(AContext.Connection) then begin
|
||||||
|
Result := AContext.Connection.Connected;
|
||||||
|
end;
|
||||||
|
// the return value is used to determine if the DoExecute needs to be called again by the thread
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCmdTCPServer.DoReplyUnknownCommand(AContext: TIdContext; ALine: string);
|
||||||
|
var
|
||||||
|
LReply: TIdReply;
|
||||||
|
begin
|
||||||
|
if CommandHandlers.PerformReplies then begin
|
||||||
|
LReply := FReplyClass.CreateWithReplyTexts(nil, ReplyTexts); try
|
||||||
|
LReply.Assign(ReplyUnknownCommand);
|
||||||
|
LReply.Text.Add(ALine);
|
||||||
|
AContext.Connection.IOHandler.Write(LReply.FormattedReply);
|
||||||
|
finally
|
||||||
|
FreeAndNil(LReply);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCmdTCPServer.InitializeCommandHandlers;
|
||||||
|
begin
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCmdTCPServer.DoConnect(AContext: TIdContext);
|
||||||
|
var
|
||||||
|
LGreeting: TIdReply;
|
||||||
|
begin
|
||||||
|
inherited DoConnect(AContext);
|
||||||
|
// RLebeau - check the connection first in case the application
|
||||||
|
// chose to disconnect the connection in the OnConnect event handler.
|
||||||
|
if AContext.Connection.Connected then begin
|
||||||
|
if Greeting.ReplyExists then begin
|
||||||
|
ReplyTexts.UpdateText(Greeting);
|
||||||
|
LGreeting := FReplyClass.Create(nil); try // SendGreeting calls TIdReply.GetFormattedReply
|
||||||
|
LGreeting.Assign(Greeting); // and that changes the reply object, so we have to
|
||||||
|
SendGreeting(AContext, LGreeting); // clone it to make it thread-safe
|
||||||
|
finally
|
||||||
|
FreeAndNil(LGreeting);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCmdTCPServer.DoMaxConnectionsExceeded(AIOHandler: TIdIOHandler);
|
||||||
|
begin
|
||||||
|
inherited DoMaxConnectionsExceeded(AIOHandler);
|
||||||
|
//Do not UpdateText here - in thread. Is done in constructor
|
||||||
|
AIOHandler.Write(MaxConnectionReply.FormattedReply);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCmdTCPServer.Startup;
|
||||||
|
var
|
||||||
|
i, j: Integer;
|
||||||
|
LDescr: TStrings;
|
||||||
|
LHelpList: TStringList;
|
||||||
|
LHandler, LAddedHandler: TIdCommandHandler;
|
||||||
|
begin
|
||||||
|
inherited Startup;
|
||||||
|
if not FCommandHandlersInitialized then begin
|
||||||
|
// InitializeCommandHandlers must be called only at runtime, and only after streaming
|
||||||
|
// has occured. This used to be in .Loaded and that worked for forms. It failed
|
||||||
|
// for dynamically created instances and also for descendant classes.
|
||||||
|
FCommandHandlersInitialized := True;
|
||||||
|
InitializeCommandHandlers;
|
||||||
|
if HelpReply.Code <> '' then begin
|
||||||
|
LAddedHandler := CommandHandlers.Add;
|
||||||
|
LAddedHandler.Command := 'Help'; {do not localize}
|
||||||
|
LAddedHandler.Description.Text := 'Displays commands that the servers supports.'; {do not localize}
|
||||||
|
LAddedHandler.NormalReply.Assign(HelpReply);
|
||||||
|
LHelpList := TStringList.Create;
|
||||||
|
try
|
||||||
|
for i := 0 to CommandHandlers.Count - 1 do begin
|
||||||
|
LHandler := CommandHandlers.Items[i];
|
||||||
|
if LHandler.HelpVisible then begin
|
||||||
|
LHelpList.AddObject(LHandler.Command+LHandler.HelpSuperScript, LHandler);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
LHelpList.Sort;
|
||||||
|
for i := 0 to LHelpList.Count - 1 do begin
|
||||||
|
LAddedHandler.Response.Add(LHelpList[i]);
|
||||||
|
LDescr := TIdCommandHandler(LHelpList.Objects[i]).Description;
|
||||||
|
for j := 0 to LDescr.Count - 1 do begin
|
||||||
|
LAddedHandler.Response.Add(' ' + LDescr[j]); {do not localize}
|
||||||
|
end;
|
||||||
|
LAddedHandler.Response.Add(''); {do not localize}
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
FreeAndNil(LHelpList);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCmdTCPServer.SetCommandHandlers(AValue: TIdCommandHandlers);
|
||||||
|
begin
|
||||||
|
FCommandHandlers.Assign(AValue);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdCmdTCPServer.CreateExceptionReply: TIdReply;
|
||||||
|
begin
|
||||||
|
Result := FReplyClass.CreateWithReplyTexts(nil, ReplyTexts);
|
||||||
|
Result.SetReply(500, 'Unknown Internal Error'); {do not localize}
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdCmdTCPServer.GetExceptionReply: TIdReply;
|
||||||
|
begin
|
||||||
|
if FExceptionReply = nil then begin
|
||||||
|
FExceptionReply := CreateExceptionReply;
|
||||||
|
end;
|
||||||
|
Result := FExceptionReply;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCmdTCPServer.SetExceptionReply(AValue: TIdReply);
|
||||||
|
begin
|
||||||
|
ExceptionReply.Assign(AValue);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdCmdTCPServer.CreateGreeting: TIdReply;
|
||||||
|
begin
|
||||||
|
Result := FReplyClass.CreateWithReplyTexts(nil, ReplyTexts);
|
||||||
|
Result.SetReply(200, 'Welcome'); {do not localize}
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdCmdTCPServer.GetGreeting: TIdReply;
|
||||||
|
begin
|
||||||
|
if FGreeting = nil then begin
|
||||||
|
FGreeting := CreateGreeting;
|
||||||
|
end;
|
||||||
|
Result := FGreeting;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCmdTCPServer.SetGreeting(AValue: TIdReply);
|
||||||
|
begin
|
||||||
|
Greeting.Assign(AValue);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdCmdTCPServer.CreateHelpReply: TIdReply;
|
||||||
|
begin
|
||||||
|
Result := FReplyClass.CreateWithReplyTexts(nil, ReplyTexts);
|
||||||
|
Result.SetReply(100, 'Help follows'); {do not localize}
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdCmdTCPServer.GetHelpReply: TIdReply;
|
||||||
|
begin
|
||||||
|
if FHelpReply = nil then begin
|
||||||
|
FHelpReply := CreateHelpReply;
|
||||||
|
end;
|
||||||
|
Result := FHelpReply;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCmdTCPServer.SetHelpReply(AValue: TIdReply);
|
||||||
|
begin
|
||||||
|
HelpReply.Assign(AValue);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdCmdTCPServer.CreateMaxConnectionReply: TIdReply;
|
||||||
|
begin
|
||||||
|
Result := FReplyClass.CreateWithReplyTexts(nil, ReplyTexts);
|
||||||
|
Result.SetReply(300, 'Too many connections. Try again later.'); {do not localize}
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdCmdTCPServer.GetMaxConnectionReply: TIdReply;
|
||||||
|
begin
|
||||||
|
if FMaxConnectionReply = nil then begin
|
||||||
|
FMaxConnectionReply := CreateMaxConnectionReply;
|
||||||
|
end;
|
||||||
|
Result := FMaxConnectionReply;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCmdTCPServer.SetMaxConnectionReply(AValue: TIdReply);
|
||||||
|
begin
|
||||||
|
MaxConnectionReply.Assign(AValue);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdCmdTCPServer.CreateReplyUnknownCommand: TIdReply;
|
||||||
|
begin
|
||||||
|
Result := FReplyClass.CreateWithReplyTexts(nil, ReplyTexts);
|
||||||
|
Result.SetReply(400, 'Unknown Command'); {do not localize}
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdCmdTCPServer.GetReplyUnknownCommand: TIdReply;
|
||||||
|
begin
|
||||||
|
if FReplyUnknownCommand = nil then begin
|
||||||
|
FReplyUnknownCommand := CreateReplyUnknownCommand;
|
||||||
|
end;
|
||||||
|
Result := FReplyUnknownCommand;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCmdTCPServer.SetReplyUnknownCommand(AValue: TIdReply);
|
||||||
|
begin
|
||||||
|
ReplyUnknownCommand.Assign(AValue);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCmdTCPServer.SetReplyTexts(AValue: TIdReplies);
|
||||||
|
begin
|
||||||
|
FReplyTexts.Assign(AValue);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCmdTCPServer.InitComponent;
|
||||||
|
begin
|
||||||
|
inherited InitComponent;
|
||||||
|
FReplyClass := GetReplyClass;
|
||||||
|
|
||||||
|
// Before Command handlers as they need FReplyTexts, but after FReplyClass is set
|
||||||
|
FReplyTexts := GetRepliesClass.Create(Self, FReplyClass);
|
||||||
|
|
||||||
|
FCommandHandlers := TIdCommandHandlers.Create(Self, FReplyClass, ReplyTexts, ExceptionReply);
|
||||||
|
FCommandHandlers.OnAfterCommandHandler := DoAfterCommandHandler;
|
||||||
|
FCommandHandlers.OnBeforeCommandHandler := DoBeforeCommandHandler;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdCmdTCPServer.ReadCommandLine(AContext: TIdContext): string;
|
||||||
|
begin
|
||||||
|
Result := AContext.Connection.IOHandler.ReadLn;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCmdTCPServer.CheckOkToBeActive;
|
||||||
|
begin
|
||||||
|
if (CommandHandlers.Count = 0) and FCommandHandlersInitialized then begin
|
||||||
|
inherited CheckOkToBeActive;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
|
@ -0,0 +1,682 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.36 2/1/05 12:37:48 AM RLebeau
|
||||||
|
Removed IdCommandHandlersEnabledDefault variable, no longer used.
|
||||||
|
|
||||||
|
Rev 1.35 1/3/05 4:43:20 PM RLebeau
|
||||||
|
Changed use of AnsiSameText() to use TextIsSame() instead
|
||||||
|
|
||||||
|
Rev 1.34 12/17/04 12:54:04 PM RLebeau
|
||||||
|
Updated TIdCommandHandler.Check() to not match misspelled commands when a
|
||||||
|
CmdDelimiter is specified.
|
||||||
|
|
||||||
|
Rev 1.33 12/10/04 1:48:04 PM RLebeau
|
||||||
|
Bug fix for TIdCommandHandler.DoCommand()
|
||||||
|
|
||||||
|
Rev 1.32 10/26/2004 8:42:58 PM JPMugaas
|
||||||
|
Should be more portable with new references to TIdStrings and TIdStringList.
|
||||||
|
|
||||||
|
Rev 1.31 6/17/2004 2:19:50 AM JPMugaas
|
||||||
|
Problem with unparsed parameters. The initial deliniator between the command
|
||||||
|
and reply was being added to Unparsed Params leading some strange results and
|
||||||
|
command failures.
|
||||||
|
|
||||||
|
Rev 1.30 6/6/2004 11:44:34 AM JPMugaas
|
||||||
|
Removed a temporary workaround for a Telnet Sequences issue in the
|
||||||
|
TIdFTPServer. That workaround is no longer needed as we fixed the issue
|
||||||
|
another way.
|
||||||
|
|
||||||
|
Rev 1.29 5/16/04 5:20:22 PM RLebeau
|
||||||
|
Removed local variable from TIdCommandHandler constructor, no longer used
|
||||||
|
|
||||||
|
Rev 1.28 2004.03.03 3:19:52 PM czhower
|
||||||
|
sorted
|
||||||
|
|
||||||
|
Rev 1.27 3/3/2004 4:59:40 AM JPMugaas
|
||||||
|
Updated for new properties.
|
||||||
|
|
||||||
|
Rev 1.26 3/2/2004 8:10:36 AM JPMugaas
|
||||||
|
HelpHide renamed to HelpVisable.
|
||||||
|
|
||||||
|
Rev 1.25 3/2/2004 6:37:36 AM JPMugaas
|
||||||
|
Updated with properties for more comprehensive help systems.
|
||||||
|
|
||||||
|
Rev 1.24 2004.03.01 7:13:40 PM czhower
|
||||||
|
Comaptibilty fix.
|
||||||
|
|
||||||
|
Rev 1.23 2004.03.01 5:12:26 PM czhower
|
||||||
|
-Bug fix for shutdown of servers when connections still existed (AV)
|
||||||
|
-Implicit HELP support in CMDserver
|
||||||
|
-Several command handler bugs
|
||||||
|
-Additional command handler functionality.
|
||||||
|
|
||||||
|
Rev 1.22 2004.02.29 9:49:06 PM czhower
|
||||||
|
Bug fix, and now responses are also write buffered.
|
||||||
|
|
||||||
|
Rev 1.21 2004.02.03 4:17:10 PM czhower
|
||||||
|
For unit name changes.
|
||||||
|
|
||||||
|
Rev 1.20 1/29/04 10:00:40 PM RLebeau
|
||||||
|
Added setter methods to various TIdReply properties
|
||||||
|
|
||||||
|
Rev 1.19 2003.12.31 7:31:58 PM czhower
|
||||||
|
AnsiSameText --> TextIsSame
|
||||||
|
|
||||||
|
Rev 1.18 10/19/2003 11:36:52 AM DSiders
|
||||||
|
Added localization comments where setting response codes.
|
||||||
|
|
||||||
|
Rev 1.17 2003.10.18 9:33:26 PM czhower
|
||||||
|
Boatload of bug fixes to command handlers.
|
||||||
|
|
||||||
|
Rev 1.16 2003.10.18 8:07:12 PM czhower
|
||||||
|
Fixed bug with defaults.
|
||||||
|
|
||||||
|
Rev 1.15 2003.10.18 8:03:58 PM czhower
|
||||||
|
Defaults for codes
|
||||||
|
|
||||||
|
Rev 1.14 10/5/2003 03:06:18 AM JPMugaas
|
||||||
|
Should compile.
|
||||||
|
|
||||||
|
Rev 1.13 8/9/2003 3:52:44 PM BGooijen
|
||||||
|
TIdCommandHandlers can now create any TIdCommandHandler descendant. this
|
||||||
|
makes it possible to override TIdCommandHandler.check and check for the
|
||||||
|
command a different way ( binary commands, protocols where the string doesn't
|
||||||
|
start with the command )
|
||||||
|
|
||||||
|
Rev 1.12 8/2/2003 2:22:54 PM SPerry
|
||||||
|
Fixed OnCommandHandlersException problem
|
||||||
|
|
||||||
|
Rev 1.11 8/2/2003 1:43:08 PM SPerry
|
||||||
|
Modifications to get command handlers to work
|
||||||
|
|
||||||
|
Rev 1.9 7/30/2003 10:18:30 PM SPerry
|
||||||
|
Fixed AV when creating commandhandler (again) -- for some reason the bug
|
||||||
|
fixed in Rev. 1.7 was still there.
|
||||||
|
|
||||||
|
Rev 1.8 7/30/2003 8:31:58 PM SPerry
|
||||||
|
Fixed AV with LFReplyClass.
|
||||||
|
|
||||||
|
Rev 1.4 7/9/2003 10:55:26 PM BGooijen
|
||||||
|
Restored all features
|
||||||
|
|
||||||
|
Rev 1.3 7/9/2003 04:36:10 PM JPMugaas
|
||||||
|
You now can override the TIdReply with your own type. This should illiminate
|
||||||
|
some warnings about some serious issues. TIdReply is ONLY a base class with
|
||||||
|
virtual methods.
|
||||||
|
|
||||||
|
Rev 1.2 7/9/2003 01:43:22 PM JPMugaas
|
||||||
|
Should now compile.
|
||||||
|
|
||||||
|
Rev 1.1 7/9/2003 2:56:44 PM SPerry
|
||||||
|
Added OnException event
|
||||||
|
|
||||||
|
|
||||||
|
Rev 1.0 7/6/2003 4:47:38 PM SPerry
|
||||||
|
Units that use Command handlers
|
||||||
|
}
|
||||||
|
unit IdCommandHandlers;
|
||||||
|
|
||||||
|
{
|
||||||
|
Original author: Chad Z. Hower
|
||||||
|
Separate Unit : Sergio Perry
|
||||||
|
}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
{$I IdCompilerDefines.inc}
|
||||||
|
//Put FPC into Delphi mode
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes,
|
||||||
|
IdBaseComponent, IdComponent, IdReply, IdGlobal,
|
||||||
|
IdContext, IdReplyRFC;
|
||||||
|
|
||||||
|
const
|
||||||
|
IdEnabledDefault = True;
|
||||||
|
// DO NOT change this default (ParseParams). Many servers rely on this
|
||||||
|
IdParseParamsDefault = True;
|
||||||
|
IdHelpVisibleDef = True;
|
||||||
|
type
|
||||||
|
TIdCommandHandlers = class;
|
||||||
|
TIdCommandHandler = class;
|
||||||
|
TIdCommand = class;
|
||||||
|
|
||||||
|
{ Events }
|
||||||
|
TIdCommandEvent = procedure(ASender: TIdCommand) of object;
|
||||||
|
TIdAfterCommandHandlerEvent = procedure(ASender: TIdCommandHandlers;
|
||||||
|
AContext: TIdContext) of object;
|
||||||
|
TIdBeforeCommandHandlerEvent = procedure(ASender: TIdCommandHandlers;
|
||||||
|
var AData: string; AContext: TIdContext) of object;
|
||||||
|
TIdCommandHandlersExceptionEvent = procedure(ACommand: String; AContext: TIdContext) of object;
|
||||||
|
|
||||||
|
{ TIdCommandHandler }
|
||||||
|
TIdCommandHandler = class(TCollectionItem)
|
||||||
|
protected
|
||||||
|
FCmdDelimiter: Char;
|
||||||
|
FCommand: string;
|
||||||
|
{$IFDEF USE_OBJECT_ARC}
|
||||||
|
// When ARC is enabled, object references MUST be valid objects.
|
||||||
|
// It is common for users to store non-object values, though, so
|
||||||
|
// we will provide separate properties for those purposes
|
||||||
|
//
|
||||||
|
// TODO; use TValue instead of separating them
|
||||||
|
//
|
||||||
|
FDataObject: TObject;
|
||||||
|
FDataValue: PtrInt;
|
||||||
|
{$ELSE}
|
||||||
|
FData: TObject;
|
||||||
|
{$ENDIF}
|
||||||
|
FDescription: TStrings;
|
||||||
|
FDisconnect: boolean;
|
||||||
|
FEnabled: boolean;
|
||||||
|
FExceptionReply: TIdReply;
|
||||||
|
FHelpSuperScript : String; //may be something like * or + which should appear in help
|
||||||
|
FHelpVisible : Boolean;
|
||||||
|
FName: string;
|
||||||
|
FNormalReply: TIdReply;
|
||||||
|
FOnCommand: TIdCommandEvent;
|
||||||
|
FParamDelimiter: Char;
|
||||||
|
FParseParams: Boolean;
|
||||||
|
FReplyClass : TIdReplyClass;
|
||||||
|
FResponse: TStrings;
|
||||||
|
FTag: integer;
|
||||||
|
//
|
||||||
|
function GetDisplayName: string; override;
|
||||||
|
procedure SetDescription(AValue: TStrings);
|
||||||
|
procedure SetExceptionReply(AValue: TIdReply);
|
||||||
|
procedure SetNormalReply(AValue: TIdReply);
|
||||||
|
procedure SetResponse(AValue: TStrings);
|
||||||
|
public
|
||||||
|
function Check(const AData: string; AContext: TIdContext): boolean; virtual;
|
||||||
|
procedure DoCommand(const AData: string; AContext: TIdContext; AUnparsedParams: string); virtual;
|
||||||
|
procedure DoParseParams(AUnparsedParams: string; AParams: TStrings); virtual;
|
||||||
|
constructor Create(ACollection: TCollection); override;
|
||||||
|
destructor Destroy; override;
|
||||||
|
// function GetNamePath: string; override;
|
||||||
|
function NameIs(const ACommand: string): Boolean;
|
||||||
|
//
|
||||||
|
{$IFDEF USE_OBJECT_ARC}
|
||||||
|
property DataObject: TObject read FDataObject write FDataObject;
|
||||||
|
property DataValue: PtrInt read FDataValue write FDataValue;
|
||||||
|
{$ELSE}
|
||||||
|
property Data: TObject read FData write FData;
|
||||||
|
{$ENDIF}
|
||||||
|
published
|
||||||
|
property CmdDelimiter: Char read FCmdDelimiter write FCmdDelimiter;
|
||||||
|
property Command: string read FCommand write FCommand;
|
||||||
|
property Description: TStrings read FDescription write SetDescription;
|
||||||
|
property Disconnect: boolean read FDisconnect write FDisconnect;
|
||||||
|
property Enabled: boolean read FEnabled write FEnabled default IdEnabledDefault;
|
||||||
|
property ExceptionReply: TIdReply read FExceptionReply write SetExceptionReply;
|
||||||
|
property Name: string read FName write FName;
|
||||||
|
property NormalReply: TIdReply read FNormalReply write SetNormalReply;
|
||||||
|
property ParamDelimiter: Char read FParamDelimiter write FParamDelimiter;
|
||||||
|
property ParseParams: Boolean read FParseParams write FParseParams;
|
||||||
|
property Response: TStrings read FResponse write SetResponse;
|
||||||
|
property Tag: Integer read FTag write FTag;
|
||||||
|
//
|
||||||
|
property HelpSuperScript : String read FHelpSuperScript write FHelpSuperScript; //may be something like * or + which should appear in help
|
||||||
|
property HelpVisible : Boolean read FHelpVisible write FHelpVisible default IdHelpVisibleDef;
|
||||||
|
|
||||||
|
property OnCommand: TIdCommandEvent read FOnCommand write FOnCommand;
|
||||||
|
end;
|
||||||
|
|
||||||
|
TIdCommandHandlerClass = class of TIdCommandHandler;
|
||||||
|
|
||||||
|
{ TIdCommandHandlers }
|
||||||
|
TIdCommandHandlers = class(TOwnedCollection)
|
||||||
|
protected
|
||||||
|
FBase: TIdComponent;
|
||||||
|
FExceptionReply: TIdReply;
|
||||||
|
FOnAfterCommandHandler: TIdAfterCommandHandlerEvent;
|
||||||
|
FOnBeforeCommandHandler: TIdBeforeCommandHandlerEvent;
|
||||||
|
FOnCommandHandlersException: TIdCommandHandlersExceptionEvent;
|
||||||
|
FParseParamsDef: Boolean;
|
||||||
|
FPerformReplies: Boolean;
|
||||||
|
FReplyClass: TIdReplyClass;
|
||||||
|
FReplyTexts: TIdReplies;
|
||||||
|
//
|
||||||
|
procedure DoAfterCommandHandler(AContext: TIdContext);
|
||||||
|
procedure DoBeforeCommandHandler(AContext: TIdContext; var VLine: string);
|
||||||
|
procedure DoOnCommandHandlersException(const ACommand: String; AContext: TIdContext);
|
||||||
|
function GetItem(AIndex: Integer): TIdCommandHandler;
|
||||||
|
// This is used instead of the OwnedBy property directly calling GetOwner because
|
||||||
|
// D5 dies with internal errors and crashes
|
||||||
|
// function GetOwnedBy: TIdPersistent;
|
||||||
|
procedure SetItem(AIndex: Integer; const AValue: TIdCommandHandler);
|
||||||
|
public
|
||||||
|
function Add: TIdCommandHandler;
|
||||||
|
constructor Create(
|
||||||
|
ABase: TIdComponent;
|
||||||
|
AReplyClass: TIdReplyClass;
|
||||||
|
AReplyTexts: TIdReplies;
|
||||||
|
AExceptionReply: TIdReply = nil;
|
||||||
|
ACommandHandlerClass: TIdCommandHandlerClass = nil
|
||||||
|
); reintroduce;
|
||||||
|
function HandleCommand(AContext: TIdContext; var VCommand: string): Boolean; virtual;
|
||||||
|
//
|
||||||
|
property Base: TIdComponent read FBase;
|
||||||
|
property Items[AIndex: Integer]: TIdCommandHandler read GetItem write SetItem;
|
||||||
|
// OwnedBy is used so as not to conflict with Owner in D6
|
||||||
|
//property OwnedBy: TIdPersistent read GetOwnedBy;
|
||||||
|
property ParseParamsDefault: Boolean read FParseParamsDef write FParseParamsDef;
|
||||||
|
property PerformReplies: Boolean read FPerformReplies write FPerformReplies;
|
||||||
|
property ReplyClass: TIdReplyClass read FReplyClass;
|
||||||
|
property ReplyTexts: TIdReplies read FReplyTexts;
|
||||||
|
//
|
||||||
|
property OnAfterCommandHandler: TIdAfterCommandHandlerEvent read FOnAfterCommandHandler
|
||||||
|
write FOnAfterCommandHandler;
|
||||||
|
// Occurs in the context of the peer thread
|
||||||
|
property OnBeforeCommandHandler: TIdBeforeCommandHandlerEvent read FOnBeforeCommandHandler
|
||||||
|
write FOnBeforeCommandHandler;
|
||||||
|
property OnCommandHandlersException: TIdCommandHandlersExceptionEvent read FOnCommandHandlersException
|
||||||
|
write FOnCommandHandlersException;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TIdCommand }
|
||||||
|
TIdCommand = class(TObject)
|
||||||
|
protected
|
||||||
|
FCommandHandler: TIdCommandHandler;
|
||||||
|
FDisconnect: Boolean;
|
||||||
|
FParams: TStrings;
|
||||||
|
FPerformReply: Boolean;
|
||||||
|
FRawLine: string;
|
||||||
|
FReply: TIdReply;
|
||||||
|
FResponse: TStrings;
|
||||||
|
FContext: TIdContext;
|
||||||
|
FUnparsedParams: string;
|
||||||
|
FSendEmptyResponse: Boolean;
|
||||||
|
//
|
||||||
|
procedure DoCommand; virtual;
|
||||||
|
procedure SetReply(AValue: TIdReply);
|
||||||
|
procedure SetResponse(AValue: TStrings);
|
||||||
|
public
|
||||||
|
constructor Create(AOwner: TIdCommandHandler); virtual;
|
||||||
|
destructor Destroy; override;
|
||||||
|
procedure SendReply;
|
||||||
|
//
|
||||||
|
property CommandHandler: TIdCommandHandler read FCommandHandler;
|
||||||
|
property Disconnect: Boolean read FDisconnect write FDisconnect;
|
||||||
|
property PerformReply: Boolean read FPerformReply write FPerformReply;
|
||||||
|
property Params: TStrings read FParams;
|
||||||
|
property RawLine: string read FRawLine;
|
||||||
|
property Reply: TIdReply read FReply write SetReply;
|
||||||
|
property Response: TStrings read FResponse write SetResponse;
|
||||||
|
property Context: TIdContext read FContext;
|
||||||
|
property UnparsedParams: string read FUnparsedParams;
|
||||||
|
property SendEmptyResponse: Boolean read FSendEmptyResponse write FSendEmptyResponse;
|
||||||
|
end;//TIdCommand
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
SysUtils;
|
||||||
|
|
||||||
|
{ TIdCommandHandlers }
|
||||||
|
|
||||||
|
constructor TIdCommandHandlers.Create(
|
||||||
|
ABase: TIdComponent;
|
||||||
|
AReplyClass: TIdReplyClass;
|
||||||
|
AReplyTexts: TIdReplies;
|
||||||
|
AExceptionReply: TIdReply = nil;
|
||||||
|
ACommandHandlerClass: TIdCommandHandlerClass = nil
|
||||||
|
);
|
||||||
|
begin
|
||||||
|
if ACommandHandlerClass = nil then begin
|
||||||
|
ACommandHandlerClass := TIdCommandHandler;
|
||||||
|
end;
|
||||||
|
inherited Create(ABase, ACommandHandlerClass);
|
||||||
|
FBase := ABase;
|
||||||
|
FExceptionReply := AExceptionReply;
|
||||||
|
FParseParamsDef := IdParseParamsDefault;
|
||||||
|
FPerformReplies := True; // RLebeau: default to legacy behavior
|
||||||
|
FReplyClass := AReplyClass;
|
||||||
|
FReplyTexts := AReplyTexts;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdCommandHandlers.Add: TIdCommandHandler;
|
||||||
|
begin
|
||||||
|
Result := TIdCommandHandler(inherited Add);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdCommandHandlers.HandleCommand(AContext: TIdContext;
|
||||||
|
var VCommand: string): Boolean;
|
||||||
|
var
|
||||||
|
i, j: Integer;
|
||||||
|
begin
|
||||||
|
j := Count - 1;
|
||||||
|
Result := False;
|
||||||
|
DoBeforeCommandHandler(AContext, VCommand); try
|
||||||
|
i := 0;
|
||||||
|
while i <= j do begin
|
||||||
|
if Items[i].Enabled then begin
|
||||||
|
Result := Items[i].Check(VCommand, AContext);
|
||||||
|
if Result then begin
|
||||||
|
Break;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
Inc(i);
|
||||||
|
end;
|
||||||
|
finally DoAfterCommandHandler(AContext); end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCommandHandlers.DoAfterCommandHandler(AContext: TIdContext);
|
||||||
|
begin
|
||||||
|
if Assigned(OnAfterCommandHandler) then begin
|
||||||
|
OnAfterCommandHandler(Self, AContext);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCommandHandlers.DoBeforeCommandHandler(AContext: TIdContext;
|
||||||
|
var VLine: string);
|
||||||
|
begin
|
||||||
|
if Assigned(OnBeforeCommandHandler) then begin
|
||||||
|
OnBeforeCommandHandler(Self, VLine, AContext);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCommandHandlers.DoOnCommandHandlersException(const ACommand: String;
|
||||||
|
AContext: TIdContext);
|
||||||
|
begin
|
||||||
|
if Assigned(FOnCommandHandlersException) then begin
|
||||||
|
OnCommandHandlersException(ACommand, AContext);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdCommandHandlers.GetItem(AIndex: Integer): TIdCommandHandler;
|
||||||
|
begin
|
||||||
|
Result := TIdCommandHandler(inherited Items[AIndex]);
|
||||||
|
end;
|
||||||
|
|
||||||
|
{
|
||||||
|
function TIdCommandHandlers.GetOwnedBy: TIdPersistent;
|
||||||
|
begin
|
||||||
|
Result := GetOwner;
|
||||||
|
end;
|
||||||
|
}
|
||||||
|
|
||||||
|
procedure TIdCommandHandlers.SetItem(AIndex: Integer; const AValue: TIdCommandHandler);
|
||||||
|
begin
|
||||||
|
inherited SetItem(AIndex, AValue);
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TIdCommandHandler }
|
||||||
|
|
||||||
|
procedure TIdCommandHandler.DoCommand(const AData: string; AContext: TIdContext; AUnparsedParams: string);
|
||||||
|
var
|
||||||
|
LCommand: TIdCommand;
|
||||||
|
begin
|
||||||
|
LCommand := TIdCommand.Create(Self);
|
||||||
|
try
|
||||||
|
LCommand.FRawLine := AData;
|
||||||
|
LCommand.FContext := AContext;
|
||||||
|
LCommand.FUnparsedParams := AUnparsedParams;
|
||||||
|
|
||||||
|
if ParseParams then begin
|
||||||
|
DoParseParams(AUnparsedParams, LCommand.Params);
|
||||||
|
end;
|
||||||
|
|
||||||
|
// RLebeau 2/21/08: for the IRC protocol, RFC 2812 section 2.4 says that
|
||||||
|
// clients are not allowed to issue numeric replies for server-issued
|
||||||
|
// commands. Added the PerformReplies property so TIdIRC can specify
|
||||||
|
// that behavior.
|
||||||
|
if Collection is TIdCommandHandlers then begin
|
||||||
|
LCommand.PerformReply := TIdCommandHandlers(Collection).PerformReplies;
|
||||||
|
end;
|
||||||
|
|
||||||
|
try
|
||||||
|
if (LCommand.Reply.Code = '') and (NormalReply.Code <> '') then begin
|
||||||
|
LCommand.Reply.Assign(NormalReply);
|
||||||
|
end;
|
||||||
|
|
||||||
|
//if code<>'' before DoCommand, then it breaks exception handling
|
||||||
|
Assert(LCommand.Reply.Code <> '');
|
||||||
|
LCommand.DoCommand;
|
||||||
|
|
||||||
|
if LCommand.Reply.Code = '' then begin
|
||||||
|
LCommand.Reply.Assign(NormalReply);
|
||||||
|
end;
|
||||||
|
// UpdateText here in case user wants to add to it. SendReply also gets it in case
|
||||||
|
// a different reply is sent (ie exception, etc), or the user changes the code in the event
|
||||||
|
LCommand.Reply.UpdateText;
|
||||||
|
except
|
||||||
|
on E: Exception do begin
|
||||||
|
// If there is an unhandled exception, we override all replies
|
||||||
|
// If nothing specified to override with, we throw the exception again.
|
||||||
|
// If the user wants a custom value on exception other, its their responsibility
|
||||||
|
// to catch it before it reaches us
|
||||||
|
LCommand.Reply.Clear;
|
||||||
|
if LCommand.PerformReply then begin
|
||||||
|
// Try from command handler first
|
||||||
|
if ExceptionReply.Code <> '' then begin
|
||||||
|
LCommand.Reply.Assign(ExceptionReply);
|
||||||
|
// If still no go, from server
|
||||||
|
// Can be nil though. Typically only servers pass it in
|
||||||
|
end else if (Collection is TIdCommandHandlers) and (TIdCommandHandlers(Collection).FExceptionReply <> nil) then begin
|
||||||
|
LCommand.Reply.Assign(TIdCommandHandlers(Collection).FExceptionReply);
|
||||||
|
end;
|
||||||
|
if LCommand.Reply.Code <> '' then begin
|
||||||
|
//done this way in case an exception message has more than one line.
|
||||||
|
//otherwise you could get something like this:
|
||||||
|
//
|
||||||
|
// 550 System Error. Code: 2
|
||||||
|
// The system cannot find the file specified
|
||||||
|
//
|
||||||
|
//and the second line would throw off some clients.
|
||||||
|
LCommand.Reply.Text.Text := E.Message;
|
||||||
|
//Reply.Text.Add(E.Message);
|
||||||
|
LCommand.SendReply;
|
||||||
|
end else begin
|
||||||
|
raise;
|
||||||
|
end;
|
||||||
|
end else begin
|
||||||
|
raise;
|
||||||
|
end;
|
||||||
|
end else begin
|
||||||
|
raise;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
if LCommand.PerformReply then begin
|
||||||
|
LCommand.SendReply;
|
||||||
|
end;
|
||||||
|
|
||||||
|
if (LCommand.Response.Count > 0) or LCommand.SendEmptyResponse then begin
|
||||||
|
AContext.Connection.WriteRFCStrings(LCommand.Response);
|
||||||
|
end else if Response.Count > 0 then begin
|
||||||
|
AContext.Connection.WriteRFCStrings(Response);
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
try
|
||||||
|
if LCommand.Disconnect then begin
|
||||||
|
AContext.Connection.Disconnect;
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
LCommand.Free;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCommandHandler.DoParseParams(AUnparsedParams: string; AParams: TStrings);
|
||||||
|
// AUnparsedParams is not preparsed and is completely left up to the command handler. This will
|
||||||
|
// allow for future expansion such as multiple delimiters etc, and allow the logic to properly
|
||||||
|
// remain in each of the command handler implementations. In the future there may be a base type
|
||||||
|
// and multiple descendants
|
||||||
|
begin
|
||||||
|
AParams.Clear;
|
||||||
|
SplitDelimitedString(AUnparsedParams, AParams, FParamDelimiter <> #32, FParamDelimiter);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdCommandHandler.Check(const AData: string; AContext: TIdContext): boolean;
|
||||||
|
// AData is not preparsed and is completely left up to the command handler. This will allow for
|
||||||
|
// future expansion such as wild cards etc, and allow the logic to properly remain in each of the
|
||||||
|
// command handler implementations. In the future there may be a base type and multiple descendants
|
||||||
|
var
|
||||||
|
LUnparsedParams: string;
|
||||||
|
begin
|
||||||
|
LUnparsedParams := '';
|
||||||
|
Result := TextIsSame(AData, Command); // Command by itself
|
||||||
|
|
||||||
|
if not Result then begin
|
||||||
|
if CmdDelimiter <> #0 then begin
|
||||||
|
Result := TextStartsWith(AData, Command + CmdDelimiter);
|
||||||
|
if Result then begin
|
||||||
|
LUnparsedParams := Copy(AData, Length(Command) + 2, MaxInt);
|
||||||
|
end;
|
||||||
|
end else begin
|
||||||
|
// Dont strip any part of the params out.. - just remove the command purely on length and
|
||||||
|
// no delim
|
||||||
|
Result := TextStartsWith(AData, Command);
|
||||||
|
if Result then begin
|
||||||
|
LUnparsedParams := Copy(AData, Length(Command) + 1, MaxInt);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
if Result then begin
|
||||||
|
DoCommand(AData, AContext, LUnparsedParams);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
constructor TIdCommandHandler.Create(ACollection: TCollection);
|
||||||
|
begin
|
||||||
|
inherited Create(ACollection);
|
||||||
|
|
||||||
|
FReplyClass := TIdCommandHandlers(ACollection).ReplyClass;
|
||||||
|
if FReplyClass = nil then begin
|
||||||
|
FReplyClass := TIdReplyRFC;
|
||||||
|
end;
|
||||||
|
|
||||||
|
FCmdDelimiter := #32;
|
||||||
|
FEnabled := IdEnabledDefault;
|
||||||
|
FName := ClassName + IntToStr(ID);
|
||||||
|
FParamDelimiter := #32;
|
||||||
|
FParseParams := TIdCommandHandlers(ACollection).ParseParamsDefault;
|
||||||
|
FResponse := TStringList.Create;
|
||||||
|
FDescription := TStringList.Create;
|
||||||
|
|
||||||
|
FNormalReply := FReplyClass.CreateWithReplyTexts(nil, TIdCommandHandlers(ACollection).ReplyTexts);
|
||||||
|
if FNormalReply is TIdReplyRFC then begin
|
||||||
|
FNormalReply.Code := '200'; {do not localize}
|
||||||
|
end;
|
||||||
|
FHelpVisible := IdHelpVisibleDef;
|
||||||
|
// Dont initialize, pulls from CmdTCPServer for defaults
|
||||||
|
FExceptionReply := FReplyClass.CreateWithReplyTexts(nil, TIdCommandHandlers(ACollection).ReplyTexts);
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TIdCommandHandler.Destroy;
|
||||||
|
begin
|
||||||
|
FreeAndNil(FResponse);
|
||||||
|
FreeAndNil(FNormalReply);
|
||||||
|
FreeAndNil(FDescription);
|
||||||
|
FreeAndNil(FExceptionReply);
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdCommandHandler.GetDisplayName: string;
|
||||||
|
begin
|
||||||
|
if Command = '' then begin
|
||||||
|
Result := Name;
|
||||||
|
end else begin
|
||||||
|
Result := Command;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{
|
||||||
|
function TIdCommandHandler.GetNamePath: string;
|
||||||
|
begin
|
||||||
|
if Collection <> nil then begin
|
||||||
|
// OwnedBy is used because D4/D5 dont expose Owner on TOwnedCollection but D6 does
|
||||||
|
Result := TIdCommandHandlers(Collection).OwnedBy.GetNamePath + '.' + Name;
|
||||||
|
end else begin
|
||||||
|
Result := inherited GetNamePath;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
}
|
||||||
|
|
||||||
|
function TIdCommandHandler.NameIs(const ACommand: string): Boolean;
|
||||||
|
begin
|
||||||
|
Result := TextIsSame(ACommand, FName);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCommandHandler.SetExceptionReply(AValue: TIdReply);
|
||||||
|
begin
|
||||||
|
FExceptionReply.Assign(AValue);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCommandHandler.SetNormalReply(AValue: TIdReply);
|
||||||
|
begin
|
||||||
|
FNormalReply.Assign(AValue);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCommandHandler.SetResponse(AValue: TStrings);
|
||||||
|
begin
|
||||||
|
FResponse.Assign(AValue);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCommandHandler.SetDescription(AValue: TStrings);
|
||||||
|
begin
|
||||||
|
FDescription.Assign(AValue);
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TIdCommand }
|
||||||
|
|
||||||
|
constructor TIdCommand.Create(AOwner: TIdCommandHandler);
|
||||||
|
begin
|
||||||
|
inherited Create;
|
||||||
|
FParams := TStringList.Create;
|
||||||
|
FReply := AOwner.FReplyClass.CreateWithReplyTexts(nil, TIdCommandHandlers(AOwner.Collection).ReplyTexts);
|
||||||
|
FResponse := TStringList.Create;
|
||||||
|
FCommandHandler := AOwner;
|
||||||
|
FDisconnect := AOwner.Disconnect;
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TIdCommand.Destroy;
|
||||||
|
begin
|
||||||
|
FreeAndNil(FReply);
|
||||||
|
FreeAndNil(FResponse);
|
||||||
|
FreeAndNil(FParams);
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCommand.DoCommand;
|
||||||
|
begin
|
||||||
|
if Assigned(CommandHandler.OnCommand) then begin
|
||||||
|
CommandHandler.OnCommand(Self);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCommand.SendReply;
|
||||||
|
begin
|
||||||
|
PerformReply := False;
|
||||||
|
Reply.UpdateText;
|
||||||
|
Context.Connection.IOHandler.Write(Reply.FormattedReply);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCommand.SetReply(AValue: TIdReply);
|
||||||
|
begin
|
||||||
|
FReply.Assign(AValue);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCommand.SetResponse(AValue: TStrings);
|
||||||
|
begin
|
||||||
|
FResponse.Assign(AValue);
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
|
@ -0,0 +1,220 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.14 6/16/2004 2:08:48 PM JPMugaas
|
||||||
|
Binding made public for the FTP Server.
|
||||||
|
|
||||||
|
Rev 1.13 6/4/2004 1:34:24 PM DSiders
|
||||||
|
Removed unused TIdContextDoRun, TIdContextMethod types.
|
||||||
|
|
||||||
|
Rev 1.12 2004.02.03 4:17:08 PM czhower
|
||||||
|
For unit name changes.
|
||||||
|
|
||||||
|
Rev 1.11 21.1.2004 ã. 12:31:04 DBondzhev
|
||||||
|
Fix for Indy source. Workaround for dccil bug
|
||||||
|
now it can be compiled using Compile instead of build
|
||||||
|
|
||||||
|
Rev 1.10 2003.10.21 12:18:58 AM czhower
|
||||||
|
TIdTask support and fiber bug fixes.
|
||||||
|
|
||||||
|
Rev 1.9 2003.10.11 5:47:18 PM czhower
|
||||||
|
-VCL fixes for servers
|
||||||
|
-Chain suport for servers (Super core)
|
||||||
|
-Scheduler upgrades
|
||||||
|
-Full yarn support
|
||||||
|
|
||||||
|
Rev 1.8 2003.09.19 11:54:28 AM czhower
|
||||||
|
-Completed more features necessary for servers
|
||||||
|
-Fixed some bugs
|
||||||
|
|
||||||
|
Rev 1.7 3/22/2003 09:45:26 PM JPMugaas
|
||||||
|
Now should compile under D4.
|
||||||
|
|
||||||
|
Rev 1.6 3/13/2003 10:18:38 AM BGooijen
|
||||||
|
Server side fibers, bug fixes
|
||||||
|
|
||||||
|
Rev 1.5 1/31/2003 7:24:18 PM BGooijen
|
||||||
|
Added a .Binding function
|
||||||
|
|
||||||
|
Rev 1.4 1/23/2003 8:33:20 PM BGooijen
|
||||||
|
|
||||||
|
Rev 1.3 1/23/2003 11:06:06 AM BGooijen
|
||||||
|
|
||||||
|
|
||||||
|
Rev 1.2 1-17-2003 23:58:30 BGooijen
|
||||||
|
removed OnCreate/OnDestroy again, they had no use
|
||||||
|
|
||||||
|
Rev 1.0 1-17-2003 22:28:58 BGooijen
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdContext;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
{$i IdCompilerDefines.inc}
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes,
|
||||||
|
IdSocketHandle, IdTCPConnection, IdTask, IdYarn, IdThreadSafe,
|
||||||
|
{$IFDEF HAS_GENERICS_TThreadList}
|
||||||
|
System.Generics.Collections,
|
||||||
|
{$ENDIF}
|
||||||
|
SysUtils;
|
||||||
|
|
||||||
|
type
|
||||||
|
TIdContext = class;
|
||||||
|
TIdContextClass = class of TIdContext;
|
||||||
|
TIdContextRun = function(AContext: TIdContext): Boolean of object;
|
||||||
|
TIdContextEvent = procedure(AContext: TIdContext) of object;
|
||||||
|
TIdContextExceptionEvent = procedure(AContext: TIdContext; AException: Exception) of object;
|
||||||
|
|
||||||
|
{$IFDEF HAS_GENERICS_TThreadList}
|
||||||
|
TIdContextThreadList = TIdThreadSafeObjectList<TIdContext>;
|
||||||
|
TIdContextList = TList<TIdContext>;
|
||||||
|
{$ELSE}
|
||||||
|
// TODO: flesh out to match TThreadList<TIdContext> and TList<TIdContext> for non-Generics compilers
|
||||||
|
TIdContextThreadList = TIdThreadSafeObjectList;
|
||||||
|
TIdContextList = TList;
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
TIdContext = class(TIdTask)
|
||||||
|
protected
|
||||||
|
// A list in which this context is registered, this can be nil, and should
|
||||||
|
// therefore not be used
|
||||||
|
FContextList: TIdContextThreadList;
|
||||||
|
FConnection: TIdTCPConnection; // TODO: should this be [Weak] on ARC systems?
|
||||||
|
FOwnsConnection: Boolean;
|
||||||
|
FOnRun: TIdContextRun;
|
||||||
|
FOnBeforeRun: TIdContextEvent;
|
||||||
|
FOnAfterRun: TIdContextEvent;
|
||||||
|
FOnException: TIdContextExceptionEvent;
|
||||||
|
//
|
||||||
|
procedure BeforeRun; override;
|
||||||
|
function Run: Boolean; override;
|
||||||
|
procedure AfterRun; override;
|
||||||
|
procedure HandleException(AException: Exception); override;
|
||||||
|
function GetBinding: TIdSocketHandle;
|
||||||
|
public
|
||||||
|
constructor Create(
|
||||||
|
AConnection: TIdTCPConnection;
|
||||||
|
AYarn: TIdYarn;
|
||||||
|
AList: TIdContextThreadList = nil
|
||||||
|
); reintroduce; virtual;
|
||||||
|
destructor Destroy; override;
|
||||||
|
procedure RemoveFromList;
|
||||||
|
//
|
||||||
|
property Binding: TIdSocketHandle read GetBinding;
|
||||||
|
property Connection: TIdTCPConnection read FConnection;
|
||||||
|
//
|
||||||
|
property OnAfterRun: TIdContextEvent read FOnAfterRun write FOnAfterRun;
|
||||||
|
property OnBeforeRun: TIdContextEvent read FOnBeforeRun write FOnBeforeRun;
|
||||||
|
property OnRun: TIdContextRun read FOnRun write FOnRun;
|
||||||
|
property OnException: TIdContextExceptionEvent read FOnException write FOnException;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
{ TIdContext }
|
||||||
|
|
||||||
|
uses
|
||||||
|
{$IFDEF VCL_XE3_OR_ABOVE}
|
||||||
|
System.Types,
|
||||||
|
{$ENDIF}
|
||||||
|
IdGlobal,
|
||||||
|
IdIOHandlerSocket;
|
||||||
|
|
||||||
|
constructor TIdContext.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn;
|
||||||
|
AList: TIdContextThreadList = nil);
|
||||||
|
begin
|
||||||
|
inherited Create(AYarn);
|
||||||
|
FConnection := AConnection;
|
||||||
|
FOwnsConnection := True;
|
||||||
|
FContextList := AList;
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TIdContext.Destroy;
|
||||||
|
begin
|
||||||
|
if Assigned(FContextList) then begin
|
||||||
|
FContextList.Remove(Self);
|
||||||
|
end;
|
||||||
|
|
||||||
|
if FOwnsConnection then begin
|
||||||
|
IdDisposeAndNil(FConnection);
|
||||||
|
end;
|
||||||
|
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdContext.RemoveFromList;
|
||||||
|
begin
|
||||||
|
FContextList := nil;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdContext.BeforeRun;
|
||||||
|
begin
|
||||||
|
//Context must be added to ContextList outside of create. This avoids
|
||||||
|
//the possibility of another thread accessing a context (specifically
|
||||||
|
//a subclass) that is still creating. similar logic for remove/destroy.
|
||||||
|
if Assigned(FContextList) then begin
|
||||||
|
FContextList.Add(Self);
|
||||||
|
end;
|
||||||
|
|
||||||
|
if Assigned(OnBeforeRun) then begin
|
||||||
|
OnBeforeRun(Self);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdContext.Run: Boolean;
|
||||||
|
begin
|
||||||
|
if Assigned(OnRun) then begin
|
||||||
|
Result := OnRun(Self);
|
||||||
|
end else begin
|
||||||
|
Result := True;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdContext.AfterRun;
|
||||||
|
begin
|
||||||
|
if Assigned(OnAfterRun) then begin
|
||||||
|
OnAfterRun(Self);
|
||||||
|
end;
|
||||||
|
|
||||||
|
if FContextList <> nil then begin
|
||||||
|
FContextList.Remove(Self);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdContext.HandleException(AException: Exception);
|
||||||
|
begin
|
||||||
|
if Assigned(OnException) then begin
|
||||||
|
OnException(Self, AException);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdContext.GetBinding: TIdSocketHandle;
|
||||||
|
begin
|
||||||
|
Result := nil;
|
||||||
|
if Connection <> nil then begin
|
||||||
|
if Connection.Socket <> nil then begin
|
||||||
|
Result := Connection.Socket.Binding;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
||||||
|
|
|
@ -0,0 +1,12 @@
|
||||||
|
[assembly: AssemblyDescription('Internet Direct (Indy) 10.6.2 Core Run-Time Package for Borland Developer Studio')]
|
||||||
|
[assembly: AssemblyConfiguration('')]
|
||||||
|
[assembly: AssemblyCompany('Chad Z. Hower a.k.a Kudzu and the Indy Pit Crew')]
|
||||||
|
[assembly: AssemblyProduct('Indy for Microsoft .NET Framework')]
|
||||||
|
[assembly: AssemblyCopyright('Copyright © 1993 - 2015 Chad Z. Hower a.k.a Kudzu and the Indy Pit Crew')]
|
||||||
|
[assembly: AssemblyTrademark('')]
|
||||||
|
[assembly: AssemblyCulture('')]
|
||||||
|
[assembly: AssemblyTitle('Indy .NET Core Run-Time Package')]
|
||||||
|
[assembly: AssemblyVersion('10.6.2.*')]
|
||||||
|
[assembly: AssemblyDelaySign(false)]
|
||||||
|
[assembly: AssemblyKeyFile('')]
|
||||||
|
[assembly: AssemblyKeyName('')]
|
|
@ -0,0 +1,244 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.4 12/10/2004 15:36:40 HHariri
|
||||||
|
Fix so it works with D8 too
|
||||||
|
|
||||||
|
Rev 1.3 9/5/2004 2:08:14 PM JPMugaas
|
||||||
|
Should work in D9 NET.
|
||||||
|
|
||||||
|
Rev 1.2 2/3/2004 11:42:52 AM JPMugaas
|
||||||
|
Fixed for new design.
|
||||||
|
|
||||||
|
Rev 1.1 2/1/2004 2:44:20 AM JPMugaas
|
||||||
|
Bindings editor should be fully functional including IPv6 support.
|
||||||
|
|
||||||
|
Rev 1.0 11/13/2002 08:41:18 AM JPMugaas
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdCoreDsnRegister;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
{$I IdCompilerDefines.inc}
|
||||||
|
|
||||||
|
uses
|
||||||
|
{$IFDEF DOTNET}
|
||||||
|
Borland.Vcl.Design.DesignIntF,
|
||||||
|
Borland.Vcl.Design.DesignEditors
|
||||||
|
{$ELSE}
|
||||||
|
{$IFDEF FPC}
|
||||||
|
PropEdits,
|
||||||
|
ComponentEditors
|
||||||
|
{$ELSE}
|
||||||
|
{$IFDEF VCL_6_OR_ABOVE}
|
||||||
|
DesignIntf,
|
||||||
|
DesignEditors
|
||||||
|
{$ELSE}
|
||||||
|
Dsgnintf
|
||||||
|
{$ENDIF}
|
||||||
|
{$ENDIF}
|
||||||
|
{$ENDIF}
|
||||||
|
;
|
||||||
|
|
||||||
|
type
|
||||||
|
{$IFDEF FPC}
|
||||||
|
TIdBaseComponentEditor = class(TDefaultComponentEditor)
|
||||||
|
{$ELSE}
|
||||||
|
TIdBaseComponentEditor = class(TDefaultEditor)
|
||||||
|
{$ENDIF}
|
||||||
|
public
|
||||||
|
procedure ExecuteVerb(Index: Integer); override;
|
||||||
|
function GetVerb(Index: Integer): string; override;
|
||||||
|
function GetVerbCount: Integer; override;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{$IFDEF FPC}
|
||||||
|
TIdPropEdBinding = class(TPropertyEditor)
|
||||||
|
protected
|
||||||
|
FValue : String;
|
||||||
|
property Value : String read FValue write FValue;
|
||||||
|
{$ELSE}
|
||||||
|
TIdPropEdBinding = class(TClassProperty)
|
||||||
|
{$ENDIF}
|
||||||
|
public
|
||||||
|
procedure Edit; override;
|
||||||
|
function GetAttributes: TPropertyAttributes; override;
|
||||||
|
function GetValue: string; override;
|
||||||
|
procedure SetValue(const Value: string); override;
|
||||||
|
end;
|
||||||
|
|
||||||
|
// Procs
|
||||||
|
procedure Register;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes,
|
||||||
|
{$IFDEF WIDGET_WINFORMS}
|
||||||
|
IdDsnPropEdBindingNET,
|
||||||
|
IdAboutDotNET,
|
||||||
|
{$ELSE}
|
||||||
|
IdDsnPropEdBindingVCL,
|
||||||
|
IdAboutVCL,
|
||||||
|
{$ENDIF}
|
||||||
|
IdDsnCoreResourceStrings,
|
||||||
|
IdBaseComponent,
|
||||||
|
IdComponent,
|
||||||
|
IdGlobal,
|
||||||
|
IdStack,
|
||||||
|
IdSocketHandle;
|
||||||
|
|
||||||
|
{
|
||||||
|
Design Note: It turns out that in DotNET, there are no services file functions and
|
||||||
|
IdPorts does not work as expected in DotNET. It is probably possible to read the
|
||||||
|
services file ourselves but that creates some portability problems as the placement
|
||||||
|
is different in every operating system.
|
||||||
|
|
||||||
|
e.g.
|
||||||
|
|
||||||
|
Linux and Unix-like systems - /etc
|
||||||
|
Windows 95, 98, and ME - c:\windows
|
||||||
|
Windows NT systems - c:\winnt\system32\drivers\etc
|
||||||
|
|
||||||
|
Thus, it will undercut whatever benefit we could get with DotNET.
|
||||||
|
|
||||||
|
About the best I could think of is to use an edit control because
|
||||||
|
we can't offer anything from the services file in DotNET.
|
||||||
|
|
||||||
|
TODO: Maybe there might be a way to find the location in a more elegant
|
||||||
|
manner than what I described.
|
||||||
|
}
|
||||||
|
|
||||||
|
type
|
||||||
|
{$IFDEF WIDGET_WINFORMS}
|
||||||
|
TIdPropEdBindingEntry = TIdDsnPropEdBindingNET;
|
||||||
|
{$ELSE}
|
||||||
|
TIdPropEdBindingEntry = TIdDsnPropEdBindingVCL;
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
procedure TIdPropEdBinding.Edit;
|
||||||
|
var
|
||||||
|
pSockets: TIdSocketHandles;
|
||||||
|
pEntry: TIdPropEdBindingEntry;
|
||||||
|
begin
|
||||||
|
inherited Edit;
|
||||||
|
|
||||||
|
{$IFNDEF DOTNET}
|
||||||
|
pSockets := TIdSocketHandles(
|
||||||
|
{$IFDEF CPU64}
|
||||||
|
GetInt64Value
|
||||||
|
{$ELSE}
|
||||||
|
GetOrdValue
|
||||||
|
{$ENDIF}
|
||||||
|
);
|
||||||
|
{$ELSE}
|
||||||
|
pSockets := GetObjValue as TIdSocketHandles;
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
pEntry := TIdPropEdBindingEntry.Create;
|
||||||
|
try
|
||||||
|
pEntry.Caption := TComponent(GetComponent(0)).Name;
|
||||||
|
pEntry.DefaultPort := pSockets.DefaultPort;
|
||||||
|
Value := GetListValues(pSockets);
|
||||||
|
pEntry.SetList(Value);
|
||||||
|
if pEntry.Execute then
|
||||||
|
begin
|
||||||
|
Value := pEntry.GetList;
|
||||||
|
FillHandleList(Value, pSockets);
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
pEntry.Free;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdPropEdBinding.GetAttributes: TPropertyAttributes;
|
||||||
|
begin
|
||||||
|
Result := inherited GetAttributes + [paDialog];
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdPropEdBinding.GetValue: string;
|
||||||
|
var
|
||||||
|
pSockets: TIdSocketHandles;
|
||||||
|
begin
|
||||||
|
{$IFNDEF DOTNET}
|
||||||
|
pSockets := TIdSocketHandles(
|
||||||
|
{$IFDEF CPU64}
|
||||||
|
GetInt64Value
|
||||||
|
{$ELSE}
|
||||||
|
GetOrdValue
|
||||||
|
{$ENDIF}
|
||||||
|
);
|
||||||
|
{$ELSE}
|
||||||
|
pSockets := GetObjValue as TIdSocketHandles;
|
||||||
|
{$ENDIF}
|
||||||
|
Result := GetListValues(pSockets);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdPropEdBinding.SetValue(const Value: string);
|
||||||
|
var
|
||||||
|
pSockets: TIdSocketHandles;
|
||||||
|
begin
|
||||||
|
inherited SetValue(Value);
|
||||||
|
{$IFNDEF DOTNET}
|
||||||
|
pSockets := TIdSocketHandles(
|
||||||
|
{$IFDEF CPU64}
|
||||||
|
GetInt64Value
|
||||||
|
{$ELSE}
|
||||||
|
GetOrdValue
|
||||||
|
{$ENDIF}
|
||||||
|
);
|
||||||
|
{$ELSE}
|
||||||
|
pSockets := GetObjValue as TIdSocketHandles;
|
||||||
|
{$ENDIF}
|
||||||
|
pSockets.BeginUpdate;
|
||||||
|
try
|
||||||
|
FillHandleList(Value, pSockets);
|
||||||
|
finally
|
||||||
|
pSockets.EndUpdate;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TIdBaseComponentEditor }
|
||||||
|
|
||||||
|
procedure TIdBaseComponentEditor.ExecuteVerb(Index: Integer);
|
||||||
|
begin
|
||||||
|
case Index of
|
||||||
|
0 : TfrmAbout.ShowDlg;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdBaseComponentEditor.GetVerb(Index: Integer): string;
|
||||||
|
begin
|
||||||
|
case Index of
|
||||||
|
0: Result := IndyFormat(RSAAboutMenuItemName, [gsIdVersion]);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdBaseComponentEditor.GetVerbCount: Integer;
|
||||||
|
begin
|
||||||
|
Result := 1;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure Register;
|
||||||
|
begin
|
||||||
|
RegisterPropertyEditor(TypeInfo(TIdSocketHandles), nil, '', TIdPropEdBinding); {Do not Localize}
|
||||||
|
RegisterComponentEditor(TIdBaseComponent, TIdBaseComponentEditor);
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
|
@ -0,0 +1,253 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.10 11/12/2004 11:30:16 AM JPMugaas
|
||||||
|
Expansions for IPv6.
|
||||||
|
|
||||||
|
Rev 1.9 11/11/2004 10:25:22 PM JPMugaas
|
||||||
|
Added OpenProxy and CloseProxy so you can do RecvFrom and SendTo functions
|
||||||
|
from the UDP client with SOCKS. You must call OpenProxy before using
|
||||||
|
RecvFrom or SendTo. When you are finished, you must use CloseProxy to close
|
||||||
|
any connection to the Proxy. Connect and disconnect also call OpenProxy and
|
||||||
|
CloseProxy.
|
||||||
|
|
||||||
|
Rev 1.8 11/11/2004 3:42:52 AM JPMugaas
|
||||||
|
Moved strings into RS. Socks will now raise an exception if you attempt to
|
||||||
|
use SOCKS4 and SOCKS4A with UDP. Those protocol versions do not support UDP
|
||||||
|
at all.
|
||||||
|
|
||||||
|
Rev 1.7 11/9/2004 8:18:00 PM JPMugaas
|
||||||
|
Attempt to add SOCKS support in UDP.
|
||||||
|
|
||||||
|
Rev 1.6 6/6/2004 11:51:56 AM JPMugaas
|
||||||
|
Fixed TODO with an exception
|
||||||
|
|
||||||
|
Rev 1.5 2004.02.03 4:17:04 PM czhower
|
||||||
|
For unit name changes.
|
||||||
|
|
||||||
|
Rev 1.4 10/15/2003 10:59:06 PM DSiders
|
||||||
|
Corrected spelling error in resource string name.
|
||||||
|
Added resource string for circular links exception in transparent proxy.
|
||||||
|
|
||||||
|
Rev 1.3 10/15/2003 10:10:18 PM DSiders
|
||||||
|
Added localization comments.
|
||||||
|
|
||||||
|
Rev 1.2 5/16/2003 9:22:38 AM BGooijen
|
||||||
|
Added Listen(...)
|
||||||
|
|
||||||
|
Rev 1.1 5/14/2003 6:41:00 PM BGooijen
|
||||||
|
Added Bind(...)
|
||||||
|
|
||||||
|
Rev 1.0 12/2/2002 05:01:26 PM JPMugaas
|
||||||
|
Rechecked in due to file corruption.
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdCustomTransparentProxy;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
{$I IdCompilerDefines.inc}
|
||||||
|
//we need to put this in Delphi mode to work
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes,
|
||||||
|
IdComponent,
|
||||||
|
IdException,
|
||||||
|
IdGlobal,
|
||||||
|
IdIOHandler,
|
||||||
|
IdSocketHandle,
|
||||||
|
IdBaseComponent;
|
||||||
|
|
||||||
|
type
|
||||||
|
EIdTransparentProxyCircularLink = class(EIdException);
|
||||||
|
EIdTransparentProxyUDPNotSupported = class(EIdException);
|
||||||
|
|
||||||
|
TIdCustomTransparentProxyClass = class of TIdCustomTransparentProxy;
|
||||||
|
|
||||||
|
TIdCustomTransparentProxy = class(TIdComponent)
|
||||||
|
protected
|
||||||
|
FHost: String;
|
||||||
|
FPassword: String;
|
||||||
|
FPort: TIdPort;
|
||||||
|
FIPVersion : TIdIPVersion;
|
||||||
|
FUsername: String;
|
||||||
|
{$IFDEF USE_OBJECT_ARC}[Weak]{$ENDIF} FChainedProxy: TIdCustomTransparentProxy;
|
||||||
|
//
|
||||||
|
function GetEnabled: Boolean; virtual; abstract;
|
||||||
|
procedure SetEnabled(AValue: Boolean); virtual;
|
||||||
|
procedure MakeConnection(AIOHandler: TIdIOHandler; const AHost: string; const APort: TIdPort; const AIPVersion: TIdIPVersion = ID_DEFAULT_IP_VERSION); virtual; abstract;
|
||||||
|
{$IFNDEF USE_OBJECT_ARC}
|
||||||
|
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
|
||||||
|
{$ENDIF}
|
||||||
|
procedure SetChainedProxy(const AValue: TIdCustomTransparentProxy);
|
||||||
|
public
|
||||||
|
procedure Assign(ASource: TPersistent); override;
|
||||||
|
procedure OpenUDP(AHandle : TIdSocketHandle; const AHost: string = ''; const APort: TIdPort = 0; const AIPVersion: TIdIPVersion = ID_DEFAULT_IP_VERSION); virtual;
|
||||||
|
procedure CloseUDP(AHandle: TIdSocketHandle); virtual;
|
||||||
|
function RecvFromUDP(AHandle: TIdSocketHandle; var ABuffer : TIdBytes;
|
||||||
|
var VPeerIP: string; var VPeerPort: TIdPort; var VIPVersion: TIdIPVersion;
|
||||||
|
AMSec: Integer = IdTimeoutDefault): Integer; virtual;
|
||||||
|
procedure SendToUDP(AHandle: TIdSocketHandle;
|
||||||
|
const AHost: string; const APort: TIdPort; const AIPVersion: TIdIPVersion;
|
||||||
|
const ABuffer : TIdBytes); virtual;
|
||||||
|
procedure Connect(AIOHandler: TIdIOHandler; const AHost: string; const APort: TIdPort; const AIPVersion: TIdIPVersion = ID_DEFAULT_IP_VERSION);
|
||||||
|
//
|
||||||
|
procedure Bind(AIOHandler: TIdIOHandler; const AHost: string; const APort: TIdPort; const AIPVersion: TIdIPVersion = ID_DEFAULT_IP_VERSION);overload;virtual;
|
||||||
|
procedure Bind(AIOHandler: TIdIOHandler; const APort: TIdPort); overload;
|
||||||
|
function Listen(AIOHandler: TIdIOHandler; const ATimeOut: Integer): Boolean; virtual;
|
||||||
|
//
|
||||||
|
property Enabled: Boolean read GetEnabled write SetEnabled;
|
||||||
|
property Host: String read FHost write FHost;
|
||||||
|
property Password: String read FPassword write FPassword;
|
||||||
|
property Port: TIdPort read FPort write FPort;
|
||||||
|
property IPVersion : TIdIPVersion read FIPVersion write FIPVersion default ID_DEFAULT_IP_VERSION;
|
||||||
|
property Username: String read FUsername write FUsername;
|
||||||
|
property ChainedProxy: TIdCustomTransparentProxy read FChainedProxy write SetChainedProxy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
IdResourceStringsCore, IdExceptionCore;
|
||||||
|
|
||||||
|
{ TIdCustomTransparentProxy }
|
||||||
|
|
||||||
|
procedure TIdCustomTransparentProxy.Assign(ASource: TPersistent);
|
||||||
|
var
|
||||||
|
LSource: TIdCustomTransparentProxy;
|
||||||
|
Begin
|
||||||
|
if ASource is TIdCustomTransparentProxy then begin
|
||||||
|
LSource := TIdCustomTransparentProxy(ASource);
|
||||||
|
FHost := LSource.Host;
|
||||||
|
FPassword := LSource.Password;
|
||||||
|
FPort := LSource.Port;
|
||||||
|
FIPVersion := LSource.IPVersion;
|
||||||
|
FUsername := LSource.Username;
|
||||||
|
end else begin
|
||||||
|
inherited Assign(ASource);
|
||||||
|
end;
|
||||||
|
End;//
|
||||||
|
|
||||||
|
procedure TIdCustomTransparentProxy.Connect(AIOHandler: TIdIOHandler; const AHost: string; const APort: TIdPort; const AIPVersion: TIdIPVersion = ID_DEFAULT_IP_VERSION);
|
||||||
|
var
|
||||||
|
// under ARC, convert a weak reference to a strong reference before working with it
|
||||||
|
LChainedProxy: TIdCustomTransparentProxy;
|
||||||
|
begin
|
||||||
|
LChainedProxy := FChainedProxy;
|
||||||
|
if Assigned(LChainedProxy) and LChainedProxy.Enabled then begin
|
||||||
|
MakeConnection(AIOHandler, LChainedProxy.Host, LChainedProxy.Port);
|
||||||
|
LChainedProxy.Connect(AIOHandler, AHost, APort, AIPVersion);
|
||||||
|
end else begin
|
||||||
|
MakeConnection(AIOHandler, AHost, APort, AIPVersion);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdCustomTransparentProxy.Listen(AIOHandler: TIdIOHandler; const ATimeOut: integer):boolean;
|
||||||
|
begin
|
||||||
|
raise EIdTransparentProxyCantBind.Create(RSTransparentProxyCannotBind);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCustomTransparentProxy.Bind(AIOHandler: TIdIOHandler; const AHost: string; const APort: TIdPort; const AIPVersion: TIdIPVersion = ID_DEFAULT_IP_VERSION);
|
||||||
|
begin
|
||||||
|
raise EIdTransparentProxyCantBind.Create(RSTransparentProxyCannotBind);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCustomTransparentProxy.Bind(AIOHandler: TIdIOHandler; const APort: TIdPort);
|
||||||
|
begin
|
||||||
|
Bind(AIOHandler, '0.0.0.0', APort); {do not localize}
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCustomTransparentProxy.SetEnabled(AValue: Boolean);
|
||||||
|
Begin
|
||||||
|
End;
|
||||||
|
|
||||||
|
// under ARC, all weak references to a freed object get nil'ed automatically
|
||||||
|
{$IFNDEF USE_OBJECT_ARC}
|
||||||
|
procedure TIdCustomTransparentProxy.Notification(AComponent: TComponent; Operation: TOperation);
|
||||||
|
begin
|
||||||
|
if (Operation = opRemove) and (AComponent = FChainedProxy) then begin
|
||||||
|
FChainedProxy := nil;
|
||||||
|
end;
|
||||||
|
inherited Notification(AComponent,Operation);
|
||||||
|
end;
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
procedure TIdCustomTransparentProxy.SetChainedProxy(const AValue: TIdCustomTransparentProxy);
|
||||||
|
var
|
||||||
|
LNextValue: TIdCustomTransparentProxy;
|
||||||
|
// under ARC, convert a weak reference to a strong reference before working with it
|
||||||
|
LChainedProxy: TIdCustomTransparentProxy;
|
||||||
|
begin
|
||||||
|
LChainedProxy := FChainedProxy;
|
||||||
|
|
||||||
|
if LChainedProxy <> AValue then
|
||||||
|
begin
|
||||||
|
LNextValue := AValue;
|
||||||
|
while Assigned(LNextValue) do begin
|
||||||
|
if LNextValue = Self then begin
|
||||||
|
raise EIdTransparentProxyCircularLink.CreateFmt(RSInterceptCircularLink, [ClassName]);// -> One EIDCircularLink exception
|
||||||
|
end;
|
||||||
|
LNextValue := LNextValue.ChainedProxy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
// under ARC, all weak references to a freed object get nil'ed automatically
|
||||||
|
|
||||||
|
{$IFNDEF USE_OBJECT_ARC}
|
||||||
|
if Assigned(LChainedProxy) then begin
|
||||||
|
LChainedProxy.RemoveFreeNotification(Self);
|
||||||
|
end;
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
FChainedProxy := AValue;
|
||||||
|
|
||||||
|
{$IFNDEF USE_OBJECT_ARC}
|
||||||
|
if Assigned(AValue) then begin
|
||||||
|
AValue.FreeNotification(Self);
|
||||||
|
end;
|
||||||
|
{$ENDIF}
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCustomTransparentProxy.CloseUDP(AHandle: TIdSocketHandle);
|
||||||
|
begin
|
||||||
|
raise EIdTransparentProxyUDPNotSupported.Create(RSTransparentProxyCanNotSupportUDP);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCustomTransparentProxy.OpenUDP(AHandle: TIdSocketHandle;
|
||||||
|
const AHost: string = ''; const APort: TIdPort = 0;
|
||||||
|
const AIPVersion: TIdIPVersion = ID_DEFAULT_IP_VERSION);
|
||||||
|
begin
|
||||||
|
raise EIdTransparentProxyUDPNotSupported.Create(RSTransparentProxyCanNotSupportUDP);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdCustomTransparentProxy.RecvFromUDP(AHandle: TIdSocketHandle;
|
||||||
|
var ABuffer : TIdBytes; var VPeerIP: string; var VPeerPort: TIdPort;
|
||||||
|
var VIPVersion: TIdIPVersion; AMSec: Integer = IdTimeoutDefault): Integer;
|
||||||
|
begin
|
||||||
|
raise EIdTransparentProxyUDPNotSupported.Create(RSTransparentProxyCanNotSupportUDP);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCustomTransparentProxy.SendToUDP(AHandle: TIdSocketHandle;
|
||||||
|
const AHost: string; const APort: TIdPort; const AIPVersion: TIdIPVersion;
|
||||||
|
const ABuffer : TIdBytes);
|
||||||
|
begin
|
||||||
|
raise EIdTransparentProxyUDPNotSupported.Create(RSTransparentProxyCanNotSupportUDP);
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
||||||
|
|
|
@ -0,0 +1,4 @@
|
||||||
|
{$IFDEF DEPRECATED_IMPL_BUG}
|
||||||
|
{$WARN SYMBOL_DEPRECATED OFF}
|
||||||
|
{$ENDIF}
|
||||||
|
|
|
@ -0,0 +1,8 @@
|
||||||
|
{$IFDEF DEPRECATED_IMPL_BUG}
|
||||||
|
{$IFDEF HAS_DIRECTIVE_WARN_DEFAULT}
|
||||||
|
{$WARN SYMBOL_DEPRECATED DEFAULT}
|
||||||
|
{$ELSE}
|
||||||
|
{$WARN SYMBOL_DEPRECATED ON}
|
||||||
|
{$ENDIF}
|
||||||
|
{$ENDIF}
|
||||||
|
|
|
@ -0,0 +1,94 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.2 9/5/2004 2:08:16 PM JPMugaas
|
||||||
|
Should work in D9 NET.
|
||||||
|
|
||||||
|
Rev 1.1 2/3/2004 11:42:50 AM JPMugaas
|
||||||
|
Fixed for new design.
|
||||||
|
|
||||||
|
Rev 1.0 11/13/2002 08:43:16 AM JPMugaas
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdDsnBaseCmpEdt;
|
||||||
|
|
||||||
|
{$I IdCompilerDefines.inc}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
{$IFDEF DOTNET}
|
||||||
|
Borland.Vcl.Design.DesignIntF,
|
||||||
|
Borland.Vcl.Design.DesignEditors
|
||||||
|
{$ELSE}
|
||||||
|
{$IFDEF FPC}
|
||||||
|
ComponentEditors
|
||||||
|
{$ELSE}
|
||||||
|
{$IFDEF VCL_6_OR_ABOVE}
|
||||||
|
DesignIntf,
|
||||||
|
DesignEditors
|
||||||
|
{$ELSE}
|
||||||
|
Dsgnintf
|
||||||
|
{$ENDIF}
|
||||||
|
{$ENDIF}
|
||||||
|
{$ENDIF}
|
||||||
|
;
|
||||||
|
|
||||||
|
type
|
||||||
|
{$IFDEF FPC}
|
||||||
|
TIdBaseComponentEditor = class(TDefaultComponentEditor)
|
||||||
|
{$ELSE}
|
||||||
|
TIdBaseComponentEditor = class(TDefaultEditor)
|
||||||
|
{$ENDIF}
|
||||||
|
public
|
||||||
|
procedure ExecuteVerb(Index: Integer); override;
|
||||||
|
function GetVerb(Index: Integer): string; override;
|
||||||
|
function GetVerbCount: Integer; override;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
IdAbout,
|
||||||
|
IdGlobal,
|
||||||
|
IdDsnCoreResourceStrings,
|
||||||
|
SysUtils;
|
||||||
|
|
||||||
|
{ TIdBaseComponentEditor }
|
||||||
|
|
||||||
|
procedure TIdBaseComponentEditor.ExecuteVerb(Index: Integer);
|
||||||
|
begin
|
||||||
|
case Index of
|
||||||
|
0 : ShowAboutBox(RSAAboutBoxCompName, gsIdVersion);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdBaseComponentEditor.GetVerb(Index: Integer): string;
|
||||||
|
begin
|
||||||
|
case Index of
|
||||||
|
0: Result := IndyFormat(RSAAboutMenuItemName, [gsIdVersion]);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdBaseComponentEditor.GetVerbCount: Integer;
|
||||||
|
begin
|
||||||
|
Result := 1;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
||||||
|
|
|
@ -0,0 +1,134 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.5 1/29/2004 8:54:30 AM JPMugaas
|
||||||
|
Removed myself from the distribution Team Chairperson entry as I am resigning
|
||||||
|
from that role.
|
||||||
|
|
||||||
|
Rev 1.4 10/15/2003 10:11:46 PM DSiders
|
||||||
|
Added resource string for About box credits.
|
||||||
|
Corrected spelling error in comments.
|
||||||
|
|
||||||
|
Rev 1.3 6/16/2003 12:01:44 PM JPMugaas
|
||||||
|
Updated copyright to say 2003.
|
||||||
|
|
||||||
|
Rev 1.2 6/8/2003 05:46:58 AM JPMugaas
|
||||||
|
The kitchen sink has now been implemented.
|
||||||
|
|
||||||
|
Rev 1.1 1/15/2003 08:03:56 AM JPMugaas
|
||||||
|
Updated with new website address.
|
||||||
|
|
||||||
|
Rev 1.0 11/13/2002 08:43:24 AM JPMugaas
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdDsnCoreResourceStrings;
|
||||||
|
|
||||||
|
{
|
||||||
|
Note: This unit is for resource strings that are used in the Core Design-Time
|
||||||
|
package and NOT any design-time packages. This is to prevent design-time
|
||||||
|
resource strings from being linked into the Run-Time only package.
|
||||||
|
}
|
||||||
|
|
||||||
|
interface
|
||||||
|
{$I IdCompilerDefines.inc}
|
||||||
|
|
||||||
|
const
|
||||||
|
IndyPitCrew = 'Kudzu (Chad Z. Hower)'#13#10
|
||||||
|
+ 'and the Indy Pit Crew';
|
||||||
|
|
||||||
|
resourcestring
|
||||||
|
{ About Box stuff }
|
||||||
|
RSAAboutFormCaption = 'About';
|
||||||
|
RSAAboutBoxCompName = 'Internet Direct (Indy)';
|
||||||
|
RSAAboutMenuItemName = 'About Internet &Direct (Indy) %s...';
|
||||||
|
|
||||||
|
RSAAboutBoxVersion = 'Version %s';
|
||||||
|
RSAAboutBoxCopyright = 'Copyright (c) 1993 - 2015'#13#10
|
||||||
|
+ IndyPitCrew;
|
||||||
|
RSAAboutBoxTitle1 = 'INDY';
|
||||||
|
RSAAboutBoxTitle2 = 'Internet Direct';
|
||||||
|
RSAAboutBoxLicences = 'Indy Modified BSD License'+#13#10+'Indy MPL License';
|
||||||
|
RSAAboutBoxBuiltFor = 'Indy.Sockets (%s)';
|
||||||
|
|
||||||
|
RSAAboutBoxPleaseVisit = 'For the latest updates and information please visit:';
|
||||||
|
RSAAboutBoxIndyWebsite = 'http://www.indyproject.org/'; {Do not Localize}
|
||||||
|
|
||||||
|
RSAAboutCreditsCoordinator = 'Project Coordinator';
|
||||||
|
RSAAboutCreditsCoCordinator = 'Project Co-Coordinator';
|
||||||
|
RSAAboutCreditsDocumentation = 'Documentation Coordinator';
|
||||||
|
RSAAboutCreditsDemos = 'Demos Coordinator';
|
||||||
|
RSAAboutCreditsRetiredPast = 'Retired/Past Contributors';
|
||||||
|
RSAAboutCreditsIndyCrew = 'The Indy Pit Crew';
|
||||||
|
|
||||||
|
RSAAboutKitchenSink = IndyPitCrew+#10#13+'present the'#10#13'Kitchen Sink';
|
||||||
|
|
||||||
|
{Binding Editor stuff}
|
||||||
|
{
|
||||||
|
Note to translators - Please Read!!!
|
||||||
|
|
||||||
|
For all the constants except RSBindingFormCaption, there may be an
|
||||||
|
& symbol before a letter or number. This is rendered as that character being
|
||||||
|
underlined. In addition, the character after the & symbol along with the ALT
|
||||||
|
key enables a user to move to that control. Since these are on one form, be
|
||||||
|
careful to ensure that the same letter or number does not have a & before it
|
||||||
|
in more than one string, otherwise an ALT key sequence will be broken.
|
||||||
|
}
|
||||||
|
RSBindingFormCaption = 'Binding Editor';
|
||||||
|
RSBindingNewCaption = '&New';
|
||||||
|
RSBindingDeleteCaption = '&Delete';
|
||||||
|
//RSBindingAddCaption = '&Add';
|
||||||
|
RSBindingRemoveCaption = '&Remove';
|
||||||
|
RSBindingLabelBindings = '&Bindings';
|
||||||
|
RSBindingHostnameLabel = '&IP Address';
|
||||||
|
RSBindingPortLabel = '&Port';
|
||||||
|
RSBindingIPVerLabel = 'IP &Version';
|
||||||
|
RSBindingIPV4Item = 'IPv&4 (127.0.0.1)';
|
||||||
|
RSBindingIPV6Item = 'IPv&6 (::1)';
|
||||||
|
{Design time SASLList Hints}
|
||||||
|
RSADlgSLMoveUp = 'Move Up';
|
||||||
|
RSADlgSLMoveDown = 'Move Down';
|
||||||
|
RSADlgSLAdd = 'Add';
|
||||||
|
RSADlgSLRemove = 'Remove';
|
||||||
|
//Caption that uses format with component name
|
||||||
|
RSADlgSLCaption = 'Editing SASL List for %s';
|
||||||
|
RSADlgSLAvailable = '&Available';
|
||||||
|
RSADlgSLAssigned = 'A&ssigned (tried in order listed)';
|
||||||
|
{Note that the Ampersand indicates an ALT keyboard sequence}
|
||||||
|
RSADlgSLEditList = 'Edit &List';
|
||||||
|
//Display item constants
|
||||||
|
RSBindingAll = 'All'; //all IP addresses
|
||||||
|
RSBindingAny = 'Any'; //any port
|
||||||
|
|
||||||
|
{Standard dialog stock strings}
|
||||||
|
RSOk = 'OK';
|
||||||
|
RSCancel = 'Cancel';
|
||||||
|
RSHelp = '&Help';
|
||||||
|
|
||||||
|
// IdRegister
|
||||||
|
RSRegIndyClients = 'Indy Clients';
|
||||||
|
RSRegIndyServers = 'Indy Servers';
|
||||||
|
RSRegIndyIntercepts = 'Indy Intercepts';
|
||||||
|
RSRegIndyIOHandlers = 'Indy I/O Handlers';
|
||||||
|
RSRegIndyMisc = 'Indy Misc';
|
||||||
|
{$IFDEF FPC}
|
||||||
|
CoreSuffix = ' - Core';
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
end.
|
|
@ -0,0 +1,143 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.9 10/26/2004 8:45:26 PM JPMugaas
|
||||||
|
Should compile.
|
||||||
|
|
||||||
|
Rev 1.8 10/26/2004 8:42:58 PM JPMugaas
|
||||||
|
Should be more portable with new references to TIdStrings and TIdStringList.
|
||||||
|
|
||||||
|
Rev 1.7 5/19/2004 10:44:28 PM DSiders
|
||||||
|
Corrected spelling for TIdIPAddress.MakeAddressObject method.
|
||||||
|
|
||||||
|
Rev 1.6 2/3/2004 11:34:26 AM JPMugaas
|
||||||
|
Should compile.
|
||||||
|
|
||||||
|
Rev 1.5.1.0 2/3/2004 11:32:26 AM JPMugaas
|
||||||
|
Should compile.
|
||||||
|
|
||||||
|
Rev 1.5 2/1/2004 2:44:20 AM JPMugaas
|
||||||
|
Bindings editor should be fully functional including IPv6 support.
|
||||||
|
|
||||||
|
Rev 1.4 2/1/2004 1:03:34 AM JPMugaas
|
||||||
|
This now work properly in both Win32 and DotNET. The behavior had to change
|
||||||
|
in DotNET because of some missing functionality and because implementing that
|
||||||
|
functionality creates more problems than it would solve.
|
||||||
|
|
||||||
|
Rev 1.3 2003.12.31 10:42:22 PM czhower
|
||||||
|
Warning removed
|
||||||
|
|
||||||
|
Rev 1.2 10/15/2003 10:12:32 PM DSiders
|
||||||
|
Added localization comments.
|
||||||
|
|
||||||
|
Rev 1.1 2003.10.11 5:47:46 PM czhower
|
||||||
|
-VCL fixes for servers
|
||||||
|
-Chain suport for servers (Super core)
|
||||||
|
-Scheduler upgrades
|
||||||
|
-Full yarn support
|
||||||
|
|
||||||
|
Rev 1.0 11/13/2002 08:43:58 AM JPMugaas
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdDsnPropEdBinding;
|
||||||
|
|
||||||
|
{
|
||||||
|
Design Note: It turns out that in DotNET, there are no services file functions and
|
||||||
|
IdPorts does not work as expected in DotNET. It is probably possible to read the
|
||||||
|
services file ourselves but that creates some portability problems as the placement
|
||||||
|
is different in every operating system.
|
||||||
|
|
||||||
|
e.g.
|
||||||
|
|
||||||
|
Linux and Unix-like systems - /etc
|
||||||
|
Windows 95, 98, and ME - c:\windows
|
||||||
|
Windows NT systems - c:\winnt\system32\drivers\etc
|
||||||
|
|
||||||
|
Thus, it will undercut whatever benefit we could get with DotNET.
|
||||||
|
|
||||||
|
About the best I could think of is to use an edit control because
|
||||||
|
we can't offer anything from the services file in DotNET.
|
||||||
|
|
||||||
|
TODO: Maybe there might be a way to find the location in a more elegant
|
||||||
|
manner than what I described.
|
||||||
|
}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
{$I IdCompilerDefines.inc}
|
||||||
|
|
||||||
|
{$IFDEF WIDGET_WINFORMS}
|
||||||
|
{$R 'IdDsnPropEdBindingNET.TIdDsnPropEdBindingNET.resources' 'IdDsnPropEdBindingNET.resx'}
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes,
|
||||||
|
IdSocketHandle;
|
||||||
|
|
||||||
|
{
|
||||||
|
Design Note: It turns out that in DotNET, there are no services file functions and IdPorts
|
||||||
|
does not work as expected in DotNET. It is probably possible to read the services
|
||||||
|
file ourselves but that creates some portability problems as the placement is different
|
||||||
|
in every operating system.
|
||||||
|
|
||||||
|
e.g.
|
||||||
|
|
||||||
|
Linux and Unix-like systems - /etc
|
||||||
|
Windows 95, 98, and ME - c:\windows
|
||||||
|
Windows NT systems - c:\winnt\system32\drivers\etc
|
||||||
|
|
||||||
|
Thus, it will undercut whatever benefit we could get with DotNET.
|
||||||
|
|
||||||
|
About the best I could think of is to use an edit control because
|
||||||
|
we can't offer anything from the services file in DotNET.
|
||||||
|
|
||||||
|
TODO: Maybe there might be a way to find the location in a more eligant
|
||||||
|
manner than what I described.
|
||||||
|
}
|
||||||
|
|
||||||
|
procedure FillHandleList(const AList: string; ADest: TIdSocketHandles);
|
||||||
|
function GetListValues(const ASocketHandles : TIdSocketHandles) : String;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
{$IFDEF WIDGET_WINFORMS}
|
||||||
|
IdDsnPropEdBindingNET;
|
||||||
|
{$ELSE}
|
||||||
|
IdDsnPropEdBindingVCL;
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
procedure FillHandleList(const AList: string; ADest: TIdSocketHandles);
|
||||||
|
begin
|
||||||
|
{$IFDEF WIDGET_WINFORMS}
|
||||||
|
IdDsnPropEdBindingNET.FillHandleList(AList,ADest);
|
||||||
|
{$ELSE}
|
||||||
|
IdDsnPropEdBindingVCL.FillHandleList(AList,ADest);
|
||||||
|
{$ENDIF}
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetListValues(const ASocketHandles : TIdSocketHandles) : String;
|
||||||
|
begin
|
||||||
|
{$IFDEF WIDGET_WINFORMS}
|
||||||
|
Result := IdDsnPropEdBindingNET.GetListValues(ASocketHandles);
|
||||||
|
{$ELSE}
|
||||||
|
Result := IdDsnPropEdBindingVCL.GetListValues(ASocketHandles);
|
||||||
|
{$ENDIF}
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
|
@ -0,0 +1,702 @@
|
||||||
|
unit IdDsnPropEdBindingNET;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes,
|
||||||
|
System.Drawing, System.Collections, System.ComponentModel,
|
||||||
|
System.Windows.Forms, System.Data, IdSocketHandle;
|
||||||
|
|
||||||
|
type
|
||||||
|
TIdDsnPropEdBindingNET = class(System.Windows.Forms.Form)
|
||||||
|
{$REGION 'Designer Managed Code'}
|
||||||
|
strict private
|
||||||
|
/// <summary>
|
||||||
|
/// Required designer variable.
|
||||||
|
/// </summary>
|
||||||
|
Components: System.ComponentModel.Container;
|
||||||
|
btnOk: System.Windows.Forms.Button;
|
||||||
|
btnCancel: System.Windows.Forms.Button;
|
||||||
|
lblBindings: System.Windows.Forms.Label;
|
||||||
|
lbBindings: System.Windows.Forms.ListBox;
|
||||||
|
btnNew: System.Windows.Forms.Button;
|
||||||
|
btnDelete: System.Windows.Forms.Button;
|
||||||
|
lblIPAddress: System.Windows.Forms.Label;
|
||||||
|
edtIPAddress: System.Windows.Forms.ComboBox;
|
||||||
|
lblPort: System.Windows.Forms.Label;
|
||||||
|
edtPort: System.Windows.Forms.NumericUpDown;
|
||||||
|
cboIPVersion: System.Windows.Forms.ComboBox;
|
||||||
|
lblIPVersion: System.Windows.Forms.Label;
|
||||||
|
/// <summary>
|
||||||
|
/// Required method for Designer support - do not modify
|
||||||
|
/// the contents of this method with the code editor.
|
||||||
|
/// </summary>
|
||||||
|
procedure InitializeComponent;
|
||||||
|
procedure btnNew_Click(sender: System.Object; e: System.EventArgs);
|
||||||
|
procedure btnDelete_Click(sender: System.Object; e: System.EventArgs);
|
||||||
|
procedure edtPort_ValueChanged(sender: System.Object; e: System.EventArgs);
|
||||||
|
procedure edtIPAddress_SelectedValueChanged(sender: System.Object; e: System.EventArgs);
|
||||||
|
procedure cboIPVersion_SelectedValueChanged(sender: System.Object; e: System.EventArgs);
|
||||||
|
procedure lbBindings_SelectedValueChanged(sender: System.Object; e: System.EventArgs);
|
||||||
|
{$ENDREGION}
|
||||||
|
strict protected
|
||||||
|
/// <summary>
|
||||||
|
/// Clean up any resources being used.
|
||||||
|
/// </summary>
|
||||||
|
procedure Dispose(Disposing: Boolean); override;
|
||||||
|
private
|
||||||
|
FHandles : TIdSocketHandles;
|
||||||
|
FDefaultPort : Integer;
|
||||||
|
FIPv4Addresses : TStrings;
|
||||||
|
FIPv6Addresses : TStrings;
|
||||||
|
FCurrentHandle : TIdSocketHandle;
|
||||||
|
|
||||||
|
{ Private Declarations }
|
||||||
|
procedure SetHandles(const Value: TIdSocketHandles);
|
||||||
|
procedure SetIPv4Addresses(const Value: TStrings);
|
||||||
|
procedure SetIPv6Addresses(const Value: TStrings);
|
||||||
|
procedure UpdateBindingList;
|
||||||
|
procedure UpdateEditControls;
|
||||||
|
procedure FillComboBox(ACombo : System.Windows.Forms.ComboBox; AStrings :TStrings);
|
||||||
|
procedure SetCaption(const AValue : String);
|
||||||
|
function GetCaption : String;
|
||||||
|
public
|
||||||
|
constructor Create;
|
||||||
|
function Execute : Boolean;
|
||||||
|
function GetList: string;
|
||||||
|
procedure SetList(const AList: string);
|
||||||
|
property Handles : TIdSocketHandles read FHandles write SetHandles;
|
||||||
|
property DefaultPort : Integer read FDefaultPort write FDefaultPort;
|
||||||
|
property IPv4Addresses : TStrings read FIPv4Addresses write SetIPv4Addresses;
|
||||||
|
property IPv6Addresses : TStrings read FIPv6Addresses write SetIPv6Addresses;
|
||||||
|
property Caption : String read GetCaption write SetCaption;
|
||||||
|
end;
|
||||||
|
|
||||||
|
[assembly: RuntimeRequiredAttribute(TypeOf(TIdDsnPropEdBindingNET))]
|
||||||
|
|
||||||
|
procedure FillHandleList(const AList: string; ADest: TIdSocketHandles);
|
||||||
|
function GetListValues(const ASocketHandles : TIdSocketHandles) : String;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
uses
|
||||||
|
IdGlobal,
|
||||||
|
IdIPAddress,
|
||||||
|
IdDsnCoreResourceStrings, IdStack, SysUtils;
|
||||||
|
|
||||||
|
const
|
||||||
|
IPv6Wildcard1 = '::'; {do not localize}
|
||||||
|
IPv6Wildcard2 = '0:0:0:0:0:0:0:0'; {do not localize}
|
||||||
|
IPv6Loopback = '::1'; {do not localize}
|
||||||
|
IPv4Wildcard = '0.0.0.0'; {do not localize}
|
||||||
|
IPv4Loopback = '127.0.0.1'; {do not localize}
|
||||||
|
|
||||||
|
function IsValidIP(const AAddr : String): Boolean;
|
||||||
|
var
|
||||||
|
LIP: TIdIPAddress;
|
||||||
|
begin
|
||||||
|
LIP := TIdIPAddress.MakeAddressObject(AAddr);
|
||||||
|
Result := Assigned(LIP);
|
||||||
|
if Result then
|
||||||
|
begin
|
||||||
|
FreeAndNil(LIP);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function StripAndSymbol(s : String) : String;
|
||||||
|
begin
|
||||||
|
Result := '';
|
||||||
|
repeat
|
||||||
|
if s='' then
|
||||||
|
begin
|
||||||
|
Break;
|
||||||
|
end;
|
||||||
|
Result := Result + Fetch(s,'&');
|
||||||
|
until False;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure FillHandleList(const AList: string; ADest: TIdSocketHandles);
|
||||||
|
var
|
||||||
|
LItems: TStringList;
|
||||||
|
i: integer;
|
||||||
|
LIPVersion: TIdIPVersion;
|
||||||
|
LAddr, LText: string;
|
||||||
|
LPort: integer;
|
||||||
|
begin
|
||||||
|
ADest.Clear;
|
||||||
|
LItems := TStringList.Create;
|
||||||
|
try
|
||||||
|
LItems.CommaText := AList;
|
||||||
|
for i := 0 to LItems.Count-1 do begin
|
||||||
|
if Length(LItems[i]) > 0 then begin
|
||||||
|
if TextStartsWith(LItems[i], '[') then begin
|
||||||
|
// ipv6
|
||||||
|
LIPVersion := Id_IPv6;
|
||||||
|
LText := Copy(LItems[i], 2, MaxInt);
|
||||||
|
LAddr := Fetch(LText, ']:');
|
||||||
|
LPort := IndyStrToInt(LText, -1);
|
||||||
|
end else begin
|
||||||
|
// ipv4
|
||||||
|
LIPVersion := Id_IPv4;
|
||||||
|
LText := LItems[i];
|
||||||
|
LAddr := Fetch(LText, ':');
|
||||||
|
LPort := IndyStrToInt(LText, -1);
|
||||||
|
//Note that 0 is legal and indicates the server binds to a random port
|
||||||
|
end;
|
||||||
|
if IsValidIP(LAddr) and (LPort > -1) and (LPort < 65536) then begin
|
||||||
|
with ADest.Add do begin
|
||||||
|
IPVersion := LIPVersion;
|
||||||
|
IP := LAddr;
|
||||||
|
Port := LPort;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
LItems.Free;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function NumericOnly(const AText : String) : String;
|
||||||
|
var
|
||||||
|
i: Integer;
|
||||||
|
begin
|
||||||
|
Result := '';
|
||||||
|
for i := 1 to Length(AText) do
|
||||||
|
begin
|
||||||
|
if IsNumeric(AText[i]) then
|
||||||
|
begin
|
||||||
|
Result := Result + AText[i];
|
||||||
|
end
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
Break;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
if (Length(Result) = 0) then
|
||||||
|
begin
|
||||||
|
Result := '0';
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function IndexOfNo(const ANo : Integer; AItems : System.Windows.Forms.ComboBox.ObjectCollection) : Integer;
|
||||||
|
begin
|
||||||
|
for Result := 0 to AItems.Count -1 do
|
||||||
|
begin
|
||||||
|
if ANo = IndyStrToInt( NumericOnly(AItems[Result].ToString )) then
|
||||||
|
begin
|
||||||
|
Exit;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
Result := -1;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetDisplayString(ASocketHandle: TIdSocketHandle): string;
|
||||||
|
begin
|
||||||
|
Result := '';
|
||||||
|
case ASocketHandle.IPVersion of
|
||||||
|
Id_IPv4 : Result := IndyFormat('%s:%d', [ASocketHandle.IP, ASocketHandle.Port]);
|
||||||
|
Id_IPv6 : Result := IndyFormat('[%s]:%d', [ASocketHandle.IP, ASocketHandle.Port]);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetListValues(const ASocketHandles : TIdSocketHandles) : String;
|
||||||
|
var
|
||||||
|
i: Integer;
|
||||||
|
begin
|
||||||
|
Result := '';
|
||||||
|
for i := 0 to ASocketHandles.Count -1 do begin
|
||||||
|
Result := Result + ',' + GetDisplayString(ASocketHandles[i]);
|
||||||
|
end;
|
||||||
|
Delete(Result,1,1);
|
||||||
|
end;
|
||||||
|
|
||||||
|
{$AUTOBOX ON}
|
||||||
|
|
||||||
|
{$REGION 'Windows Form Designer generated code'}
|
||||||
|
/// <summary>
|
||||||
|
/// Required method for Designer support -- do not modify
|
||||||
|
/// the contents of this method with the code editor.
|
||||||
|
/// </summary>
|
||||||
|
procedure TIdDsnPropEdBindingNET.InitializeComponent;
|
||||||
|
type
|
||||||
|
TArrayOfInteger = array of Integer;
|
||||||
|
begin
|
||||||
|
Self.btnOk := System.Windows.Forms.Button.Create;
|
||||||
|
Self.btnCancel := System.Windows.Forms.Button.Create;
|
||||||
|
Self.lblBindings := System.Windows.Forms.Label.Create;
|
||||||
|
Self.lbBindings := System.Windows.Forms.ListBox.Create;
|
||||||
|
Self.btnNew := System.Windows.Forms.Button.Create;
|
||||||
|
Self.btnDelete := System.Windows.Forms.Button.Create;
|
||||||
|
Self.lblIPAddress := System.Windows.Forms.Label.Create;
|
||||||
|
Self.edtIPAddress := System.Windows.Forms.ComboBox.Create;
|
||||||
|
Self.lblPort := System.Windows.Forms.Label.Create;
|
||||||
|
Self.edtPort := System.Windows.Forms.NumericUpDown.Create;
|
||||||
|
Self.cboIPVersion := System.Windows.Forms.ComboBox.Create;
|
||||||
|
Self.lblIPVersion := System.Windows.Forms.Label.Create;
|
||||||
|
(System.ComponentModel.ISupportInitialize(Self.edtPort)).BeginInit;
|
||||||
|
Self.SuspendLayout;
|
||||||
|
//
|
||||||
|
// btnOk
|
||||||
|
//
|
||||||
|
Self.btnOk.Anchor := (System.Windows.Forms.AnchorStyles((System.Windows.Forms.AnchorStyles.Bottom
|
||||||
|
or System.Windows.Forms.AnchorStyles.Right)));
|
||||||
|
Self.btnOk.DialogResult := System.Windows.Forms.DialogResult.OK;
|
||||||
|
Self.btnOk.Location := System.Drawing.Point.Create(312, 160);
|
||||||
|
Self.btnOk.Name := 'btnOk';
|
||||||
|
Self.btnOk.TabIndex := 0;
|
||||||
|
//
|
||||||
|
// btnCancel
|
||||||
|
//
|
||||||
|
Self.btnCancel.Anchor := (System.Windows.Forms.AnchorStyles((System.Windows.Forms.AnchorStyles.Bottom
|
||||||
|
or System.Windows.Forms.AnchorStyles.Right)));
|
||||||
|
Self.btnCancel.DialogResult := System.Windows.Forms.DialogResult.Cancel;
|
||||||
|
Self.btnCancel.Location := System.Drawing.Point.Create(392, 160);
|
||||||
|
Self.btnCancel.Name := 'btnCancel';
|
||||||
|
Self.btnCancel.TabIndex := 1;
|
||||||
|
//
|
||||||
|
// lblBindings
|
||||||
|
//
|
||||||
|
Self.lblBindings.AutoSize := True;
|
||||||
|
Self.lblBindings.Location := System.Drawing.Point.Create(8, 8);
|
||||||
|
Self.lblBindings.Name := 'lblBindings';
|
||||||
|
Self.lblBindings.Size := System.Drawing.Size.Create(42, 16);
|
||||||
|
Self.lblBindings.TabIndex := 2;
|
||||||
|
Self.lblBindings.Text := '&Binding';
|
||||||
|
//
|
||||||
|
// lbBindings
|
||||||
|
//
|
||||||
|
Self.lbBindings.Anchor := (System.Windows.Forms.AnchorStyles(((System.Windows.Forms.AnchorStyles.Top
|
||||||
|
or System.Windows.Forms.AnchorStyles.Bottom) or System.Windows.Forms.AnchorStyles.Left)));
|
||||||
|
Self.lbBindings.Location := System.Drawing.Point.Create(8, 24);
|
||||||
|
Self.lbBindings.Name := 'lbBindings';
|
||||||
|
Self.lbBindings.Size := System.Drawing.Size.Create(137, 121);
|
||||||
|
Self.lbBindings.TabIndex := 3;
|
||||||
|
Include(Self.lbBindings.SelectedValueChanged, Self.lbBindings_SelectedValueChanged);
|
||||||
|
//
|
||||||
|
// btnNew
|
||||||
|
//
|
||||||
|
Self.btnNew.Location := System.Drawing.Point.Create(152, 56);
|
||||||
|
Self.btnNew.Name := 'btnNew';
|
||||||
|
Self.btnNew.TabIndex := 4;
|
||||||
|
Include(Self.btnNew.Click, Self.btnNew_Click);
|
||||||
|
//
|
||||||
|
// btnDelete
|
||||||
|
//
|
||||||
|
Self.btnDelete.Location := System.Drawing.Point.Create(152, 88);
|
||||||
|
Self.btnDelete.Name := 'btnDelete';
|
||||||
|
Self.btnDelete.TabIndex := 5;
|
||||||
|
Include(Self.btnDelete.Click, Self.btnDelete_Click);
|
||||||
|
//
|
||||||
|
// lblIPAddress
|
||||||
|
//
|
||||||
|
Self.lblIPAddress.Location := System.Drawing.Point.Create(240, 8);
|
||||||
|
Self.lblIPAddress.Name := 'lblIPAddress';
|
||||||
|
Self.lblIPAddress.Size := System.Drawing.Size.Create(100, 16);
|
||||||
|
Self.lblIPAddress.TabIndex := 6;
|
||||||
|
Self.lblIPAddress.Text := 'Label1';
|
||||||
|
//
|
||||||
|
// edtIPAddress
|
||||||
|
//
|
||||||
|
Self.edtIPAddress.Anchor := (System.Windows.Forms.AnchorStyles(((System.Windows.Forms.AnchorStyles.Top
|
||||||
|
or System.Windows.Forms.AnchorStyles.Left) or System.Windows.Forms.AnchorStyles.Right)));
|
||||||
|
Self.edtIPAddress.Location := System.Drawing.Point.Create(240, 24);
|
||||||
|
Self.edtIPAddress.Name := 'edtIPAddress';
|
||||||
|
Self.edtIPAddress.Size := System.Drawing.Size.Create(224, 21);
|
||||||
|
Self.edtIPAddress.TabIndex := 7;
|
||||||
|
Include(Self.edtIPAddress.SelectedValueChanged, Self.edtIPAddress_SelectedValueChanged);
|
||||||
|
//
|
||||||
|
// lblPort
|
||||||
|
//
|
||||||
|
Self.lblPort.Location := System.Drawing.Point.Create(240, 58);
|
||||||
|
Self.lblPort.Name := 'lblPort';
|
||||||
|
Self.lblPort.Size := System.Drawing.Size.Create(100, 16);
|
||||||
|
Self.lblPort.TabIndex := 8;
|
||||||
|
Self.lblPort.Text := 'Label1';
|
||||||
|
//
|
||||||
|
// edtPort
|
||||||
|
//
|
||||||
|
Self.edtPort.Anchor := (System.Windows.Forms.AnchorStyles(((System.Windows.Forms.AnchorStyles.Top
|
||||||
|
or System.Windows.Forms.AnchorStyles.Left) or System.Windows.Forms.AnchorStyles.Right)));
|
||||||
|
Self.edtPort.Location := System.Drawing.Point.Create(240, 74);
|
||||||
|
Self.edtPort.Maximum := System.Decimal.Create(TArrayOfInteger.Create(65535,
|
||||||
|
0, 0, 0));
|
||||||
|
Self.edtPort.Name := 'edtPort';
|
||||||
|
Self.edtPort.Size := System.Drawing.Size.Create(224, 20);
|
||||||
|
Self.edtPort.TabIndex := 9;
|
||||||
|
Include(Self.edtPort.ValueChanged, Self.edtPort_ValueChanged);
|
||||||
|
//
|
||||||
|
// cboIPVersion
|
||||||
|
//
|
||||||
|
Self.cboIPVersion.DropDownStyle := System.Windows.Forms.ComboBoxStyle.DropDownList;
|
||||||
|
Self.cboIPVersion.Location := System.Drawing.Point.Create(240, 124);
|
||||||
|
Self.cboIPVersion.Name := 'cboIPVersion';
|
||||||
|
Self.cboIPVersion.Size := System.Drawing.Size.Create(224, 21);
|
||||||
|
Self.cboIPVersion.TabIndex := 10;
|
||||||
|
Include(Self.cboIPVersion.SelectedValueChanged, Self.cboIPVersion_SelectedValueChanged);
|
||||||
|
//
|
||||||
|
// lblIPVersion
|
||||||
|
//
|
||||||
|
Self.lblIPVersion.Location := System.Drawing.Point.Create(240, 108);
|
||||||
|
Self.lblIPVersion.Name := 'lblIPVersion';
|
||||||
|
Self.lblIPVersion.Size := System.Drawing.Size.Create(100, 16);
|
||||||
|
Self.lblIPVersion.TabIndex := 11;
|
||||||
|
Self.lblIPVersion.Text := 'Label1';
|
||||||
|
//
|
||||||
|
// TIdDsnPropEdBindingNET
|
||||||
|
//
|
||||||
|
Self.AcceptButton := Self.btnOk;
|
||||||
|
Self.AutoScaleBaseSize := System.Drawing.Size.Create(5, 13);
|
||||||
|
Self.CancelButton := Self.btnCancel;
|
||||||
|
Self.ClientSize := System.Drawing.Size.Create(470, 189);
|
||||||
|
Self.Controls.Add(Self.lblIPVersion);
|
||||||
|
Self.Controls.Add(Self.cboIPVersion);
|
||||||
|
Self.Controls.Add(Self.edtPort);
|
||||||
|
Self.Controls.Add(Self.lblPort);
|
||||||
|
Self.Controls.Add(Self.edtIPAddress);
|
||||||
|
Self.Controls.Add(Self.lblIPAddress);
|
||||||
|
Self.Controls.Add(Self.btnDelete);
|
||||||
|
Self.Controls.Add(Self.btnNew);
|
||||||
|
Self.Controls.Add(Self.lbBindings);
|
||||||
|
Self.Controls.Add(Self.lblBindings);
|
||||||
|
Self.Controls.Add(Self.btnCancel);
|
||||||
|
Self.Controls.Add(Self.btnOk);
|
||||||
|
Self.FormBorderStyle := System.Windows.Forms.FormBorderStyle.FixedDialog;
|
||||||
|
Self.MaximizeBox := False;
|
||||||
|
Self.MaximumSize := System.Drawing.Size.Create(480, 225);
|
||||||
|
Self.MinimizeBox := False;
|
||||||
|
Self.MinimumSize := System.Drawing.Size.Create(480, 225);
|
||||||
|
Self.Name := 'TIdDsnPropEdBindingNET';
|
||||||
|
Self.ShowInTaskbar := False;
|
||||||
|
Self.StartPosition := System.Windows.Forms.FormStartPosition.CenterScreen;
|
||||||
|
Self.Text := 'WinForm';
|
||||||
|
(System.ComponentModel.ISupportInitialize(Self.edtPort)).EndInit;
|
||||||
|
Self.ResumeLayout(False);
|
||||||
|
end;
|
||||||
|
{$ENDREGION}
|
||||||
|
|
||||||
|
procedure TIdDsnPropEdBindingNET.Dispose(Disposing: Boolean);
|
||||||
|
begin
|
||||||
|
if Disposing then
|
||||||
|
begin
|
||||||
|
if Components <> nil then
|
||||||
|
begin
|
||||||
|
Components.Dispose();
|
||||||
|
FreeAndNil(FHandles);
|
||||||
|
|
||||||
|
FreeAndNil(FIPv4Addresses);
|
||||||
|
FreeAndNil(FIPv6Addresses);
|
||||||
|
|
||||||
|
//don't free FCurrentHandle; - it's in the handles collection
|
||||||
|
TIdStack.DecUsage;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
inherited Dispose(Disposing);
|
||||||
|
|
||||||
|
end;
|
||||||
|
|
||||||
|
constructor TIdDsnPropEdBindingNET.Create;
|
||||||
|
var
|
||||||
|
i: Integer;
|
||||||
|
LLocalAddresses: TIdStackLocalAddressList;
|
||||||
|
begin
|
||||||
|
inherited Create;
|
||||||
|
//
|
||||||
|
// Required for Windows Form Designer support
|
||||||
|
//
|
||||||
|
InitializeComponent;
|
||||||
|
//
|
||||||
|
// TODO: Add any constructor code after InitializeComponent call
|
||||||
|
//
|
||||||
|
FHandles := TIdSocketHandles.Create(nil);
|
||||||
|
FIPv4Addresses := TStringList.Create;
|
||||||
|
FIPv6Addresses := TStringList.Create;
|
||||||
|
SetIPv4Addresses(nil);
|
||||||
|
SetIPv6Addresses(nil);
|
||||||
|
|
||||||
|
TIdStack.IncUsage;
|
||||||
|
try
|
||||||
|
LLocalAddresses := TIdStackLocalAddressList.Create;
|
||||||
|
try
|
||||||
|
GStack.GetLocalAddressList(LLocalAddresses);
|
||||||
|
for i := 0 to LLocalAddresses.Count-1 do
|
||||||
|
begin
|
||||||
|
case LLocalAddresses[i].IPVersion of
|
||||||
|
Id_IPv4: FIPv4Addresses.Add(LLocalAddresses[i].IPAddress);
|
||||||
|
Id_IPv6: FIPv6Addresses.Add(LLocalAddresses[i].IPAddress);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
LLocalAddresses.Free;
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
TIdStack.DecUsage;
|
||||||
|
end;
|
||||||
|
|
||||||
|
UpdateEditControls;
|
||||||
|
//captions
|
||||||
|
btnNew.Text := RSBindingNewCaption;
|
||||||
|
btnDelete.Text := RSBindingDeleteCaption;
|
||||||
|
lblIPAddress.Text := RSBindingHostnameLabel;
|
||||||
|
lblPort.Text := RSBindingPortLabel;
|
||||||
|
lblIPVersion.Text := RSBindingIPVerLabel;
|
||||||
|
btnOk.Text := RSOk;
|
||||||
|
btnCancel.Text := RSCancel;
|
||||||
|
//IPVersion choices
|
||||||
|
//we yhave to strip out the & symbol. In Win32, we use this
|
||||||
|
//in a radio-box so a user could select by pressingg the 4 or 6
|
||||||
|
//key. For this, we don't have a radio box and I'm too lazy
|
||||||
|
//to use two Radio Buttons.
|
||||||
|
cboIPVersion.Items.Add(StripAndSymbol(RSBindingIPV4Item));
|
||||||
|
cboIPVersion.Items.Add(StripAndSymbol(RSBindingIPV6Item));
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdDsnPropEdBindingNET.SetHandles(const Value: TIdSocketHandles);
|
||||||
|
begin
|
||||||
|
FHandles.Assign(Value);
|
||||||
|
UpdateBindingList;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdDsnPropEdBindingNET.GetList: string;
|
||||||
|
begin
|
||||||
|
Result := GetListValues(Handles);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdDsnPropEdBindingNET.SetIPv6Addresses(const Value: TStrings);
|
||||||
|
begin
|
||||||
|
if Assigned(Value) then begin
|
||||||
|
FIPv6Addresses.Assign(Value);
|
||||||
|
end;
|
||||||
|
// Ensure that these two are always present
|
||||||
|
if FIPv6Addresses.IndexOf(IPv6Loopback) = -1 then begin
|
||||||
|
FIPv6Addresses.Insert(0, IPv6Loopback);
|
||||||
|
end;
|
||||||
|
if FIPv6Addresses.IndexOf(IPv6Wildcard1) = -1 then begin
|
||||||
|
FIPv6Addresses.Insert(0, IPv6Wildcard1);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdDsnPropEdBindingNET.SetIPv4Addresses(const Value: TStrings);
|
||||||
|
begin
|
||||||
|
if Assigned(Value) then begin
|
||||||
|
FIPv4Addresses.Assign(Value);
|
||||||
|
end;
|
||||||
|
// Ensure that these two are always present
|
||||||
|
if FIPv4Addresses.IndexOf(IPv6Loopback) = -1 then begin
|
||||||
|
FIPv4Addresses.Insert(0, IPv4Loopback);
|
||||||
|
end;
|
||||||
|
if FIPv4Addresses.IndexOf(IPv4Wildcard) = -1 then begin
|
||||||
|
FIPv4Addresses.Insert(0, IPv4Wildcard);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdDsnPropEdBindingNET.SetList(const AList: string);
|
||||||
|
begin
|
||||||
|
FCurrentHandle := nil;
|
||||||
|
FillHandleList(AList, Handles);
|
||||||
|
UpdateBindingList;
|
||||||
|
UpdateEditControls;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdDsnPropEdBindingNET.lbBindings_SelectedValueChanged(sender: System.Object;
|
||||||
|
e: System.EventArgs);
|
||||||
|
begin
|
||||||
|
if lbBindings.SelectedIndex >= 0 then begin
|
||||||
|
btnDelete.Enabled := True;
|
||||||
|
FCurrentHandle := FHandles[lbBindings.SelectedIndex];
|
||||||
|
end else begin
|
||||||
|
btnDelete.Enabled := False;
|
||||||
|
FCurrentHandle := nil;
|
||||||
|
end;
|
||||||
|
UpdateEditControls;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdDsnPropEdBindingNET.cboIPVersion_SelectedValueChanged(sender: System.Object;
|
||||||
|
e: System.EventArgs);
|
||||||
|
begin
|
||||||
|
case cboIPVersion.SelectedIndex of
|
||||||
|
0 :
|
||||||
|
begin
|
||||||
|
if FCurrentHandle.IPVersion <> Id_IPv4 then
|
||||||
|
begin
|
||||||
|
FCurrentHandle.IPVersion := Id_IPv4;
|
||||||
|
FillComboBox(edtIPAddress,FIPv4Addresses);
|
||||||
|
FCurrentHandle.IP := IPv4Wildcard;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
1 :
|
||||||
|
begin
|
||||||
|
if FCurrentHandle.IPVersion <> Id_IPv6 then
|
||||||
|
begin
|
||||||
|
FCurrentHandle.IPVersion := Id_IPv6;
|
||||||
|
FillComboBox(edtIPAddress,FIPv6Addresses);
|
||||||
|
FCurrentHandle.IP := IPv6Wildcard1;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
UpdateEditControls;
|
||||||
|
UpdateBindingList;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdDsnPropEdBindingNET.edtIPAddress_SelectedValueChanged(sender: System.Object;
|
||||||
|
e: System.EventArgs);
|
||||||
|
begin
|
||||||
|
FCurrentHandle.IP := edtIPAddress.SelectedItem.ToString;
|
||||||
|
UpdateBindingList;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdDsnPropEdBindingNET.edtPort_ValueChanged(sender: System.Object;
|
||||||
|
e: System.EventArgs);
|
||||||
|
begin
|
||||||
|
if Assigned(FCurrentHandle) then begin
|
||||||
|
FCurrentHandle.Port := edtPort.Value.ToInt16(edtPort.Value);
|
||||||
|
end;
|
||||||
|
UpdateBindingList;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdDsnPropEdBindingNET.btnDelete_Click(sender: System.Object; e: System.EventArgs);
|
||||||
|
var LSH : TIdSocketHandle;
|
||||||
|
i : Integer;
|
||||||
|
begin
|
||||||
|
if lbBindings.SelectedIndex >= 0 then
|
||||||
|
begin
|
||||||
|
// Delete is not available in D4's collection classes
|
||||||
|
// This should work just as well.
|
||||||
|
i := lbBindings.get_SelectedIndex;
|
||||||
|
LSH := Handles[i];
|
||||||
|
FreeAndNil(LSH);
|
||||||
|
lbBindings.Items.Remove(i);
|
||||||
|
FCurrentHandle := nil;
|
||||||
|
UpdateBindingList;
|
||||||
|
end;
|
||||||
|
lbBindings_SelectedValueChanged(nil, nil);
|
||||||
|
UpdateEditControls;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdDsnPropEdBindingNET.btnNew_Click(sender: System.Object; e: System.EventArgs);
|
||||||
|
begin
|
||||||
|
FCurrentHandle := FHandles.Add;
|
||||||
|
FCurrentHandle.IP := IPv4Wildcard;
|
||||||
|
FCurrentHandle.Port := FDefaultPort;
|
||||||
|
UpdateBindingList;
|
||||||
|
FillComboBox(edtIPAddress, FIPv4Addresses);
|
||||||
|
UpdateEditControls;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdDsnPropEdBindingNET.UpdateBindingList;
|
||||||
|
var
|
||||||
|
i: integer;
|
||||||
|
selected: integer;
|
||||||
|
s: string;
|
||||||
|
begin
|
||||||
|
selected := lbBindings.SelectedIndex;
|
||||||
|
lbBindings.BeginUpdate;
|
||||||
|
try
|
||||||
|
if lbBindings.Items.Count = FHandles.Count then begin
|
||||||
|
for i := 0 to FHandles.Count - 1 do begin
|
||||||
|
s := GetDisplayString(FHandles[i]);
|
||||||
|
if s <> lbBindings.Items[i].ToString then begin
|
||||||
|
lbBindings.Items[i] := s;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end else begin
|
||||||
|
lbBindings.Items.Clear;
|
||||||
|
for i := 0 to FHandles.Count-1 do begin
|
||||||
|
lbBindings.Items.Add(GetDisplayString(FHandles[i]));
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
lbBindings.EndUpdate;
|
||||||
|
if Assigned(FCurrentHandle) then begin
|
||||||
|
lbBindings.SelectedIndex := FCurrentHandle.Index;
|
||||||
|
end else begin
|
||||||
|
lbBindings.SelectedIndex := IndyMin(selected, lbBindings.Items.Count-1);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
{ selected := lbBindings.SelectedItem;
|
||||||
|
lbBindings.Items.BeginUpdate;
|
||||||
|
try
|
||||||
|
if lbBindings.Items.Count = FHandles.Count then begin
|
||||||
|
for i := 0 to FHandles.Count - 1 do begin
|
||||||
|
s := GetDisplayString(FHandles[i]);
|
||||||
|
if s <> lbBindings.Items[i] then begin
|
||||||
|
lbBindings.Items[i] := s;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end else begin
|
||||||
|
lbBindings.Items.Clear;
|
||||||
|
for i := 0 to FHandles.Count-1 do begin
|
||||||
|
lbBindings.Items.Add(GetDisplayString(FHandles[i]));
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
lbBindings.Items.EndUpdate;
|
||||||
|
if Assigned(FCurrentHandle) then begin
|
||||||
|
lbBindings.ItemIndex := FCurrentHandle.Index;
|
||||||
|
end else begin
|
||||||
|
lbBindings.ItemIndex := IndyMin(selected, lbBindings.Items.Count-1);
|
||||||
|
end;
|
||||||
|
end; }
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdDsnPropEdBindingNET.UpdateEditControls;
|
||||||
|
begin
|
||||||
|
if Assigned(FCurrentHandle) then
|
||||||
|
begin
|
||||||
|
edtPort.Text := '';
|
||||||
|
edtPort.Value := FCurrentHandle.Port;
|
||||||
|
case FCurrentHandle.IPVersion of
|
||||||
|
Id_IPv4 :
|
||||||
|
begin
|
||||||
|
FillComboBox(edtIPAddress, FIPv4Addresses);
|
||||||
|
edtIPAddress.SelectedItem := edtIPAddress.Items[0];
|
||||||
|
cboIPVersion.SelectedItem := cboIPVersion.Items[0];
|
||||||
|
end;
|
||||||
|
Id_IPv6 :
|
||||||
|
begin
|
||||||
|
FillComboBox(edtIPAddress, FIPv6Addresses);
|
||||||
|
edtIPAddress.SelectedItem := edtIPAddress.Items[0];
|
||||||
|
cboIPVersion.SelectedItem := cboIPVersion.Items[1];
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
if edtIPAddress.DropDownStyle = System.Windows.Forms.ComboBoxStyle.DropDown then begin
|
||||||
|
edtIPAddress.Text := FCurrentHandle.IP;
|
||||||
|
end else begin
|
||||||
|
edtIPAddress.SelectedIndex := edtIPAddress.Items.IndexOf(FCurrentHandle.IP);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
lblIPAddress.Enabled := Assigned(FCurrentHandle);
|
||||||
|
edtIPAddress.Enabled := Assigned(FCurrentHandle);
|
||||||
|
lblPort.Enabled := Assigned(FCurrentHandle);
|
||||||
|
edtPort.Enabled := Assigned(FCurrentHandle);
|
||||||
|
lblIPVersion.Enabled := Assigned(FCurrentHandle);
|
||||||
|
cboIPVersion.Enabled := Assigned(FCurrentHandle);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdDsnPropEdBindingNET.FillComboBox(
|
||||||
|
ACombo: System.Windows.Forms.ComboBox; AStrings: TStrings);
|
||||||
|
var
|
||||||
|
i : Integer;
|
||||||
|
begin
|
||||||
|
ACombo.Items.Clear;
|
||||||
|
for i := 0 to AStrings.Count-1 do begin
|
||||||
|
ACombo.Items.Add(AStrings[i]);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdDsnPropEdBindingNET.Execute: Boolean;
|
||||||
|
begin
|
||||||
|
Result := Self.ShowDialog = System.Windows.Forms.DialogResult.OK;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdDsnPropEdBindingNET.GetCaption: String;
|
||||||
|
begin
|
||||||
|
Result := Text;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdDsnPropEdBindingNET.SetCaption(const AValue: String);
|
||||||
|
begin
|
||||||
|
Text := AValue;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
|
@ -0,0 +1,196 @@
|
||||||
|
<?xml version="1.0" encoding="utf-8"?>
|
||||||
|
<root>
|
||||||
|
<!--
|
||||||
|
Microsoft ResX Schema
|
||||||
|
|
||||||
|
Version 1.3
|
||||||
|
|
||||||
|
The primary goals of this format is to allow a simple XML format
|
||||||
|
that is mostly human readable. The generation and parsing of the
|
||||||
|
various data types are done through the TypeConverter classes
|
||||||
|
associated with the data types.
|
||||||
|
|
||||||
|
Example:
|
||||||
|
|
||||||
|
... ado.net/XML headers & schema ...
|
||||||
|
<resheader name="resmimetype">text/microsoft-resx</resheader>
|
||||||
|
<resheader name="version">1.3</resheader>
|
||||||
|
<resheader name="reader">System.Resources.ResXResourceReader, System.Windows.Forms, ...</resheader>
|
||||||
|
<resheader name="writer">System.Resources.ResXResourceWriter, System.Windows.Forms, ...</resheader>
|
||||||
|
<data name="Name1">this is my long string</data>
|
||||||
|
<data name="Color1" type="System.Drawing.Color, System.Drawing">Blue</data>
|
||||||
|
<data name="Bitmap1" mimetype="application/x-microsoft.net.object.binary.base64">
|
||||||
|
[base64 mime encoded serialized .NET Framework object]
|
||||||
|
</data>
|
||||||
|
<data name="Icon1" type="System.Drawing.Icon, System.Drawing" mimetype="application/x-microsoft.net.object.bytearray.base64">
|
||||||
|
[base64 mime encoded string representing a byte array form of the .NET Framework object]
|
||||||
|
</data>
|
||||||
|
|
||||||
|
There are any number of "resheader" rows that contain simple
|
||||||
|
name/value pairs.
|
||||||
|
|
||||||
|
Each data row contains a name, and value. The row also contains a
|
||||||
|
type or mimetype. Type corresponds to a .NET class that support
|
||||||
|
text/value conversion through the TypeConverter architecture.
|
||||||
|
Classes that don't support this are serialized and stored with the
|
||||||
|
mimetype set.
|
||||||
|
|
||||||
|
The mimetype is used forserialized objects, and tells the
|
||||||
|
ResXResourceReader how to depersist the object. This is currently not
|
||||||
|
extensible. For a given mimetype the value must be set accordingly:
|
||||||
|
|
||||||
|
Note - application/x-microsoft.net.object.binary.base64 is the format
|
||||||
|
that the ResXResourceWriter will generate, however the reader can
|
||||||
|
read any of the formats listed below.
|
||||||
|
|
||||||
|
mimetype: application/x-microsoft.net.object.binary.base64
|
||||||
|
value : The object must be serialized with
|
||||||
|
: System.Serialization.Formatters.Binary.BinaryFormatter
|
||||||
|
: and then encoded with base64 encoding.
|
||||||
|
|
||||||
|
mimetype: application/x-microsoft.net.object.soap.base64
|
||||||
|
value : The object must be serialized with
|
||||||
|
: System.Runtime.Serialization.Formatters.Soap.SoapFormatter
|
||||||
|
: and then encoded with base64 encoding.
|
||||||
|
|
||||||
|
mimetype: application/x-microsoft.net.object.bytearray.base64
|
||||||
|
value : The object must be serialized into a byte array
|
||||||
|
: using a System.ComponentModel.TypeConverter
|
||||||
|
: and then encoded with base64 encoding.
|
||||||
|
-->
|
||||||
|
<xsd:schema id="root" xmlns="" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:msdata="urn:schemas-microsoft-com:xml-msdata">
|
||||||
|
<xsd:element name="root" msdata:IsDataSet="true">
|
||||||
|
<xsd:complexType>
|
||||||
|
<xsd:choice maxOccurs="unbounded">
|
||||||
|
<xsd:element name="data">
|
||||||
|
<xsd:complexType>
|
||||||
|
<xsd:sequence>
|
||||||
|
<xsd:element name="value" type="xsd:string" minOccurs="0" msdata:Ordinal="1" />
|
||||||
|
<xsd:element name="comment" type="xsd:string" minOccurs="0" msdata:Ordinal="2" />
|
||||||
|
</xsd:sequence>
|
||||||
|
<xsd:attribute name="name" type="xsd:string" msdata:Ordinal="1" />
|
||||||
|
<xsd:attribute name="type" type="xsd:string" msdata:Ordinal="3" />
|
||||||
|
<xsd:attribute name="mimetype" type="xsd:string" msdata:Ordinal="4" />
|
||||||
|
</xsd:complexType>
|
||||||
|
</xsd:element>
|
||||||
|
<xsd:element name="resheader">
|
||||||
|
<xsd:complexType>
|
||||||
|
<xsd:sequence>
|
||||||
|
<xsd:element name="value" type="xsd:string" minOccurs="0" msdata:Ordinal="1" />
|
||||||
|
</xsd:sequence>
|
||||||
|
<xsd:attribute name="name" type="xsd:string" use="required" />
|
||||||
|
</xsd:complexType>
|
||||||
|
</xsd:element>
|
||||||
|
</xsd:choice>
|
||||||
|
</xsd:complexType>
|
||||||
|
</xsd:element>
|
||||||
|
</xsd:schema>
|
||||||
|
<resheader name="resmimetype">
|
||||||
|
<value>text/microsoft-resx</value>
|
||||||
|
</resheader>
|
||||||
|
<resheader name="version">
|
||||||
|
<value>1.3</value>
|
||||||
|
</resheader>
|
||||||
|
<resheader name="reader">
|
||||||
|
<value>System.Resources.ResXResourceReader, System.Windows.Forms, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
|
||||||
|
</resheader>
|
||||||
|
<resheader name="writer">
|
||||||
|
<value>System.Resources.ResXResourceWriter, System.Windows.Forms, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
|
||||||
|
</resheader>
|
||||||
|
<data name="btnOk.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="btnOk.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="btnCancel.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="btnCancel.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblBindings.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblBindings.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="lbBindings.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="lbBindings.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="btnNew.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="btnNew.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="btnDelete.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="btnDelete.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblIPAddress.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblIPAddress.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="edtIPAddress.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="edtIPAddress.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblPort.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblPort.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="edtPort.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="edtPort.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="cboIPVersion.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="cboIPVersion.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblIPVersion.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="lblIPVersion.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>Private</value>
|
||||||
|
</data>
|
||||||
|
<data name="$this.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="$this.Language" type="System.Globalization.CultureInfo, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>(Default)</value>
|
||||||
|
</data>
|
||||||
|
<data name="$this.TrayLargeIcon" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="$this.Localizable" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>False</value>
|
||||||
|
</data>
|
||||||
|
<data name="$this.GridSize" type="System.Drawing.Size, System.Drawing, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a">
|
||||||
|
<value>8, 8</value>
|
||||||
|
</data>
|
||||||
|
<data name="$this.DrawGrid" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>True</value>
|
||||||
|
</data>
|
||||||
|
<data name="$this.TrayHeight" type="System.Int32, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>80</value>
|
||||||
|
</data>
|
||||||
|
<data name="$this.SnapToGrid" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
|
||||||
|
<value>True</value>
|
||||||
|
</data>
|
||||||
|
</root>
|
|
@ -0,0 +1,819 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.9 10/26/2004 8:45:26 PM JPMugaas
|
||||||
|
Should compile.
|
||||||
|
|
||||||
|
Rev 1.8 10/26/2004 8:42:58 PM JPMugaas
|
||||||
|
Should be more portable with new references to TIdStrings and TIdStringList.
|
||||||
|
|
||||||
|
Rev 1.7 5/19/2004 10:44:28 PM DSiders
|
||||||
|
Corrected spelling for TIdIPAddress.MakeAddressObject method.
|
||||||
|
|
||||||
|
Rev 1.6 2/3/2004 11:34:26 AM JPMugaas
|
||||||
|
Should compile.
|
||||||
|
|
||||||
|
Rev 1.5.1.0 2/3/2004 11:32:26 AM JPMugaas
|
||||||
|
Should compile.
|
||||||
|
|
||||||
|
Rev 1.5 2/1/2004 2:44:20 AM JPMugaas
|
||||||
|
Bindings editor should be fully functional including IPv6 support.
|
||||||
|
|
||||||
|
Rev 1.4 2/1/2004 1:03:34 AM JPMugaas
|
||||||
|
This now work properly in both Win32 and DotNET. The behavior had to change
|
||||||
|
in DotNET because of some missing functionality and because implementing that
|
||||||
|
functionality creates more problems than it would solve.
|
||||||
|
|
||||||
|
Rev 1.3 2003.12.31 10:42:22 PM czhower
|
||||||
|
Warning removed
|
||||||
|
|
||||||
|
Rev 1.2 10/15/2003 10:12:32 PM DSiders
|
||||||
|
Added localization comments.
|
||||||
|
|
||||||
|
Rev 1.1 2003.10.11 5:47:46 PM czhower
|
||||||
|
-VCL fixes for servers
|
||||||
|
-Chain suport for servers (Super core)
|
||||||
|
-Scheduler upgrades
|
||||||
|
-Full yarn support
|
||||||
|
|
||||||
|
Rev 1.0 11/13/2002 08:43:58 AM JPMugaas
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdDsnPropEdBindingVCL;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
{$I IdCompilerDefines.inc}
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes,
|
||||||
|
{$IFDEF WIDGET_KYLIX}
|
||||||
|
QActnList, QStdCtrls, QForms, QExtCtrls, QControls, QComCtrls, QGraphics, Qt,
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF WIDGET_VCL_LIKE}
|
||||||
|
ActnList, StdCtrls, Buttons, ExtCtrls, Graphics, Controls, ComCtrls, Forms, Dialogs,
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF HAS_UNIT_Types}
|
||||||
|
Types,
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF WINDOWS}
|
||||||
|
Windows,
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF LCL}
|
||||||
|
LResources,
|
||||||
|
{$ENDIF}
|
||||||
|
IdSocketHandle;
|
||||||
|
{
|
||||||
|
Design Note: It turns out that in DotNET, there are no services file functions and
|
||||||
|
IdPorts does not work as expected in DotNET. It is probably possible to read the
|
||||||
|
services file ourselves but that creates some portability problems as the placement
|
||||||
|
is different in every operating system.
|
||||||
|
|
||||||
|
e.g.
|
||||||
|
|
||||||
|
Linux and Unix-like systems - /etc
|
||||||
|
Windows 95, 98, and ME - c:\windows
|
||||||
|
Windows NT systems - c:\winnt\system32\drivers\etc
|
||||||
|
|
||||||
|
Thus, it will undercut whatever benefit we could get with DotNET.
|
||||||
|
|
||||||
|
About the best I could think of is to use an edit control because
|
||||||
|
we can't offer anything from the services file in DotNET.
|
||||||
|
|
||||||
|
TODO: Maybe there might be a way to find the location in a more elegant
|
||||||
|
manner than what I described.
|
||||||
|
}
|
||||||
|
|
||||||
|
type
|
||||||
|
TIdDsnPropEdBindingVCL = class(TForm)
|
||||||
|
{$IFDEF USE_TBitBtn}
|
||||||
|
btnOk: TBitBtn;
|
||||||
|
btnCancel: TBitBtn;
|
||||||
|
{$ELSE}
|
||||||
|
btnOk: TButton;
|
||||||
|
btnCancel: TButton;
|
||||||
|
{$ENDIF}
|
||||||
|
lblBindings: TLabel;
|
||||||
|
edtPort: TComboBox;
|
||||||
|
rdoBindingType: TRadioGroup;
|
||||||
|
lblIPAddress: TLabel;
|
||||||
|
lblPort: TLabel;
|
||||||
|
btnNew: TButton;
|
||||||
|
btnDelete: TButton;
|
||||||
|
ActionList1: TActionList;
|
||||||
|
btnBindingsNew: TAction;
|
||||||
|
btnBindingsDelete: TAction;
|
||||||
|
edtIPAddress: TComboBox;
|
||||||
|
lbBindings: TListBox;
|
||||||
|
procedure btnBindingsNewExecute(Sender: TObject);
|
||||||
|
procedure btnBindingsDeleteExecute(Sender: TObject);
|
||||||
|
procedure btnBindingsDeleteUpdate(Sender: TObject);
|
||||||
|
procedure edtPortKeyPress(Sender: TObject; var Key: Char);
|
||||||
|
procedure edtIPAddressChange(Sender: TObject);
|
||||||
|
procedure edtPortChange(Sender: TObject);
|
||||||
|
procedure rdoBindingTypeClick(Sender: TObject);
|
||||||
|
procedure lbBindingsClick(Sender: TObject);
|
||||||
|
private
|
||||||
|
procedure SetHandles(const Value: TIdSocketHandles);
|
||||||
|
procedure SetIPv4Addresses(const Value: TStrings);
|
||||||
|
procedure SetIPv6Addresses(const Value: TStrings);
|
||||||
|
procedure UpdateBindingList;
|
||||||
|
protected
|
||||||
|
FInUpdateRoutine : Boolean;
|
||||||
|
FHandles : TIdSocketHandles;
|
||||||
|
FDefaultPort : Integer;
|
||||||
|
FIPv4Addresses : TStrings;
|
||||||
|
FIPv6Addresses : TStrings;
|
||||||
|
fCreatedStack : Boolean;
|
||||||
|
FCurrentHandle : TIdSocketHandle;
|
||||||
|
procedure UpdateEditControls;
|
||||||
|
function PortDescription(const PortNumber: integer): string;
|
||||||
|
public
|
||||||
|
Constructor Create(AOwner : TComponent); overload; override;
|
||||||
|
constructor Create; reintroduce; overload;
|
||||||
|
Destructor Destroy; override;
|
||||||
|
function Execute : Boolean;
|
||||||
|
function GetList: string;
|
||||||
|
procedure SetList(const AList: string);
|
||||||
|
property Handles : TIdSocketHandles read FHandles write SetHandles;
|
||||||
|
property DefaultPort : Integer read FDefaultPort write FDefaultPort;
|
||||||
|
property IPv4Addresses : TStrings read FIPv4Addresses write SetIPv4Addresses;
|
||||||
|
property IPv6Addresses : TStrings read FIPv6Addresses write SetIPv6Addresses;
|
||||||
|
end;
|
||||||
|
|
||||||
|
var
|
||||||
|
IdPropEdBindingEntry: TIdDsnPropEdBindingVCL;
|
||||||
|
|
||||||
|
procedure FillHandleList(const AList: string; ADest: TIdSocketHandles);
|
||||||
|
function GetListValues(const ASocketHandles : TIdSocketHandles) : String;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
IdGlobal,
|
||||||
|
IdIPAddress,
|
||||||
|
IdDsnCoreResourceStrings,
|
||||||
|
IdStack,
|
||||||
|
IdStackBSDBase,
|
||||||
|
SysUtils;
|
||||||
|
|
||||||
|
const
|
||||||
|
IPv6Wildcard1 = '::'; {do not localize}
|
||||||
|
{CH IPv6Wildcard2 = '0:0:0:0:0:0:0:0'; } {do not localize}
|
||||||
|
IPv6Loopback = '::1'; {do not localize}
|
||||||
|
IPv4Wildcard = '0.0.0.0'; {do not localize}
|
||||||
|
IPv4Loopback = '127.0.0.1'; {do not localize}
|
||||||
|
|
||||||
|
function IsValidIP(const AAddr : String): Boolean;
|
||||||
|
var
|
||||||
|
LIP : TIdIPAddress;
|
||||||
|
begin
|
||||||
|
LIP := TIdIPAddress.MakeAddressObject(AAddr);
|
||||||
|
Result := Assigned(LIP);
|
||||||
|
if Result then begin
|
||||||
|
FreeAndNil(LIP);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure FillHandleList(const AList: string; ADest: TIdSocketHandles);
|
||||||
|
var
|
||||||
|
LItems: TStringList;
|
||||||
|
i: integer;
|
||||||
|
LIPVersion: TIdIPVersion;
|
||||||
|
LAddr, LText: string;
|
||||||
|
LPort: integer;
|
||||||
|
LSocket: TIdSocketHandle;
|
||||||
|
begin
|
||||||
|
ADest.Clear;
|
||||||
|
LItems := TStringList.Create;
|
||||||
|
try
|
||||||
|
LItems.CommaText := AList;
|
||||||
|
for i := 0 to LItems.Count-1 do begin
|
||||||
|
if Length(LItems[i]) > 0 then begin
|
||||||
|
if TextStartsWith(LItems[i], '[') then begin
|
||||||
|
// ipv6
|
||||||
|
LIPVersion := Id_IPv6;
|
||||||
|
LText := Copy(LItems[i], 2, MaxInt);
|
||||||
|
LAddr := Fetch(LText, ']:');
|
||||||
|
LPort := StrToIntDef(LText, -1);
|
||||||
|
end else begin
|
||||||
|
// ipv4
|
||||||
|
LIPVersion := Id_IPv4;
|
||||||
|
LText := LItems[i];
|
||||||
|
LAddr := Fetch(LText, ':');
|
||||||
|
LPort := StrToIntDef(LText, -1);
|
||||||
|
//Note that 0 is legal and indicates the server binds to a random port
|
||||||
|
end;
|
||||||
|
if IsValidIP(LAddr) and (LPort > -1) and (LPort < 65536) then begin
|
||||||
|
LSocket := ADest.Add;
|
||||||
|
LSocket.IPVersion := LIPVersion;
|
||||||
|
LSocket.IP := LAddr;
|
||||||
|
LSocket.Port := LPort;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
LItems.Free;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TIdDsnPropEdBindingVCL }
|
||||||
|
|
||||||
|
function NumericOnly(const AText : String) : String;
|
||||||
|
var
|
||||||
|
i : Integer;
|
||||||
|
begin
|
||||||
|
Result := '';
|
||||||
|
for i := 1 to Length(AText) do
|
||||||
|
begin
|
||||||
|
if IsNumeric(AText[i]) then begin
|
||||||
|
Result := Result + AText[i];
|
||||||
|
end else begin
|
||||||
|
Break;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
if Length(Result) = 0 then begin
|
||||||
|
Result := '0';
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function IndexOfNo(const ANo : Integer; AStrings : TStrings) : Integer;
|
||||||
|
begin
|
||||||
|
for Result := 0 to AStrings.Count-1 do
|
||||||
|
begin
|
||||||
|
if ANo = IndyStrToInt(NumericOnly(AStrings[Result])) then begin
|
||||||
|
Exit;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
Result := -1;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetDisplayString(ASocketHandle: TIdSocketHandle): string;
|
||||||
|
begin
|
||||||
|
Result := '';
|
||||||
|
case ASocketHandle.IPVersion of
|
||||||
|
Id_IPv4 : Result := Format('%s:%d',[ASocketHandle.IP, ASocketHandle.Port]);
|
||||||
|
Id_IPv6 : Result := Format('[%s]:%d',[ASocketHandle.IP, ASocketHandle.Port]);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetListValues(const ASocketHandles : TIdSocketHandles) : String;
|
||||||
|
var i : Integer;
|
||||||
|
begin
|
||||||
|
Result := '';
|
||||||
|
for i := 0 to ASocketHandles.Count -1 do begin
|
||||||
|
Result := Result + ',' + GetDisplayString(ASocketHandles[i]);
|
||||||
|
end;
|
||||||
|
Delete(Result,1,1);
|
||||||
|
end;
|
||||||
|
|
||||||
|
constructor TIdDsnPropEdBindingVCL.Create(AOwner: TComponent);
|
||||||
|
var
|
||||||
|
i : Integer;
|
||||||
|
LLocalAddresses: TIdStackLocalAddressList;
|
||||||
|
begin
|
||||||
|
inherited CreateNew(AOwner, 0);
|
||||||
|
{$IFNDEF WIDGET_KYLIX}
|
||||||
|
Borderstyle := bsDialog;
|
||||||
|
{$ENDIF}
|
||||||
|
BorderIcons := [biSystemMenu];
|
||||||
|
// Width := 480;
|
||||||
|
// Height := 252;
|
||||||
|
ClientWidth := 472;
|
||||||
|
{$IFDEF USE_TBitBtn}
|
||||||
|
ClientHeight := 230;
|
||||||
|
{$ELSE}
|
||||||
|
ClientHeight := 225;
|
||||||
|
{$ENDIF}
|
||||||
|
Constraints.MaxWidth := Width;
|
||||||
|
Constraints.MaxHeight := Height;
|
||||||
|
Constraints.MinWidth := Width;
|
||||||
|
Constraints.MinHeight := Height;
|
||||||
|
Position := poScreenCenter;
|
||||||
|
lblBindings := TLabel.Create(Self);
|
||||||
|
lbBindings := TListBox.Create(Self);
|
||||||
|
ActionList1 := TActionList.Create(Self);
|
||||||
|
btnBindingsNew := TAction.Create(Self);
|
||||||
|
btnBindingsDelete := TAction.Create(Self);
|
||||||
|
btnNew := TButton.Create(Self);
|
||||||
|
btnDelete := TButton.Create(Self);
|
||||||
|
lblIPAddress := TLabel.Create(Self);
|
||||||
|
edtIPAddress := TComboBox.Create(Self);
|
||||||
|
lblPort := TLabel.Create(Self);
|
||||||
|
|
||||||
|
edtPort := TComboBox.Create(Self);
|
||||||
|
rdoBindingType := TRadioGroup.Create(Self);
|
||||||
|
|
||||||
|
{$IFDEF USE_TBitBtn}
|
||||||
|
btnOk := TBitBtn.Create(Self);
|
||||||
|
btnCancel := TBitBtn.Create(Self);
|
||||||
|
{$ELSE}
|
||||||
|
btnOk := TButton.Create(Self);
|
||||||
|
btnCancel := TButton.Create(Self);
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
lblBindings.Name := 'lblBindings'; {do not localize}
|
||||||
|
lblBindings.Parent := Self;
|
||||||
|
lblBindings.Left := 8;
|
||||||
|
lblBindings.Top := 8;
|
||||||
|
lblBindings.Width := 35;
|
||||||
|
lblBindings.Height := 13;
|
||||||
|
lblBindings.Caption := '&Binding'; {do not localize}
|
||||||
|
|
||||||
|
lbBindings.Name := 'lbBindings'; {do not localize}
|
||||||
|
lbBindings.Parent := Self;
|
||||||
|
lbBindings.Left := 8;
|
||||||
|
lbBindings.Top := 24;
|
||||||
|
lbBindings.Width := 137;
|
||||||
|
lbBindings.Height := 161;
|
||||||
|
lbBindings.ItemHeight := 13;
|
||||||
|
lbBindings.TabOrder := 8;
|
||||||
|
lbBindings.OnClick := lbBindingsClick;
|
||||||
|
|
||||||
|
ActionList1.Name := 'ActionList1'; {do not localize}
|
||||||
|
{
|
||||||
|
ActionList1.Left := 152;
|
||||||
|
ActionList1.Top := 32;
|
||||||
|
}
|
||||||
|
|
||||||
|
btnBindingsNew.Name := 'btnBindingsNew'; {do not localize}
|
||||||
|
btnBindingsNew.Caption := RSBindingNewCaption;
|
||||||
|
btnBindingsNew.OnExecute := btnBindingsNewExecute;
|
||||||
|
|
||||||
|
btnBindingsDelete.Name := 'btnBindingsDelete'; {do not localize}
|
||||||
|
btnBindingsDelete.Caption := RSBindingDeleteCaption;
|
||||||
|
btnBindingsDelete.OnExecute := btnBindingsDeleteExecute;
|
||||||
|
btnBindingsDelete.OnUpdate := btnBindingsDeleteUpdate;
|
||||||
|
|
||||||
|
btnNew.Name := 'btnNew'; {do not localize}
|
||||||
|
btnNew.Parent := Self;
|
||||||
|
btnNew.Left := 152;
|
||||||
|
btnNew.Top := 72;
|
||||||
|
btnNew.Width := 75;
|
||||||
|
btnNew.Height := 25;
|
||||||
|
btnNew.Action := btnBindingsNew;
|
||||||
|
btnNew.TabOrder := 6;
|
||||||
|
|
||||||
|
btnDelete.Name := 'btnDelete'; {do not localize}
|
||||||
|
btnDelete.Parent := Self;
|
||||||
|
btnDelete.Left := 152;
|
||||||
|
btnDelete.Top := 104;
|
||||||
|
btnDelete.Width := 75;
|
||||||
|
btnDelete.Height := 25;
|
||||||
|
btnDelete.Action := btnBindingsDelete;
|
||||||
|
btnDelete.TabOrder := 7;
|
||||||
|
|
||||||
|
lblIPAddress.Name := 'lblIPAddress'; {do not localize}
|
||||||
|
lblIPAddress.Parent := Self;
|
||||||
|
lblIPAddress.Left := 240;
|
||||||
|
lblIPAddress.Top := 8;
|
||||||
|
lblIPAddress.Width := 54;
|
||||||
|
lblIPAddress.Height := 13;
|
||||||
|
lblIPAddress.Caption := RSBindingHostnameLabel;
|
||||||
|
lblIPAddress.Enabled := False;
|
||||||
|
|
||||||
|
edtIPAddress.Name := 'edtIPAddress'; {do not localize}
|
||||||
|
edtIPAddress.Parent := Self;
|
||||||
|
edtIPAddress.Left := 240;
|
||||||
|
edtIPAddress.Top := 24;
|
||||||
|
edtIPAddress.Width := 221;
|
||||||
|
edtIPAddress.Height := 21;
|
||||||
|
edtIPAddress.Enabled := False;
|
||||||
|
edtIPAddress.ItemHeight := 13;
|
||||||
|
edtIPAddress.TabOrder := 3;
|
||||||
|
edtIPAddress.OnChange := edtIPAddressChange;
|
||||||
|
|
||||||
|
lblPort.Name := 'lblPort'; {do not localize}
|
||||||
|
lblPort.Parent := Self;
|
||||||
|
lblPort.Left := 240;
|
||||||
|
lblPort.Top := 56;
|
||||||
|
lblPort.Width := 22;
|
||||||
|
lblPort.Height := 13;
|
||||||
|
lblPort.Caption := RSBindingPortLabel;
|
||||||
|
lblPort.Enabled := False;
|
||||||
|
lblPort.FocusControl := edtPort;
|
||||||
|
|
||||||
|
edtPort.Name := 'edtPort'; {do not localize}
|
||||||
|
edtPort.Parent := Self;
|
||||||
|
edtPort.Left := 240;
|
||||||
|
edtPort.Top := 72;
|
||||||
|
edtPort.Width := 221;
|
||||||
|
edtPort.Height := 21;
|
||||||
|
edtPort.Enabled := False;
|
||||||
|
edtPort.ItemHeight := 13;
|
||||||
|
edtPort.TabOrder := 4;
|
||||||
|
edtPort.OnChange := edtPortChange;
|
||||||
|
edtPort.OnKeyPress := edtPortKeyPress;
|
||||||
|
|
||||||
|
rdoBindingType.Name := 'rdoBindingType'; {do not localize}
|
||||||
|
rdoBindingType.Parent := Self;
|
||||||
|
rdoBindingType.Left := 240;
|
||||||
|
rdoBindingType.Top := 120;
|
||||||
|
rdoBindingType.Width := 221;
|
||||||
|
rdoBindingType.Height := 65;
|
||||||
|
rdoBindingType.Caption := RSBindingIPVerLabel;
|
||||||
|
rdoBindingType.Enabled := False;
|
||||||
|
rdoBindingType.Items.Add(RSBindingIPV4Item);
|
||||||
|
rdoBindingType.Items.Add(RSBindingIPV6Item);
|
||||||
|
rdoBindingType.TabOrder := 5;
|
||||||
|
rdoBindingType.OnClick := rdoBindingTypeClick;
|
||||||
|
|
||||||
|
btnOk.Name := 'btnOk'; {do not localize}
|
||||||
|
btnOk.Parent := Self;
|
||||||
|
btnOk.Anchors := [akRight, akBottom];
|
||||||
|
btnOk.Left := 306;
|
||||||
|
btnOk.Top := 193;
|
||||||
|
btnOk.Width := 75;
|
||||||
|
{$IFDEF USE_TBitBtn}
|
||||||
|
btnOk.Height := 30;
|
||||||
|
btnOk.Kind := bkOk;
|
||||||
|
{$ELSE}
|
||||||
|
btnOk.Height := 25;
|
||||||
|
btnOk.Caption := RSOk;
|
||||||
|
btnOk.Default := True;
|
||||||
|
btnOk.ModalResult := 1;
|
||||||
|
{$ENDIF}
|
||||||
|
btnOk.TabOrder := 0;
|
||||||
|
|
||||||
|
btnCancel.Name := 'btnCancel'; {do not localize}
|
||||||
|
btnCancel.Parent := Self;
|
||||||
|
btnCancel.Anchors := [akRight, akBottom];
|
||||||
|
btnCancel.Left := 386;
|
||||||
|
btnCancel.Top := 193;
|
||||||
|
btnCancel.Width := 75;
|
||||||
|
{$IFDEF USE_TBitBtn}
|
||||||
|
btnCancel.Height := 30;
|
||||||
|
btnCancel.Kind := bkCancel;
|
||||||
|
{$ELSE}
|
||||||
|
btnCancel.Height := 25;
|
||||||
|
btnCancel.Cancel := True;
|
||||||
|
btnCancel.Caption := RSCancel;
|
||||||
|
btnCancel.ModalResult := 2;
|
||||||
|
{$ENDIF}
|
||||||
|
btnCancel.Anchors := [akRight, akBottom];
|
||||||
|
btnCancel.TabOrder := 1;
|
||||||
|
|
||||||
|
FHandles := TIdSocketHandles.Create(nil);
|
||||||
|
FIPv4Addresses := TStringList.Create;
|
||||||
|
FIPv6Addresses := TStringList.Create;
|
||||||
|
SetIPv4Addresses(nil);
|
||||||
|
SetIPv6Addresses(nil);
|
||||||
|
|
||||||
|
TIdStack.IncUsage;
|
||||||
|
try
|
||||||
|
LLocalAddresses := TIdStackLocalAddressList.Create;
|
||||||
|
try
|
||||||
|
GStack.GetLocalAddressList(LLocalAddresses);
|
||||||
|
for i := 0 to LLocalAddresses.Count-1 do
|
||||||
|
begin
|
||||||
|
case LLocalAddresses[i].IPVersion of
|
||||||
|
Id_IPv4: FIPv4Addresses.Add(LLocalAddresses[i].IPAddress);
|
||||||
|
Id_IPv6: FIPv6Addresses.Add(LLocalAddresses[i].IPAddress);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
LLocalAddresses.Free;
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
TIdStack.DecUsage;
|
||||||
|
end;
|
||||||
|
|
||||||
|
edtPort.Items.BeginUpdate;
|
||||||
|
try
|
||||||
|
edtPort.Items.Add(PortDescription(0));
|
||||||
|
for i := 0 to IdPorts.Count - 1 do begin
|
||||||
|
edtPort.Items.Add(
|
||||||
|
PortDescription(
|
||||||
|
{$IFDEF HAS_GENERICS_TList}
|
||||||
|
IdPorts[i]
|
||||||
|
{$ELSE}
|
||||||
|
PtrInt(IdPorts[i])
|
||||||
|
{$ENDIF}
|
||||||
|
)
|
||||||
|
);
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
edtPort.Items.EndUpdate;
|
||||||
|
end;
|
||||||
|
|
||||||
|
AutoScroll := False;
|
||||||
|
Caption := RSBindingFormCaption;
|
||||||
|
{$IFDEF WIDGET_VCL}
|
||||||
|
Scaled := False;
|
||||||
|
{$ENDIF}
|
||||||
|
Font.Color := clBtnText;
|
||||||
|
Font.Height := -11;
|
||||||
|
Font.Name := 'MS Sans Serif'; {Do not Localize}
|
||||||
|
Font.Style := [];
|
||||||
|
Position := poScreenCenter;
|
||||||
|
PixelsPerInch := 96;
|
||||||
|
FInUpdateRoutine := False;
|
||||||
|
UpdateEditControls;
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TIdDsnPropEdBindingVCL.Destroy;
|
||||||
|
begin
|
||||||
|
FreeAndNil(FIPv4Addresses);
|
||||||
|
FreeAndNil(FIPv6Addresses);
|
||||||
|
FreeAndNil(FHandles);
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdDsnPropEdBindingVCL.PortDescription(const PortNumber: integer): string;
|
||||||
|
var
|
||||||
|
LList: TStringList;
|
||||||
|
begin
|
||||||
|
if PortNumber = 0 then begin
|
||||||
|
Result := IndyFormat('%d: %s', [PortNumber, RSBindingAny]);
|
||||||
|
end else begin
|
||||||
|
Result := ''; {Do not Localize}
|
||||||
|
LList := TStringList.Create;
|
||||||
|
try
|
||||||
|
GBSDStack.AddServByPortToList(PortNumber, LList);
|
||||||
|
if LList.Count > 0 then begin
|
||||||
|
Result := Format('%d: %s', [PortNumber, LList.CommaText]); {Do not Localize}
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
LList.Free;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdDsnPropEdBindingVCL.SetHandles(const Value: TIdSocketHandles);
|
||||||
|
begin
|
||||||
|
FHandles.Assign(Value);
|
||||||
|
UpdateBindingList;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdDsnPropEdBindingVCL.btnBindingsNewExecute(Sender: TObject);
|
||||||
|
begin
|
||||||
|
FCurrentHandle := FHandles.Add;
|
||||||
|
FCurrentHandle.IP := IPv4Wildcard;
|
||||||
|
FCurrentHandle.Port := FDefaultPort;
|
||||||
|
UpdateBindingList;
|
||||||
|
edtIPAddress.Items.Assign(FIPv4Addresses);
|
||||||
|
UpdateEditControls;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdDsnPropEdBindingVCL.UpdateEditControls;
|
||||||
|
var
|
||||||
|
i : Integer;
|
||||||
|
begin
|
||||||
|
if Assigned(FCurrentHandle) then
|
||||||
|
begin
|
||||||
|
i := IndexOfNo(FCurrentHandle.Port,edtPort.Items);
|
||||||
|
if i = -1 then begin
|
||||||
|
edtPort.Text := IntToStr(FCurrentHandle.Port);
|
||||||
|
end else begin
|
||||||
|
edtPort.ItemIndex := i;
|
||||||
|
end;
|
||||||
|
|
||||||
|
case FCurrentHandle.IPVersion of
|
||||||
|
Id_IPv4 :
|
||||||
|
begin
|
||||||
|
rdoBindingType.ItemIndex := 0;
|
||||||
|
edtIPAddress.Items.Assign(FIPv4Addresses);
|
||||||
|
end;
|
||||||
|
Id_IPv6 :
|
||||||
|
begin
|
||||||
|
rdoBindingType.ItemIndex := 1;
|
||||||
|
edtIPAddress.Items.Assign(FIPv6Addresses);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
if edtIPAddress.Style = csDropDown then begin
|
||||||
|
edtIPAddress.Text := FCurrentHandle.IP;
|
||||||
|
end else begin
|
||||||
|
edtIPAddress.ItemIndex := edtIPAddress.Items.IndexOf(FCurrentHandle.IP);
|
||||||
|
end;
|
||||||
|
end
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
edtIPAddress.Text := '';
|
||||||
|
//in LCL, the line below caused an index out of range error.
|
||||||
|
{$IFDEF WIDGET_VCL}
|
||||||
|
edtPort.ItemIndex := -1; //-2;
|
||||||
|
{$ENDIF}
|
||||||
|
edtPort.Text := '';
|
||||||
|
end;
|
||||||
|
|
||||||
|
lblIPAddress.Enabled := Assigned(FCurrentHandle);
|
||||||
|
edtIPAddress.Enabled := Assigned(FCurrentHandle);
|
||||||
|
lblPort.Enabled := Assigned(FCurrentHandle);
|
||||||
|
edtPort.Enabled := Assigned(FCurrentHandle);
|
||||||
|
rdoBindingType.Enabled := Assigned(FCurrentHandle);
|
||||||
|
{$IFDEF WIDGET_KYLIX}
|
||||||
|
//WOrkaround for CLX quirk that might be Kylix 1
|
||||||
|
for i := 0 to rdoBindingType.ControlCount -1 do begin
|
||||||
|
rdoBindingType.Controls[i].Enabled := Assigned(FCurrentHandle);
|
||||||
|
end;
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF WIDGET_VCL_LIKE}
|
||||||
|
//The Win32 VCL does not change the control background to a greyed look
|
||||||
|
//when controls are disabled. This quirk is not present in CLX.
|
||||||
|
if Assigned(FCurrentHandle) then
|
||||||
|
begin
|
||||||
|
edtIPAddress.Color := clWindow;
|
||||||
|
edtPort.Color := clWindow;
|
||||||
|
end else
|
||||||
|
begin
|
||||||
|
edtIPAddress.Color := clBtnFace;
|
||||||
|
edtPort.Color := clBtnFace;
|
||||||
|
end;
|
||||||
|
{$ENDIF}
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdDsnPropEdBindingVCL.btnBindingsDeleteExecute(Sender: TObject);
|
||||||
|
var
|
||||||
|
LSH : TIdSocketHandle;
|
||||||
|
begin
|
||||||
|
if lbBindings.ItemIndex >= 0 then
|
||||||
|
begin
|
||||||
|
// Delete is not available in D4's collection classes
|
||||||
|
// This should work just as well.
|
||||||
|
LSH := Handles[lbBindings.ItemIndex];
|
||||||
|
FreeAndNil(LSH);
|
||||||
|
FCurrentHandle := nil;
|
||||||
|
UpdateBindingList;
|
||||||
|
end;
|
||||||
|
lbBindingsClick(nil);
|
||||||
|
UpdateEditControls;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdDsnPropEdBindingVCL.btnBindingsDeleteUpdate(Sender: TObject);
|
||||||
|
begin
|
||||||
|
btnBindingsDelete.Enabled := lbBindings.ItemIndex >= 0;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdDsnPropEdBindingVCL.SetIPv4Addresses(const Value: TStrings);
|
||||||
|
begin
|
||||||
|
if Assigned(Value) then begin
|
||||||
|
FIPv4Addresses.Assign(Value);
|
||||||
|
end;
|
||||||
|
// Ensure that these two are always present
|
||||||
|
if FIPv4Addresses.IndexOf(IPv6Loopback) = -1 then begin
|
||||||
|
FIPv4Addresses.Insert(0, IPv4Loopback);
|
||||||
|
end;
|
||||||
|
if FIPv4Addresses.IndexOf(IPv4Wildcard) = -1 then begin
|
||||||
|
FIPv4Addresses.Insert(0, IPv4Wildcard);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdDsnPropEdBindingVCL.SetIPv6Addresses(const Value: TStrings);
|
||||||
|
begin
|
||||||
|
if Assigned(Value) then begin
|
||||||
|
FIPv6Addresses.Assign(Value);
|
||||||
|
end;
|
||||||
|
// Ensure that these two are always present
|
||||||
|
if FIPv6Addresses.IndexOf(IPv6Loopback) = -1 then begin
|
||||||
|
FIPv6Addresses.Insert(0, IPv6Loopback);
|
||||||
|
end;
|
||||||
|
if FIPv6Addresses.IndexOf(IPv6Wildcard1) = -1 then begin
|
||||||
|
FIPv6Addresses.Insert(0, IPv6Wildcard1);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdDsnPropEdBindingVCL.edtPortKeyPress(Sender: TObject; var Key: Char);
|
||||||
|
begin
|
||||||
|
// RLebeau 1/7/09: using Char() for #128-#255 because in D2009, the compiler
|
||||||
|
// may change characters >= #128 from their Ansi codepage value to their true
|
||||||
|
// Unicode codepoint value, depending on the codepage used for the source code.
|
||||||
|
// For instance, #128 may become #$20AC...
|
||||||
|
|
||||||
|
if (Key > Chr(31)) and (Key < Chr(128)) then begin
|
||||||
|
if not IsNumeric(Key) then begin
|
||||||
|
Key := #0;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdDsnPropEdBindingVCL.edtIPAddressChange(Sender: TObject);
|
||||||
|
begin
|
||||||
|
FCurrentHandle.IP := edtIPAddress.Text;
|
||||||
|
UpdateBindingList;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdDsnPropEdBindingVCL.edtPortChange(Sender: TObject);
|
||||||
|
begin
|
||||||
|
if Assigned(FCurrentHandle) then begin
|
||||||
|
FCurrentHandle.Port := IndyStrToInt(NumericOnly(edtPort.Text), 0);
|
||||||
|
end;
|
||||||
|
UpdateBindingList;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdDsnPropEdBindingVCL.rdoBindingTypeClick(Sender: TObject);
|
||||||
|
begin
|
||||||
|
case rdoBindingType.ItemIndex of
|
||||||
|
0 :
|
||||||
|
begin
|
||||||
|
if FCurrentHandle.IPVersion <> Id_IPv4 then
|
||||||
|
begin
|
||||||
|
FCurrentHandle.IPVersion := Id_IPv4;
|
||||||
|
edtIPAddress.Items.Assign(FIPv4Addresses);
|
||||||
|
FCurrentHandle.IP := IPv4Wildcard;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
1 :
|
||||||
|
begin
|
||||||
|
if FCurrentHandle.IPVersion <> Id_IPv6 then
|
||||||
|
begin
|
||||||
|
FCurrentHandle.IPVersion := Id_IPv6;
|
||||||
|
edtIPAddress.Items.Assign(FIPv6Addresses);
|
||||||
|
FCurrentHandle.IP := IPv6Wildcard1;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
UpdateEditControls;
|
||||||
|
UpdateBindingList;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdDsnPropEdBindingVCL.GetList: string;
|
||||||
|
begin
|
||||||
|
Result := GetListValues(Handles);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdDsnPropEdBindingVCL.lbBindingsClick(Sender: TObject);
|
||||||
|
begin
|
||||||
|
if lbBindings.ItemIndex >= 0 then begin
|
||||||
|
FCurrentHandle := FHandles[lbBindings.ItemIndex];
|
||||||
|
end else begin
|
||||||
|
FCurrentHandle := nil;
|
||||||
|
end;
|
||||||
|
UpdateEditControls;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdDsnPropEdBindingVCL.SetList(const AList: string);
|
||||||
|
begin
|
||||||
|
FCurrentHandle := nil;
|
||||||
|
FillHandleList(AList, Handles);
|
||||||
|
UpdateBindingList;
|
||||||
|
UpdateEditControls;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdDsnPropEdBindingVCL.UpdateBindingList;
|
||||||
|
var
|
||||||
|
i: integer;
|
||||||
|
selected: integer;
|
||||||
|
s: string;
|
||||||
|
begin
|
||||||
|
//in Lazarus, for some odd reason, if you have more than one binding,
|
||||||
|
//the routine is called while the items are updated
|
||||||
|
if FInUpdateRoutine then begin
|
||||||
|
Exit;
|
||||||
|
end;
|
||||||
|
FInUpdateRoutine := True;
|
||||||
|
try
|
||||||
|
selected := lbBindings.ItemIndex;
|
||||||
|
lbBindings.Items.BeginUpdate;
|
||||||
|
try
|
||||||
|
if lbBindings.Items.Count = FHandles.Count then begin
|
||||||
|
for i := 0 to FHandles.Count - 1 do begin
|
||||||
|
s := GetDisplayString(FHandles[i]);
|
||||||
|
if s <> lbBindings.Items[i] then begin
|
||||||
|
lbBindings.Items[i] := s;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end else begin
|
||||||
|
lbBindings.Items.Clear;
|
||||||
|
for i := 0 to FHandles.Count-1 do begin
|
||||||
|
lbBindings.Items.Add(GetDisplayString(FHandles[i]));
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
lbBindings.Items.EndUpdate;
|
||||||
|
if Assigned(FCurrentHandle) then begin
|
||||||
|
lbBindings.ItemIndex := FCurrentHandle.Index;
|
||||||
|
end else begin
|
||||||
|
lbBindings.ItemIndex := IndyMin(selected, lbBindings.Items.Count-1);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
FInUpdateRoutine := False;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdDsnPropEdBindingVCL.Execute: Boolean;
|
||||||
|
begin
|
||||||
|
Result := ShowModal = mrOk;
|
||||||
|
end;
|
||||||
|
|
||||||
|
constructor TIdDsnPropEdBindingVCL.Create;
|
||||||
|
begin
|
||||||
|
Create(nil);
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
|
@ -0,0 +1,191 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.3 09/06/2004 09:52:34 CCostelloe
|
||||||
|
Kylix 3 patch
|
||||||
|
|
||||||
|
Rev 1.2 6/4/2004 5:12:56 PM SGrobety
|
||||||
|
added EIdMaxCaptureLineExceeded
|
||||||
|
|
||||||
|
Rev 1.1 2/10/2004 7:41:50 PM JPMugaas
|
||||||
|
I had to move EWrapperException down to the system package because
|
||||||
|
IdStackDotNET was using it and that would drage IdExceptionCore into the
|
||||||
|
package. Borland changed some behavior so the warning is now an error.
|
||||||
|
|
||||||
|
Rev 1.0 2004.02.03 4:19:48 PM czhower
|
||||||
|
Rename
|
||||||
|
|
||||||
|
Rev 1.15 11/4/2003 10:26:58 PM DSiders
|
||||||
|
Added exceptions moved from IdIOHandler.pas and IdTCPConnection.pas.
|
||||||
|
|
||||||
|
Rev 1.14 2003.10.16 11:24:00 AM czhower
|
||||||
|
Added IfAssigned
|
||||||
|
|
||||||
|
Rev 1.13 2003.10.11 5:47:58 PM czhower
|
||||||
|
-VCL fixes for servers
|
||||||
|
-Chain suport for servers (Super core)
|
||||||
|
-Scheduler upgrades
|
||||||
|
-Full yarn support
|
||||||
|
|
||||||
|
Rev 1.12 10/3/2003 11:38:36 PM GGrieve
|
||||||
|
Add EIdWrapperException
|
||||||
|
|
||||||
|
Rev 1.11 9/29/2003 02:56:28 PM JPMugaas
|
||||||
|
Added comment about why IdException.Create is virtual.
|
||||||
|
|
||||||
|
Rev 1.10 9/24/2003 11:42:50 PM JPMugaas
|
||||||
|
Minor changes to help compile under NET
|
||||||
|
|
||||||
|
Rev 1.9 2003.09.19 10:10:02 PM czhower
|
||||||
|
IfTrue, IfFalse
|
||||||
|
|
||||||
|
Rev 1.8 2003.09.19 11:54:28 AM czhower
|
||||||
|
-Completed more features necessary for servers
|
||||||
|
-Fixed some bugs
|
||||||
|
|
||||||
|
Rev 1.7 2003.07.17 4:57:04 PM czhower
|
||||||
|
Added new exception type so it can be added to debugger list of ignored
|
||||||
|
exceptions.
|
||||||
|
|
||||||
|
Rev 1.6 7/1/2003 8:33:02 PM BGooijen
|
||||||
|
Added EIdFibersNotSupported
|
||||||
|
|
||||||
|
Rev 1.5 2003.06.05 10:08:50 AM czhower
|
||||||
|
Extended reply mechanisms to the exception handling. Only base and RFC
|
||||||
|
completed, handing off to J Peter.
|
||||||
|
|
||||||
|
Rev 1.4 5/14/2003 2:59:58 PM BGooijen
|
||||||
|
Added exception for transparant proxy
|
||||||
|
|
||||||
|
Rev 1.3 2003.04.14 10:54:06 AM czhower
|
||||||
|
Fiber specific exceptions
|
||||||
|
|
||||||
|
Rev 1.2 4/2/2003 7:18:38 PM BGooijen
|
||||||
|
Added EIdHttpProxyError
|
||||||
|
|
||||||
|
Rev 1.1 1/17/2003 05:06:46 PM JPMugaas
|
||||||
|
Exceptions for scheduler string.
|
||||||
|
|
||||||
|
Rev 1.0 11/13/2002 08:44:10 AM JPMugaas
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdExceptionCore;
|
||||||
|
|
||||||
|
interface
|
||||||
|
{$I IdCompilerDefines.inc}
|
||||||
|
//needed to put FCP into Delphi mode
|
||||||
|
uses
|
||||||
|
IdException, IdStack;
|
||||||
|
|
||||||
|
type
|
||||||
|
// IdFiber Exceptions
|
||||||
|
EIdFiber = class(EIdException);
|
||||||
|
EIdFiberFinished = class(EIdFiber);
|
||||||
|
EIdFibersNotSupported = class(EIdFiber);
|
||||||
|
|
||||||
|
EIdAlreadyConnected = class(EIdException);
|
||||||
|
|
||||||
|
// EIdClosedSocket is raised if .Disconnect has been called and an operation is attempted
|
||||||
|
// or Connect has not been called
|
||||||
|
EIdClosedSocket = class(EIdException);
|
||||||
|
EIdResponseError = class(EIdException);
|
||||||
|
EIdReadTimeout = class(EIdException);
|
||||||
|
EIdAcceptTimeout = class(EIdException);
|
||||||
|
EIdReadLnMaxLineLengthExceeded = class(EIdException);
|
||||||
|
EIdReadLnWaitMaxAttemptsExceeded = class(EIdException);
|
||||||
|
|
||||||
|
// TIdTCPConnection exceptions
|
||||||
|
EIdPortRequired = class(EIdException);
|
||||||
|
EIdHostRequired = class(EIdException);
|
||||||
|
EIdTCPConnectionError = class(EIdException);
|
||||||
|
EIdObjectTypeNotSupported = class(EIdTCPConnectionError);
|
||||||
|
EIdInterceptPropIsNil = class(EIdTCPConnectionError);
|
||||||
|
EIdInterceptPropInvalid = class(EIdTCPConnectionError);
|
||||||
|
EIdIOHandlerPropInvalid = class(EIdTCPConnectionError);
|
||||||
|
EIdNoDataToRead = class(EIdTCPConnectionError);
|
||||||
|
EIdFileNotFound = class(EIdTCPConnectionError);
|
||||||
|
|
||||||
|
EIdNotConnected = class(EIdException);
|
||||||
|
|
||||||
|
EInvalidSyslogMessage = class(EIdException);
|
||||||
|
EIdSSLProtocolReplyError = class(EIdException);
|
||||||
|
EIdConnectTimeout = class(EIdException);
|
||||||
|
EIdConnectException = class(EIdException);
|
||||||
|
|
||||||
|
EIdTransparentProxyCantBind = class(EIdException);
|
||||||
|
|
||||||
|
EIdHttpProxyError = class(EIdException);
|
||||||
|
|
||||||
|
EIdSocksError = class(EIdException);
|
||||||
|
EIdSocksRequestFailed = class(EIdSocksError);
|
||||||
|
EIdSocksRequestServerFailed = class(EIdSocksError);
|
||||||
|
EIdSocksRequestIdentFailed = class(EIdSocksError);
|
||||||
|
EIdSocksUnknownError = class(EIdSocksError);
|
||||||
|
EIdSocksServerRespondError = class(EIdSocksError);
|
||||||
|
EIdSocksAuthMethodError = class(EIdSocksError);
|
||||||
|
EIdSocksAuthError = class(EIdSocksError);
|
||||||
|
EIdSocksServerGeneralError = class(EIdSocksError);
|
||||||
|
EIdSocksServerPermissionError = class (EIdSocksError);
|
||||||
|
EIdSocksServerNetUnreachableError = class (EIdSocksError);
|
||||||
|
EIdSocksServerHostUnreachableError = class (EIdSocksError);
|
||||||
|
EIdSocksServerConnectionRefusedError = class (EIdSocksError);
|
||||||
|
EIdSocksServerTTLExpiredError = class (EIdSocksError);
|
||||||
|
EIdSocksServerCommandError = class (EIdSocksError);
|
||||||
|
EIdSocksServerAddressError = class (EIdSocksError);
|
||||||
|
|
||||||
|
//IdIMAP4 Exception
|
||||||
|
EIdConnectionStateError = class(EIdException);
|
||||||
|
|
||||||
|
// THE EDnsResolverError is used so the resolver can repond to only resolver execeptions.
|
||||||
|
EIdDnsResolverError = Class(EIdException);
|
||||||
|
|
||||||
|
{Socket exceptions}
|
||||||
|
EIdInvalidSocket = class(EIdException);
|
||||||
|
|
||||||
|
EIdThreadMgrError = class(EIdException);
|
||||||
|
EIdThreadClassNotSpecified = class(EIdThreadMgrError);
|
||||||
|
|
||||||
|
{TIdTrivial FTP Exception }
|
||||||
|
EIdTFTPException = class(EIdException);
|
||||||
|
EIdTFTPFileNotFound = class(EIdTFTPException);
|
||||||
|
EIdTFTPAccessViolation = class(EIdTFTPException);
|
||||||
|
EIdTFTPAllocationExceeded = class(EIdTFTPException);
|
||||||
|
EIdTFTPIllegalOperation = class(EIdTFTPException);
|
||||||
|
EIdTFTPUnknownTransferID = class(EIdTFTPException);
|
||||||
|
EIdTFTPFileAlreadyExists = class(EIdTFTPException);
|
||||||
|
EIdTFTPNoSuchUser = class(EIdTFTPException);
|
||||||
|
EIdTFTPOptionNegotiationFailed = class(EIdTFTPException); // RFC 1782
|
||||||
|
|
||||||
|
{Icmp exceptions}
|
||||||
|
EIdIcmpException = class(EIdException);
|
||||||
|
|
||||||
|
EIdSetSizeExceeded = class(EIdException);
|
||||||
|
|
||||||
|
{IdMessage and things use this}
|
||||||
|
EIdMessageException = class(EIdException);
|
||||||
|
|
||||||
|
//scheduler exception
|
||||||
|
EIdSchedulerException = class(EIdException);
|
||||||
|
EIdSchedulerMaxThreadsExceeded = class(EIdSchedulerException);
|
||||||
|
|
||||||
|
{ IdIOHandler }
|
||||||
|
EIdMaxCaptureLineExceeded = class(EIdException); // S.G. 6/4/2004: triggered when a capture command exceeds the maximum number of line allowed
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
end.
|
|
@ -0,0 +1,48 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.2 8/16/2004 1:08:46 PM JPMugaas
|
||||||
|
Failed to compile in some IDE's.
|
||||||
|
|
||||||
|
Rev 1.1 2004.08.13 21:46:20 czhower
|
||||||
|
Fix for .NET
|
||||||
|
|
||||||
|
Rev 1.0 2004.08.13 10:54:58 czhower
|
||||||
|
Initial checkin
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdGlobalCore;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
{$I IdCompilerDefines.inc}
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes,
|
||||||
|
IdGlobal;
|
||||||
|
|
||||||
|
const
|
||||||
|
{$IFDEF UNIX}
|
||||||
|
tpListener = tpNormal;
|
||||||
|
{$ELSE}
|
||||||
|
tpListener = tpHighest;
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
end.
|
|
@ -0,0 +1,575 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.38 11/10/2004 8:25:54 AM JPMugaas
|
||||||
|
Fix for AV caused by short-circut boolean evaluation.
|
||||||
|
|
||||||
|
Rev 1.37 27.08.2004 21:58:20 Andreas Hausladen
|
||||||
|
Speed optimization ("const" for string parameters)
|
||||||
|
|
||||||
|
Rev 1.36 8/2/04 5:44:40 PM RLebeau
|
||||||
|
Moved ConnectTimeout over from TIdIOHandlerStack
|
||||||
|
|
||||||
|
Rev 1.35 7/21/2004 12:22:32 PM BGooijen
|
||||||
|
Fix to .connected
|
||||||
|
|
||||||
|
Rev 1.34 6/30/2004 12:31:34 PM BGooijen
|
||||||
|
Added OnSocketAllocated
|
||||||
|
|
||||||
|
Rev 1.33 4/24/04 12:52:52 PM RLebeau
|
||||||
|
Added setter method to UseNagle property
|
||||||
|
|
||||||
|
Rev 1.32 2004.04.18 12:52:02 AM czhower
|
||||||
|
Big bug fix with server disconnect and several other bug fixed that I found
|
||||||
|
along the way.
|
||||||
|
|
||||||
|
Rev 1.31 2004.02.03 4:16:46 PM czhower
|
||||||
|
For unit name changes.
|
||||||
|
|
||||||
|
Rev 1.30 2/2/2004 11:46:46 AM BGooijen
|
||||||
|
Dotnet and TransparentProxy
|
||||||
|
|
||||||
|
Rev 1.29 2/1/2004 9:44:00 PM JPMugaas
|
||||||
|
Start on reenabling Transparant proxy.
|
||||||
|
|
||||||
|
Rev 1.28 2004.01.20 10:03:28 PM czhower
|
||||||
|
InitComponent
|
||||||
|
|
||||||
|
Rev 1.27 1/2/2004 12:02:16 AM BGooijen
|
||||||
|
added OnBeforeBind/OnAfterBind
|
||||||
|
|
||||||
|
Rev 1.26 12/31/2003 9:51:56 PM BGooijen
|
||||||
|
Added IPv6 support
|
||||||
|
|
||||||
|
Rev 1.25 11/4/2003 10:37:40 PM BGooijen
|
||||||
|
JP's patch to fix the bound port
|
||||||
|
|
||||||
|
Rev 1.24 10/19/2003 5:21:26 PM BGooijen
|
||||||
|
SetSocketOption
|
||||||
|
|
||||||
|
Rev 1.23 10/18/2003 1:44:06 PM BGooijen
|
||||||
|
Added include
|
||||||
|
|
||||||
|
Rev 1.22 2003.10.14 1:26:54 PM czhower
|
||||||
|
Uupdates + Intercept support
|
||||||
|
|
||||||
|
Rev 1.21 10/9/2003 8:09:06 PM SPerry
|
||||||
|
bug fixes
|
||||||
|
|
||||||
|
Rev 1.20 8/10/2003 2:05:50 PM SGrobety
|
||||||
|
Dotnet
|
||||||
|
|
||||||
|
Rev 1.19 2003.10.07 10:18:26 PM czhower
|
||||||
|
Uncommneted todo code that is now non dotnet.
|
||||||
|
|
||||||
|
Rev 1.18 2003.10.02 8:23:42 PM czhower
|
||||||
|
DotNet Excludes
|
||||||
|
|
||||||
|
Rev 1.17 2003.10.01 9:11:18 PM czhower
|
||||||
|
.Net
|
||||||
|
|
||||||
|
Rev 1.16 2003.10.01 5:05:12 PM czhower
|
||||||
|
.Net
|
||||||
|
|
||||||
|
Rev 1.15 2003.10.01 2:46:38 PM czhower
|
||||||
|
.Net
|
||||||
|
|
||||||
|
Rev 1.14 2003.10.01 11:16:32 AM czhower
|
||||||
|
.Net
|
||||||
|
|
||||||
|
Rev 1.13 2003.09.30 1:22:58 PM czhower
|
||||||
|
Stack split for DotNet
|
||||||
|
|
||||||
|
Rev 1.12 7/4/2003 08:26:44 AM JPMugaas
|
||||||
|
Optimizations.
|
||||||
|
|
||||||
|
Rev 1.11 7/1/2003 03:39:44 PM JPMugaas
|
||||||
|
Started numeric IP function API calls for more efficiency.
|
||||||
|
|
||||||
|
Rev 1.10 2003.06.30 5:41:56 PM czhower
|
||||||
|
-Fixed AV that occurred sometimes when sockets were closed with chains
|
||||||
|
-Consolidated code that was marked by a todo for merging as it no longer
|
||||||
|
needed to be separate
|
||||||
|
-Removed some older code that was no longer necessary
|
||||||
|
|
||||||
|
Passes bubble tests.
|
||||||
|
|
||||||
|
Rev 1.9 6/3/2003 11:45:58 PM BGooijen
|
||||||
|
Added .Connected
|
||||||
|
|
||||||
|
Rev 1.8 2003.04.22 7:45:34 PM czhower
|
||||||
|
|
||||||
|
Rev 1.7 4/2/2003 3:24:56 PM BGooijen
|
||||||
|
Moved transparantproxy from ..stack to ..socket
|
||||||
|
|
||||||
|
Rev 1.6 2/28/2003 9:51:56 PM BGooijen
|
||||||
|
removed the field: FReadTimeout: Integer, it hided the one in TIdIOHandler
|
||||||
|
|
||||||
|
Rev 1.5 2/26/2003 1:15:38 PM BGooijen
|
||||||
|
FBinding is now freed in IdIOHandlerSocket, instead of in IdIOHandlerStack
|
||||||
|
|
||||||
|
Rev 1.4 2003.02.25 1:36:08 AM czhower
|
||||||
|
|
||||||
|
Rev 1.3 2002.12.07 12:26:26 AM czhower
|
||||||
|
|
||||||
|
Rev 1.2 12-6-2002 20:09:14 BGooijen
|
||||||
|
Changed SetDestination to search for the last ':', instead of the first
|
||||||
|
|
||||||
|
Rev 1.1 12-6-2002 18:54:14 BGooijen
|
||||||
|
Added IPv6-support
|
||||||
|
|
||||||
|
Rev 1.0 11/13/2002 08:45:08 AM JPMugaas
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdIOHandlerSocket;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
{$I IdCompilerDefines.inc}
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes,
|
||||||
|
IdCustomTransparentProxy,
|
||||||
|
IdBaseComponent,
|
||||||
|
IdGlobal,
|
||||||
|
IdIOHandler,
|
||||||
|
IdSocketHandle;
|
||||||
|
|
||||||
|
const
|
||||||
|
IdDefTimeout = 0;
|
||||||
|
IdBoundPortDefault = 0;
|
||||||
|
|
||||||
|
type
|
||||||
|
{
|
||||||
|
TIdIOHandlerSocket is the base class for socket IOHandlers that implement a
|
||||||
|
binding.
|
||||||
|
|
||||||
|
Descendants
|
||||||
|
-TIdIOHandlerStack
|
||||||
|
-TIdIOHandlerChain
|
||||||
|
}
|
||||||
|
TIdIOHandlerSocket = class(TIdIOHandler)
|
||||||
|
protected
|
||||||
|
FBinding: TIdSocketHandle;
|
||||||
|
FBoundIP: string;
|
||||||
|
FBoundPort: TIdPort;
|
||||||
|
FBoundPortMax: TIdPort;
|
||||||
|
FBoundPortMin: TIdPort;
|
||||||
|
FDefaultPort: TIdPort;
|
||||||
|
FOnBeforeBind: TNotifyEvent;
|
||||||
|
FOnAfterBind: TNotifyEvent;
|
||||||
|
FOnSocketAllocated: TNotifyEvent;
|
||||||
|
{$IFDEF USE_OBJECT_ARC}[Weak]{$ENDIF} FTransparentProxy: TIdCustomTransparentProxy;
|
||||||
|
FImplicitTransparentProxy: Boolean;
|
||||||
|
FUseNagle: Boolean;
|
||||||
|
FReuseSocket: TIdReuseSocket;
|
||||||
|
FIPVersion: TIdIPVersion;
|
||||||
|
//
|
||||||
|
procedure ConnectClient; virtual;
|
||||||
|
procedure DoBeforeBind; virtual;
|
||||||
|
procedure DoAfterBind; virtual;
|
||||||
|
procedure DoSocketAllocated; virtual;
|
||||||
|
procedure InitComponent; override;
|
||||||
|
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
|
||||||
|
function GetDestination: string; override;
|
||||||
|
procedure SetDestination(const AValue: string); override;
|
||||||
|
function GetReuseSocket: TIdReuseSocket;
|
||||||
|
procedure SetReuseSocket(AValue: TIdReuseSocket);
|
||||||
|
function GetTransparentProxy: TIdCustomTransparentProxy; virtual;
|
||||||
|
procedure SetTransparentProxy(AProxy: TIdCustomTransparentProxy); virtual;
|
||||||
|
function GetUseNagle: Boolean;
|
||||||
|
procedure SetUseNagle(AValue: Boolean);
|
||||||
|
//
|
||||||
|
function SourceIsAvailable: Boolean; override;
|
||||||
|
function CheckForError(ALastResult: Integer): Integer; override;
|
||||||
|
procedure RaiseError(AError: Integer); override;
|
||||||
|
public
|
||||||
|
procedure AfterAccept; override;
|
||||||
|
destructor Destroy; override;
|
||||||
|
function BindingAllocated: Boolean;
|
||||||
|
procedure Close; override;
|
||||||
|
function Connected: Boolean; override;
|
||||||
|
procedure Open; override;
|
||||||
|
function WriteFile(const AFile: String; AEnableTransferFile: Boolean = False): Int64; override;
|
||||||
|
//
|
||||||
|
property Binding: TIdSocketHandle read FBinding;
|
||||||
|
property BoundPortMax: TIdPort read FBoundPortMax write FBoundPortMax;
|
||||||
|
property BoundPortMin: TIdPort read FBoundPortMin write FBoundPortMin;
|
||||||
|
// events
|
||||||
|
property OnBeforeBind: TNotifyEvent read FOnBeforeBind write FOnBeforeBind;
|
||||||
|
property OnAfterBind: TNotifyEvent read FOnAfterBind write FOnAfterBind;
|
||||||
|
property OnSocketAllocated: TNotifyEvent read FOnSocketAllocated write FOnSocketAllocated;
|
||||||
|
published
|
||||||
|
property BoundIP: string read FBoundIP write FBoundIP;
|
||||||
|
property BoundPort: TIdPort read FBoundPort write FBoundPort default IdBoundPortDefault;
|
||||||
|
property DefaultPort: TIdPort read FDefaultPort write FDefaultPort;
|
||||||
|
property IPVersion: TIdIPVersion read FIPVersion write FIPVersion default ID_DEFAULT_IP_VERSION;
|
||||||
|
property ReuseSocket: TIdReuseSocket read GetReuseSocket write SetReuseSocket default rsOSDependent;
|
||||||
|
property TransparentProxy: TIdCustomTransparentProxy read GetTransparentProxy write SetTransparentProxy;
|
||||||
|
property UseNagle: boolean read GetUseNagle write SetUseNagle default True;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
//facilitate inlining only.
|
||||||
|
{$IFDEF DOTNET}
|
||||||
|
{$IFDEF USE_INLINE}
|
||||||
|
System.IO,
|
||||||
|
{$ENDIF}
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF WIN32_OR_WIN64 }
|
||||||
|
Windows,
|
||||||
|
{$ENDIF}
|
||||||
|
SysUtils,
|
||||||
|
IdStack,
|
||||||
|
IdStackConsts,
|
||||||
|
IdSocks;
|
||||||
|
|
||||||
|
{ TIdIOHandlerSocket }
|
||||||
|
|
||||||
|
procedure TIdIOHandlerSocket.AfterAccept;
|
||||||
|
begin
|
||||||
|
inherited AfterAccept;
|
||||||
|
FIPVersion := FBinding.IPVersion;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIOHandlerSocket.Close;
|
||||||
|
begin
|
||||||
|
if FBinding <> nil then begin
|
||||||
|
FBinding.CloseSocket;
|
||||||
|
end;
|
||||||
|
inherited Close;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIOHandlerSocket.ConnectClient;
|
||||||
|
var
|
||||||
|
LBinding: TIdSocketHandle;
|
||||||
|
begin
|
||||||
|
LBinding := Binding;
|
||||||
|
DoBeforeBind;
|
||||||
|
// Allocate the socket
|
||||||
|
LBinding.IPVersion := FIPVersion;
|
||||||
|
LBinding.AllocateSocket;
|
||||||
|
DoSocketAllocated;
|
||||||
|
// Bind the socket
|
||||||
|
if BoundIP <> '' then begin
|
||||||
|
LBinding.IP := BoundIP;
|
||||||
|
end;
|
||||||
|
LBinding.Port := BoundPort;
|
||||||
|
LBinding.ClientPortMin := BoundPortMin;
|
||||||
|
LBinding.ClientPortMax := BoundPortMax;
|
||||||
|
LBinding.ReuseSocket := FReuseSocket;
|
||||||
|
|
||||||
|
// RLebeau 11/15/2014: Using the socket bind() function in a Mac OSX sandbox
|
||||||
|
// causes the Apple store to reject an app with the following error if it
|
||||||
|
// uses Indy client(s) and no Indy server(s):
|
||||||
|
//
|
||||||
|
// "This app uses one or more entitlements which do not have matching
|
||||||
|
// functionality within the app. Apps should have only the minimum set of
|
||||||
|
// entitlements necessary for the app to function properly. Please remove
|
||||||
|
// all entitlements that are not needed by your app and submit an updated
|
||||||
|
// binary for review, including the following:
|
||||||
|
//
|
||||||
|
// com.apple.security.network.server"
|
||||||
|
//
|
||||||
|
// Ideally, TIdSocketHandle.Bind() should not call TryBind() if the IP is
|
||||||
|
// blank and the Port, ClientPortMin, and ClientPortMax are all 0. However,
|
||||||
|
// TIdSocketHandle.Bind() is used for both clients and servers, and sometimes
|
||||||
|
// a server needs to bind to port 0 to get a random ephemeral port, which it
|
||||||
|
// can then report to clients. So lets do the check here instead, as this
|
||||||
|
// method is only used for clients...
|
||||||
|
|
||||||
|
{$IFDEF DARWIN}
|
||||||
|
// TODO: remove the DARWIN check and just skip the Bind() on all platforms?
|
||||||
|
if (LBinding.IP <> '') or (LBinding.Port <> 0) or
|
||||||
|
((LBinding.ClientPortMin <> 0) and (LBinding.ClientPortMax <> 0)) then
|
||||||
|
begin
|
||||||
|
LBinding.Bind;
|
||||||
|
end;
|
||||||
|
{$ELSE}
|
||||||
|
LBinding.Bind;
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
// Turn off Nagle if specified
|
||||||
|
LBinding.UseNagle := FUseNagle;
|
||||||
|
DoAfterBind;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdIOHandlerSocket.Connected: Boolean;
|
||||||
|
begin
|
||||||
|
Result := (BindingAllocated and inherited Connected) or (not InputBufferIsEmpty);
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TIdIOHandlerSocket.Destroy;
|
||||||
|
begin
|
||||||
|
SetTransparentProxy(nil);
|
||||||
|
FreeAndNil(FBinding);
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIOHandlerSocket.DoBeforeBind;
|
||||||
|
begin
|
||||||
|
if Assigned(FOnBeforeBind) then begin
|
||||||
|
FOnBeforeBind(self);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIOHandlerSocket.DoAfterBind;
|
||||||
|
begin
|
||||||
|
if Assigned(FOnAfterBind) then begin
|
||||||
|
FOnAfterBind(self);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIOHandlerSocket.DoSocketAllocated;
|
||||||
|
begin
|
||||||
|
if Assigned(FOnSocketAllocated) then begin
|
||||||
|
FOnSocketAllocated(self);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdIOHandlerSocket.GetDestination: string;
|
||||||
|
begin
|
||||||
|
Result := Host;
|
||||||
|
if (Port <> DefaultPort) and (Port > 0) then begin
|
||||||
|
Result := Host + ':' + IntToStr(Port);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIOHandlerSocket.Open;
|
||||||
|
begin
|
||||||
|
inherited Open;
|
||||||
|
|
||||||
|
if not Assigned(FBinding) then begin
|
||||||
|
FBinding := TIdSocketHandle.Create(nil);
|
||||||
|
end else begin
|
||||||
|
FBinding.Reset(True);
|
||||||
|
end;
|
||||||
|
FBinding.ClientPortMin := BoundPortMin;
|
||||||
|
FBinding.ClientPortMax := BoundPortMax;
|
||||||
|
|
||||||
|
//if the IOHandler is used to accept connections then port+host will be empty
|
||||||
|
if (Host <> '') and (Port > 0) then begin
|
||||||
|
ConnectClient;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIOHandlerSocket.SetDestination(const AValue: string);
|
||||||
|
var
|
||||||
|
LPortStart: integer;
|
||||||
|
begin
|
||||||
|
// Bas Gooijen 06-Dec-2002: Changed to search the last ':', instead of the first:
|
||||||
|
LPortStart := LastDelimiter(':', AValue);
|
||||||
|
if LPortStart > 0 then begin
|
||||||
|
Host := Copy(AValue, 1, LPortStart-1);
|
||||||
|
Port := IndyStrToInt(Trim(Copy(AValue, LPortStart + 1, $FF)), DefaultPort);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdIOHandlerSocket.BindingAllocated: Boolean;
|
||||||
|
begin
|
||||||
|
Result := FBinding <> nil;
|
||||||
|
if Result then begin
|
||||||
|
Result := FBinding.HandleAllocated;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdIOHandlerSocket.WriteFile(const AFile: String;
|
||||||
|
AEnableTransferFile: Boolean): Int64;
|
||||||
|
{$IFDEF WIN32_OR_WIN64}
|
||||||
|
var
|
||||||
|
LOldErrorMode : Integer;
|
||||||
|
{$ENDIF}
|
||||||
|
begin
|
||||||
|
Result := 0;
|
||||||
|
{$IFDEF WIN32_OR_WIN64}
|
||||||
|
LOldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
|
||||||
|
try
|
||||||
|
{$ENDIF}
|
||||||
|
if FileExists(AFile) then begin
|
||||||
|
if Assigned(GServeFileProc) and (not WriteBufferingActive)
|
||||||
|
{and (Intercept = nil)} and AEnableTransferFile
|
||||||
|
then begin
|
||||||
|
Result := GServeFileProc(Binding.Handle, AFile);
|
||||||
|
Exit;
|
||||||
|
end
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
Result := inherited WriteFile(AFile, AEnableTransferFile);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
{$IFDEF WIN32_OR_WIN64}
|
||||||
|
finally
|
||||||
|
SetErrorMode(LOldErrorMode)
|
||||||
|
end;
|
||||||
|
{$ENDIF}
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdIOHandlerSocket.GetReuseSocket: TIdReuseSocket;
|
||||||
|
begin
|
||||||
|
if FBinding <> nil then begin
|
||||||
|
Result := FBinding.ReuseSocket;
|
||||||
|
end else begin
|
||||||
|
Result := FReuseSocket;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIOHandlerSocket.SetReuseSocket(AValue: TIdReuseSocket);
|
||||||
|
begin
|
||||||
|
FReuseSocket := AValue;
|
||||||
|
if FBinding <> nil then begin
|
||||||
|
FBinding.ReuseSocket := AValue;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIOHandlerSocket.SetTransparentProxy(AProxy : TIdCustomTransparentProxy);
|
||||||
|
var
|
||||||
|
LClass: TIdCustomTransparentProxyClass;
|
||||||
|
// under ARC, convert a weak reference to a strong reference before working with it
|
||||||
|
LTransparentProxy: TIdCustomTransparentProxy;
|
||||||
|
begin
|
||||||
|
LTransparentProxy := FTransparentProxy;
|
||||||
|
|
||||||
|
if LTransparentProxy <> AProxy then
|
||||||
|
begin
|
||||||
|
// All this is to preserve the compatibility with old version
|
||||||
|
// In the case when we have SocksInfo as object created in runtime without owner form it is treated as temporary object
|
||||||
|
// In the case when the ASocks points to an object with owner it is treated as component on form.
|
||||||
|
|
||||||
|
// under ARC, all weak references to a freed object get nil'ed automatically
|
||||||
|
|
||||||
|
if Assigned(AProxy) then begin
|
||||||
|
if not Assigned(AProxy.Owner) then begin
|
||||||
|
if Assigned(LTransparentProxy) and (not FImplicitTransparentProxy) then begin
|
||||||
|
FTransparentProxy := nil;
|
||||||
|
{$IFNDEF USE_OBJECT_ARC}
|
||||||
|
LTransparentProxy.RemoveFreeNotification(Self);
|
||||||
|
{$ENDIF}
|
||||||
|
end;
|
||||||
|
LClass := TIdCustomTransparentProxyClass(AProxy.ClassType);
|
||||||
|
if Assigned(LTransparentProxy) and (LTransparentProxy.ClassType <> LClass) then begin
|
||||||
|
FTransparentProxy := nil;
|
||||||
|
FImplicitTransparentProxy := False;
|
||||||
|
IdDisposeAndNil(LTransparentProxy);
|
||||||
|
end;
|
||||||
|
if not Assigned(LTransparentProxy) then begin
|
||||||
|
LTransparentProxy := LClass.Create(Self);
|
||||||
|
FTransparentProxy := LTransparentProxy;
|
||||||
|
FImplicitTransparentProxy := True;
|
||||||
|
end;
|
||||||
|
LTransparentProxy.Assign(AProxy);
|
||||||
|
end else begin
|
||||||
|
if Assigned(LTransparentProxy) then begin
|
||||||
|
if FImplicitTransparentProxy then begin
|
||||||
|
FTransparentProxy := nil;
|
||||||
|
FImplicitTransparentProxy := False;
|
||||||
|
IdDisposeAndNil(LTransparentProxy);
|
||||||
|
end else begin
|
||||||
|
{$IFNDEF USE_OBJECT_ARC}
|
||||||
|
LTransparentProxy.RemoveFreeNotification(Self);
|
||||||
|
{$ENDIF}
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
FTransparentProxy := AProxy;
|
||||||
|
{$IFNDEF USE_OBJECT_ARC}
|
||||||
|
AProxy.FreeNotification(Self);
|
||||||
|
{$ENDIF}
|
||||||
|
end;
|
||||||
|
end
|
||||||
|
else if Assigned(LTransparentProxy) then begin
|
||||||
|
if FImplicitTransparentProxy then begin
|
||||||
|
FTransparentProxy := nil;
|
||||||
|
FImplicitTransparentProxy := False;
|
||||||
|
IdDisposeAndNil(LTransparentProxy);
|
||||||
|
end else begin
|
||||||
|
FTransparentProxy := nil;
|
||||||
|
{$IFNDEF USE_OBJECT_ARC}
|
||||||
|
LTransparentProxy.RemoveFreeNotification(Self);
|
||||||
|
{$ENDIF}
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdIOHandlerSocket.GetTransparentProxy: TIdCustomTransparentProxy;
|
||||||
|
var
|
||||||
|
// under ARC, convert a weak reference to a strong reference before working with it
|
||||||
|
LTransparentProxy: TIdCustomTransparentProxy;
|
||||||
|
begin
|
||||||
|
LTransparentProxy := FTransparentProxy;
|
||||||
|
// Necessary at design time for Borland SOAP support
|
||||||
|
if LTransparentProxy = nil then begin
|
||||||
|
LTransparentProxy := TIdSocksInfo.Create(Self); //default
|
||||||
|
FTransparentProxy := LTransparentProxy;
|
||||||
|
FImplicitTransparentProxy := True;
|
||||||
|
end;
|
||||||
|
Result := LTransparentProxy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdIOHandlerSocket.GetUseNagle: Boolean;
|
||||||
|
begin
|
||||||
|
if FBinding <> nil then begin
|
||||||
|
Result := FBinding.UseNagle;
|
||||||
|
end else begin
|
||||||
|
Result := FUseNagle;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIOHandlerSocket.SetUseNagle(AValue: Boolean);
|
||||||
|
begin
|
||||||
|
FUseNagle := AValue;
|
||||||
|
if FBinding <> nil then begin
|
||||||
|
FBinding.UseNagle := AValue;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
// under ARC, all weak references to a freed object get nil'ed automatically
|
||||||
|
// so this is mostly redundant
|
||||||
|
procedure TIdIOHandlerSocket.Notification(AComponent: TComponent; Operation: TOperation);
|
||||||
|
begin
|
||||||
|
if (Operation = opRemove) and (AComponent = FTransparentProxy) then begin
|
||||||
|
FTransparentProxy := nil;
|
||||||
|
FImplicitTransparentProxy := False;
|
||||||
|
end;
|
||||||
|
inherited Notification(AComponent, Operation);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIOHandlerSocket.InitComponent;
|
||||||
|
begin
|
||||||
|
inherited InitComponent;
|
||||||
|
FUseNagle := True;
|
||||||
|
FIPVersion := ID_DEFAULT_IP_VERSION;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdIOHandlerSocket.SourceIsAvailable: Boolean;
|
||||||
|
begin
|
||||||
|
Result := BindingAllocated;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdIOHandlerSocket.CheckForError(ALastResult: Integer): Integer;
|
||||||
|
begin
|
||||||
|
Result := GStack.CheckForSocketError(ALastResult, [Id_WSAESHUTDOWN, Id_WSAECONNABORTED, Id_WSAECONNRESET, Id_WSAETIMEDOUT]);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIOHandlerSocket.RaiseError(AError: Integer);
|
||||||
|
begin
|
||||||
|
GStack.RaiseSocketError(AError);
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
|
@ -0,0 +1,442 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.53 3/10/05 3:23:16 PM RLebeau
|
||||||
|
Updated WriteDirect() to access the Intercept property directly.
|
||||||
|
|
||||||
|
Rev 1.52 11/12/2004 11:30:16 AM JPMugaas
|
||||||
|
Expansions for IPv6.
|
||||||
|
|
||||||
|
Rev 1.51 11/11/04 12:03:46 PM RLebeau
|
||||||
|
Updated DoConnectTimeout() to recognize IdTimeoutDefault
|
||||||
|
|
||||||
|
Rev 1.50 6/18/04 1:06:58 PM RLebeau
|
||||||
|
Bug fix for ReadTimeout property
|
||||||
|
|
||||||
|
Rev 1.49 5/4/2004 9:57:34 AM JPMugaas
|
||||||
|
Removed some old uncommented code and reenabled some TransparentProxy code
|
||||||
|
since it compile in DotNET.
|
||||||
|
|
||||||
|
Rev 1.48 2004.04.18 12:52:02 AM czhower
|
||||||
|
Big bug fix with server disconnect and several other bug fixed that I found
|
||||||
|
along the way.
|
||||||
|
|
||||||
|
Rev 1.47 2004.04.08 3:56:34 PM czhower
|
||||||
|
Fixed bug with Intercept byte count. Also removed Bytes from Buffer.
|
||||||
|
|
||||||
|
Rev 1.46 2004.03.12 8:01:00 PM czhower
|
||||||
|
Exception update
|
||||||
|
|
||||||
|
Rev 1.45 2004.03.07 11:48:42 AM czhower
|
||||||
|
Flushbuffer fix + other minor ones found
|
||||||
|
|
||||||
|
Rev 1.44 2004.03.01 5:12:32 PM czhower
|
||||||
|
-Bug fix for shutdown of servers when connections still existed (AV)
|
||||||
|
-Implicit HELP support in CMDserver
|
||||||
|
-Several command handler bugs
|
||||||
|
-Additional command handler functionality.
|
||||||
|
|
||||||
|
Rev 1.43 2/21/04 9:25:50 PM RLebeau
|
||||||
|
Fix for BBG #66
|
||||||
|
|
||||||
|
Added FLastSocketError member to TIdConnectThread
|
||||||
|
|
||||||
|
Rev 1.42 2004.02.03 4:16:48 PM czhower
|
||||||
|
For unit name changes.
|
||||||
|
|
||||||
|
Rev 1.41 12/31/2003 9:51:56 PM BGooijen
|
||||||
|
Added IPv6 support
|
||||||
|
|
||||||
|
Rev 1.40 2003.12.28 1:05:58 PM czhower
|
||||||
|
.Net changes.
|
||||||
|
|
||||||
|
Rev 1.39 11/21/2003 12:05:18 AM BGooijen
|
||||||
|
Terminated isn't public in TThread any more, made it public here now
|
||||||
|
|
||||||
|
Rev 1.38 10/28/2003 9:15:44 PM BGooijen
|
||||||
|
.net
|
||||||
|
|
||||||
|
Rev 1.37 10/18/2003 1:42:46 PM BGooijen
|
||||||
|
Added include
|
||||||
|
|
||||||
|
Rev 1.36 2003.10.14 1:26:56 PM czhower
|
||||||
|
Uupdates + Intercept support
|
||||||
|
|
||||||
|
Rev 1.35 2003.10.11 5:48:36 PM czhower
|
||||||
|
-VCL fixes for servers
|
||||||
|
-Chain suport for servers (Super core)
|
||||||
|
-Scheduler upgrades
|
||||||
|
-Full yarn support
|
||||||
|
|
||||||
|
Rev 1.34 10/9/2003 8:09:10 PM SPerry
|
||||||
|
bug fixes
|
||||||
|
|
||||||
|
Rev 1.33 10/5/2003 11:02:36 PM BGooijen
|
||||||
|
Write buffering
|
||||||
|
|
||||||
|
Rev 1.32 05/10/2003 23:01:02 HHariri
|
||||||
|
Fix for connect problem when IP address specified as opposed to host
|
||||||
|
|
||||||
|
Rev 1.31 2003.10.02 8:23:42 PM czhower
|
||||||
|
DotNet Excludes
|
||||||
|
|
||||||
|
Rev 1.30 2003.10.02 10:16:28 AM czhower
|
||||||
|
.Net
|
||||||
|
|
||||||
|
Rev 1.29 2003.10.01 9:11:18 PM czhower
|
||||||
|
.Net
|
||||||
|
|
||||||
|
Rev 1.28 2003.10.01 5:05:14 PM czhower
|
||||||
|
.Net
|
||||||
|
|
||||||
|
Rev 1.27 2003.10.01 2:46:38 PM czhower
|
||||||
|
.Net
|
||||||
|
|
||||||
|
Rev 1.26 2003.10.01 2:30:38 PM czhower
|
||||||
|
.Net
|
||||||
|
|
||||||
|
Rev 1.22 10/1/2003 12:14:14 AM BGooijen
|
||||||
|
DotNet: removing CheckForSocketError
|
||||||
|
|
||||||
|
Rev 1.21 2003.10.01 1:37:34 AM czhower
|
||||||
|
.Net
|
||||||
|
|
||||||
|
Rev 1.19 2003.09.30 1:22:58 PM czhower
|
||||||
|
Stack split for DotNet
|
||||||
|
|
||||||
|
Rev 1.18 2003.07.14 1:57:22 PM czhower
|
||||||
|
-First set of IOCP fixes.
|
||||||
|
-Fixed a threadsafe problem with the stack class.
|
||||||
|
|
||||||
|
Rev 1.17 2003.07.14 12:54:32 AM czhower
|
||||||
|
Fixed graceful close detection if it occurs after connect.
|
||||||
|
|
||||||
|
Rev 1.16 2003.07.10 4:34:58 PM czhower
|
||||||
|
Fixed AV, added some new comments
|
||||||
|
|
||||||
|
Rev 1.15 7/4/2003 08:26:46 AM JPMugaas
|
||||||
|
Optimizations.
|
||||||
|
|
||||||
|
Rev 1.14 7/1/2003 03:39:48 PM JPMugaas
|
||||||
|
Started numeric IP function API calls for more efficiency.
|
||||||
|
|
||||||
|
Rev 1.13 6/30/2003 10:25:18 AM BGooijen
|
||||||
|
removed unnecessary assignment to FRecvBuffer.Size
|
||||||
|
|
||||||
|
Rev 1.12 6/29/2003 10:56:28 PM BGooijen
|
||||||
|
Removed .Memory from the buffer, and added some extra methods
|
||||||
|
|
||||||
|
Rev 1.11 2003.06.25 4:28:32 PM czhower
|
||||||
|
Formatting and fixed a short circuit clause.
|
||||||
|
|
||||||
|
Rev 1.10 6/3/2003 11:43:52 PM BGooijen
|
||||||
|
Elimintated some code
|
||||||
|
|
||||||
|
Rev 1.9 4/16/2003 3:31:26 PM BGooijen
|
||||||
|
Removed InternalCheckForDisconnect, added .Connected
|
||||||
|
|
||||||
|
Rev 1.8 4/14/2003 11:44:20 AM BGooijen
|
||||||
|
CheckForDisconnect calls ReadFromSource now
|
||||||
|
|
||||||
|
Rev 1.7 4/2/2003 3:24:56 PM BGooijen
|
||||||
|
Moved transparantproxy from ..stack to ..socket
|
||||||
|
|
||||||
|
Rev 1.6 3/5/2003 11:04:32 PM BGooijen
|
||||||
|
Fixed Intercept, but the part in WriteBuffer doesn't look really nice yet
|
||||||
|
|
||||||
|
Rev 1.5 3/3/2003 11:31:58 PM BGooijen
|
||||||
|
fixed stack overflow in .CheckForDisconnect
|
||||||
|
|
||||||
|
Rev 1.4 2/26/2003 1:15:40 PM BGooijen
|
||||||
|
FBinding is now freed in IdIOHandlerSocket, instead of in IdIOHandlerStack
|
||||||
|
|
||||||
|
Rev 1.3 2003.02.25 1:36:12 AM czhower
|
||||||
|
|
||||||
|
Rev 1.2 2002.12.06 11:49:34 PM czhower
|
||||||
|
|
||||||
|
Rev 1.1 12-6-2002 20:10:18 BGooijen
|
||||||
|
Added IPv6-support
|
||||||
|
|
||||||
|
Rev 1.0 11/13/2002 08:45:16 AM JPMugaas
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdIOHandlerStack;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
{$i IdCompilerDefines.inc}
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes,
|
||||||
|
IdGlobal, IdSocketHandle, IdIOHandlerSocket, IdExceptionCore, IdStack,
|
||||||
|
SysUtils;
|
||||||
|
|
||||||
|
type
|
||||||
|
TIdIOHandlerStack = class(TIdIOHandlerSocket)
|
||||||
|
protected
|
||||||
|
procedure ConnectClient; override;
|
||||||
|
function ReadDataFromSource(var VBuffer: TIdBytes): Integer; override;
|
||||||
|
function WriteDataToTarget(const ABuffer: TIdBytes; const AOffset, ALength: Integer): Integer; override;
|
||||||
|
public
|
||||||
|
procedure CheckForDisconnect(ARaiseExceptionIfDisconnected: Boolean = True;
|
||||||
|
AIgnoreBuffer: Boolean = False); override;
|
||||||
|
function Connected: Boolean; override;
|
||||||
|
function Readable(AMSec: Integer = IdTimeoutDefault): Boolean; override;
|
||||||
|
published
|
||||||
|
property ReadTimeout;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
{$IFDEF USE_VCL_POSIX}
|
||||||
|
Posix.SysSelect,
|
||||||
|
Posix.SysTime,
|
||||||
|
{$ENDIF}
|
||||||
|
IdAntiFreezeBase, IdResourceStringsCore, IdResourceStrings, IdStackConsts, IdException,
|
||||||
|
IdTCPConnection, IdComponent, IdIOHandler;
|
||||||
|
|
||||||
|
type
|
||||||
|
TIdConnectThread = class(TThread)
|
||||||
|
protected
|
||||||
|
FBinding: TIdSocketHandle;
|
||||||
|
FLastSocketError: Integer;
|
||||||
|
FExceptionMessage: string;
|
||||||
|
FExceptionOccured: Boolean;
|
||||||
|
procedure Execute; override;
|
||||||
|
procedure DoTerminate; override;
|
||||||
|
public
|
||||||
|
constructor Create(ABinding: TIdSocketHandle); reintroduce;
|
||||||
|
property Terminated;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TIdIOHandlerStack }
|
||||||
|
|
||||||
|
function TIdIOHandlerStack.Connected: Boolean;
|
||||||
|
begin
|
||||||
|
ReadFromSource(False, 0, False);
|
||||||
|
Result := inherited Connected;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIOHandlerStack.ConnectClient;
|
||||||
|
|
||||||
|
procedure DoConnectTimeout(ATimeout: Integer);
|
||||||
|
var
|
||||||
|
LSleepTime: Integer;
|
||||||
|
LThread: TIdConnectThread;
|
||||||
|
begin
|
||||||
|
if ATimeout = IdTimeoutDefault then begin
|
||||||
|
ATimeout := IdTimeoutInfinite;
|
||||||
|
end;
|
||||||
|
LThread := TIdConnectThread.Create(Binding);
|
||||||
|
try
|
||||||
|
// IndySleep
|
||||||
|
if TIdAntiFreezeBase.ShouldUse then begin
|
||||||
|
LSleepTime := IndyMin(GAntiFreeze.IdleTimeOut, 125);
|
||||||
|
end else begin
|
||||||
|
LSleepTime := 125;
|
||||||
|
end;
|
||||||
|
|
||||||
|
if ATimeout = IdTimeoutInfinite then begin
|
||||||
|
while not LThread.Terminated do begin
|
||||||
|
IndySleep(LSleepTime);
|
||||||
|
TIdAntiFreezeBase.DoProcess;
|
||||||
|
end;
|
||||||
|
end else
|
||||||
|
begin
|
||||||
|
// TODO: we need to take the actual clock into account, not just
|
||||||
|
// decrement by the sleep interval. If IndySleep() runs longer then
|
||||||
|
// requested, that would slow down the loop and exceed the original
|
||||||
|
// timeout that was requested...
|
||||||
|
while (ATimeout > 0) and (not LThread.Terminated) do begin
|
||||||
|
IndySleep(IndyMin(ATimeout, LSleepTime));
|
||||||
|
TIdAntiFreezeBase.DoProcess;
|
||||||
|
Dec(ATimeout, IndyMin(ATimeout, LSleepTime));
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
if LThread.Terminated then begin
|
||||||
|
if LThread.FExceptionOccured then begin
|
||||||
|
// TODO: acquire the actual Exception object from TIdConnectThread and re-raise it here
|
||||||
|
if LThread.FLastSocketError <> 0 then begin
|
||||||
|
raise EIdSocketError.CreateError(LThread.FLastSocketError, LThread.FExceptionMessage);
|
||||||
|
end;
|
||||||
|
raise EIdConnectException.Create(LThread.FExceptionMessage);
|
||||||
|
end;
|
||||||
|
end else begin
|
||||||
|
LThread.Terminate;
|
||||||
|
Close;
|
||||||
|
LThread.WaitFor;
|
||||||
|
raise EIdConnectTimeout.Create(RSConnectTimeout);
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
LThread.Free;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
var
|
||||||
|
LHost: String;
|
||||||
|
LPort: Integer;
|
||||||
|
LIP: string;
|
||||||
|
LIPVersion : TIdIPVersion;
|
||||||
|
begin
|
||||||
|
inherited ConnectClient;
|
||||||
|
if Assigned(FTransparentProxy) then begin
|
||||||
|
if FTransparentProxy.Enabled then begin
|
||||||
|
LHost := FTransparentProxy.Host;
|
||||||
|
LPort := FTransparentProxy.Port;
|
||||||
|
LIPVersion := FTransparentProxy.IPVersion;
|
||||||
|
end else begin
|
||||||
|
LHost := Host;
|
||||||
|
LPort := Port;
|
||||||
|
LIPVersion := IPVersion;
|
||||||
|
end;
|
||||||
|
end else begin
|
||||||
|
LHost := Host;
|
||||||
|
LPort := Port;
|
||||||
|
LIPVersion := IPVersion;
|
||||||
|
end;
|
||||||
|
if LIPVersion = Id_IPv4 then
|
||||||
|
begin
|
||||||
|
if not GStack.IsIP(LHost) then begin
|
||||||
|
if Assigned(OnStatus) then begin
|
||||||
|
DoStatus(hsResolving, [LHost]);
|
||||||
|
end;
|
||||||
|
LIP := GStack.ResolveHost(LHost, LIPVersion);
|
||||||
|
end else begin
|
||||||
|
LIP := LHost;
|
||||||
|
end;
|
||||||
|
end
|
||||||
|
else
|
||||||
|
begin //IPv6
|
||||||
|
LIP := MakeCanonicalIPv6Address(LHost);
|
||||||
|
if LIP='' then begin //if MakeCanonicalIPv6Address failed, we have a hostname
|
||||||
|
if Assigned(OnStatus) then begin
|
||||||
|
DoStatus(hsResolving, [LHost]);
|
||||||
|
end;
|
||||||
|
LIP := GStack.ResolveHost(LHost, LIPVersion);
|
||||||
|
end else begin
|
||||||
|
LIP := LHost;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
Binding.SetPeer(LIP, LPort, LIPVersion);
|
||||||
|
// Connect
|
||||||
|
//note for status events, we check specifically for them here
|
||||||
|
//so we don't do a string conversion in Binding.PeerIP.
|
||||||
|
if Assigned(OnStatus) then begin
|
||||||
|
DoStatus(hsConnecting, [Binding.PeerIP]);
|
||||||
|
end;
|
||||||
|
|
||||||
|
if ConnectTimeout = 0 then begin
|
||||||
|
if TIdAntiFreezeBase.ShouldUse then begin
|
||||||
|
DoConnectTimeout(120000); // 2 Min
|
||||||
|
end else begin
|
||||||
|
Binding.Connect;
|
||||||
|
end;
|
||||||
|
end else begin
|
||||||
|
DoConnectTimeout(ConnectTimeout);
|
||||||
|
end;
|
||||||
|
if Assigned(FTransparentProxy) then begin
|
||||||
|
if FTransparentProxy.Enabled then begin
|
||||||
|
FTransparentProxy.Connect(Self, Host, Port, IPVersion);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdIOHandlerStack.Readable(AMSec: integer): boolean;
|
||||||
|
begin
|
||||||
|
Result := Binding.Readable(AMSec);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdIOHandlerStack.WriteDataToTarget(const ABuffer: TIdBytes; const AOffset, ALength: Integer): Integer;
|
||||||
|
begin
|
||||||
|
Assert(Binding<>nil);
|
||||||
|
Result := Binding.Send(ABuffer, AOffset, ALength);
|
||||||
|
end;
|
||||||
|
|
||||||
|
// Reads any data in tcp/ip buffer and puts it into Indy buffer
|
||||||
|
// This must be the ONLY raw read from Winsock routine
|
||||||
|
// This must be the ONLY call to RECV - all data goes thru this method
|
||||||
|
function TIdIOHandlerStack.ReadDataFromSource(var VBuffer: TIdBytes): Integer;
|
||||||
|
begin
|
||||||
|
Assert(Binding<>nil);
|
||||||
|
Result := Binding.Receive(VBuffer);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIOHandlerStack.CheckForDisconnect(
|
||||||
|
ARaiseExceptionIfDisconnected: Boolean; AIgnoreBuffer: Boolean);
|
||||||
|
var
|
||||||
|
LDisconnected: Boolean;
|
||||||
|
begin
|
||||||
|
// ClosedGracefully // Server disconnected
|
||||||
|
// IOHandler = nil // Client disconnected
|
||||||
|
if ClosedGracefully then begin
|
||||||
|
if BindingAllocated then begin
|
||||||
|
Close;
|
||||||
|
// Call event handlers to inform the user that we were disconnected
|
||||||
|
DoStatus(hsDisconnected);
|
||||||
|
//DoOnDisconnected;
|
||||||
|
end;
|
||||||
|
LDisconnected := True;
|
||||||
|
end else begin
|
||||||
|
LDisconnected := not BindingAllocated;
|
||||||
|
end;
|
||||||
|
// Do not raise unless all data has been read by the user
|
||||||
|
if LDisconnected then begin
|
||||||
|
if (InputBufferIsEmpty or AIgnoreBuffer) and ARaiseExceptionIfDisconnected then begin
|
||||||
|
RaiseConnClosedGracefully;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TIdConnectThread }
|
||||||
|
|
||||||
|
constructor TIdConnectThread.Create(ABinding: TIdSocketHandle);
|
||||||
|
begin
|
||||||
|
FBinding := ABinding;
|
||||||
|
inherited Create(False);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdConnectThread.Execute;
|
||||||
|
begin
|
||||||
|
try
|
||||||
|
FBinding.Connect;
|
||||||
|
except
|
||||||
|
on E: Exception do begin
|
||||||
|
// TODO: acquire the actual Exception object and re-raise it in TIdIOHandlerStack.ConnectClient()
|
||||||
|
FExceptionOccured := True;
|
||||||
|
FExceptionMessage := E.Message;
|
||||||
|
if E is EIdSocketError then begin
|
||||||
|
if (EIdSocketError(E).LastError <> Id_WSAEBADF) and (EIdSocketError(E).LastError <> Id_WSAENOTSOCK) then begin
|
||||||
|
FLastSocketError := EIdSocketError(E).LastError;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdConnectThread.DoTerminate;
|
||||||
|
begin
|
||||||
|
// Necessary as caller checks this
|
||||||
|
Terminate;
|
||||||
|
inherited;
|
||||||
|
end;
|
||||||
|
|
||||||
|
initialization
|
||||||
|
TIdIOHandlerStack.SetDefaultClass;
|
||||||
|
end.
|
|
@ -0,0 +1,332 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.21 3/10/05 3:24:30 PM RLebeau
|
||||||
|
Updated ReadFromSource() and WriteDirect() to access the Intercept property
|
||||||
|
directly.
|
||||||
|
|
||||||
|
Rev 1.20 10/21/2004 11:07:30 PM BGooijen
|
||||||
|
works in win32 now too
|
||||||
|
|
||||||
|
Rev 1.19 10/21/2004 1:52:56 PM BGooijen
|
||||||
|
Raid 214235
|
||||||
|
|
||||||
|
Rev 1.18 7/23/04 6:20:52 PM RLebeau
|
||||||
|
Removed memory leaks in Send/ReceiveStream property setters
|
||||||
|
|
||||||
|
Rev 1.17 2004.05.20 11:39:08 AM czhower
|
||||||
|
IdStreamVCL
|
||||||
|
|
||||||
|
Rev 1.16 23/04/2004 20:29:36 CCostelloe
|
||||||
|
Minor change to support IdMessageClient's new TIdIOHandlerStreamMsg
|
||||||
|
|
||||||
|
Rev 1.15 2004.04.16 11:30:32 PM czhower
|
||||||
|
Size fix to IdBuffer, optimizations, and memory leaks
|
||||||
|
|
||||||
|
Rev 1.14 2004.04.08 3:56:36 PM czhower
|
||||||
|
Fixed bug with Intercept byte count. Also removed Bytes from Buffer.
|
||||||
|
|
||||||
|
Rev 1.13 2004.03.07 11:48:46 AM czhower
|
||||||
|
Flushbuffer fix + other minor ones found
|
||||||
|
|
||||||
|
Rev 1.12 2004.03.03 11:55:04 AM czhower
|
||||||
|
IdStream change
|
||||||
|
|
||||||
|
Rev 1.11 2004.02.03 4:17:16 PM czhower
|
||||||
|
For unit name changes.
|
||||||
|
|
||||||
|
Rev 1.10 11/01/2004 19:52:44 CCostelloe
|
||||||
|
Revisions for TIdMessage SaveToFile & LoadFromFile for D7 & D8
|
||||||
|
|
||||||
|
Rev 1.8 08/01/2004 23:37:16 CCostelloe
|
||||||
|
Minor changes
|
||||||
|
|
||||||
|
Rev 1.7 1/8/2004 1:01:22 PM BGooijen
|
||||||
|
Cleaned up
|
||||||
|
|
||||||
|
Rev 1.6 1/8/2004 4:23:06 AM BGooijen
|
||||||
|
temp fixed TIdIOHandlerStream.WriteToDestination
|
||||||
|
|
||||||
|
Rev 1.5 08/01/2004 00:25:22 CCostelloe
|
||||||
|
Start of reimplementing LoadFrom/SaveToFile
|
||||||
|
|
||||||
|
Rev 1.4 2003.12.31 7:44:54 PM czhower
|
||||||
|
Matched constructors visibility to ancestor.
|
||||||
|
|
||||||
|
Rev 1.3 2003.10.24 10:44:54 AM czhower
|
||||||
|
IdStream implementation, bug fixes.
|
||||||
|
|
||||||
|
Rev 1.2 2003.10.14 11:19:14 PM czhower
|
||||||
|
Updated for better functionality.
|
||||||
|
|
||||||
|
Rev 1.1 2003.10.14 1:27:14 PM czhower
|
||||||
|
Uupdates + Intercept support
|
||||||
|
|
||||||
|
Rev 1.0 2003.10.13 6:40:40 PM czhower
|
||||||
|
Moved from root
|
||||||
|
|
||||||
|
Rev 1.9 2003.10.11 10:00:36 PM czhower
|
||||||
|
Compiles again.
|
||||||
|
|
||||||
|
Rev 1.8 10/10/2003 10:53:42 PM BGooijen
|
||||||
|
Changed const-ness of some methods to reflect base class changes
|
||||||
|
|
||||||
|
Rev 1.7 7/10/2003 6:07:58 PM SGrobety
|
||||||
|
.net
|
||||||
|
|
||||||
|
Rev 1.6 17/07/2003 00:01:24 CCostelloe
|
||||||
|
Added (empty) procedures for the base classes' abstract CheckForDataOnSource
|
||||||
|
and CheckForDisconnect
|
||||||
|
|
||||||
|
Rev 1.5 7/1/2003 12:45:56 PM BGooijen
|
||||||
|
changed FInputBuffer.Size := 0 to FInputBuffer.Clear
|
||||||
|
|
||||||
|
Rev 1.4 12-8-2002 21:05:28 BGooijen
|
||||||
|
Removed call to Close in .Destroy, this is already done in
|
||||||
|
TIdIOHandler.Destroy
|
||||||
|
|
||||||
|
Rev 1.3 12/7/2002 06:42:44 PM JPMugaas
|
||||||
|
These should now compile except for Socks server. IPVersion has to be a
|
||||||
|
property someplace for that.
|
||||||
|
|
||||||
|
Rev 1.2 12/5/2002 02:53:52 PM JPMugaas
|
||||||
|
Updated for new API definitions.
|
||||||
|
|
||||||
|
Rev 1.1 05/12/2002 15:29:16 AO'Neill
|
||||||
|
|
||||||
|
Rev 1.0 11/13/2002 07:55:08 AM JPMugaas
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdIOHandlerStream;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
{$I IdCompilerDefines.inc}
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes,
|
||||||
|
IdBaseComponent,
|
||||||
|
IdGlobal,
|
||||||
|
IdIOHandler,
|
||||||
|
IdStream;
|
||||||
|
|
||||||
|
type
|
||||||
|
TIdIOHandlerStream = class;
|
||||||
|
TIdIOHandlerStreamType = (stRead, stWrite, stReadWrite);
|
||||||
|
TIdOnGetStreams = procedure(ASender: TIdIOHandlerStream;
|
||||||
|
var VReceiveStream: TStream; var VSendStream: TStream) of object;
|
||||||
|
|
||||||
|
TIdIOHandlerStream = class(TIdIOHandler)
|
||||||
|
protected
|
||||||
|
FFreeStreams: Boolean;
|
||||||
|
FOnGetStreams: TIdOnGetStreams;
|
||||||
|
FReceiveStream: TStream;
|
||||||
|
FSendStream: TStream;
|
||||||
|
FStreamType: TIdIOHandlerStreamType;
|
||||||
|
//
|
||||||
|
procedure InitComponent; override;
|
||||||
|
function ReadDataFromSource(var VBuffer: TIdBytes): Integer; override;
|
||||||
|
function WriteDataToTarget(const ABuffer: TIdBytes; const AOffset, ALength: Integer): Integer; override;
|
||||||
|
function SourceIsAvailable: Boolean; override;
|
||||||
|
function CheckForError(ALastResult: Integer): Integer; override;
|
||||||
|
procedure RaiseError(AError: Integer); override;
|
||||||
|
public
|
||||||
|
function StreamingAvailable: Boolean;
|
||||||
|
procedure CheckForDisconnect(ARaiseExceptionIfDisconnected: Boolean = True;
|
||||||
|
AIgnoreBuffer: Boolean = False); override;
|
||||||
|
constructor Create(AOwner: TComponent; AReceiveStream: TStream; ASendStream: TStream = nil); reintroduce; overload; virtual;
|
||||||
|
constructor Create(AOwner: TComponent); reintroduce; overload;
|
||||||
|
function Connected: Boolean; override;
|
||||||
|
procedure Close; override;
|
||||||
|
procedure Open; override;
|
||||||
|
function Readable(AMSec: integer = IdTimeoutDefault): boolean; override;
|
||||||
|
//
|
||||||
|
property ReceiveStream: TStream read FReceiveStream;
|
||||||
|
property SendStream: TStream read FSendStream;
|
||||||
|
property StreamType: TIdIOHandlerStreamType read FStreamType;
|
||||||
|
published
|
||||||
|
property FreeStreams: Boolean read FFreeStreams write FFreeStreams default True;
|
||||||
|
//
|
||||||
|
property OnGetStreams: TIdOnGetStreams read FOnGetStreams write FOnGetStreams;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
IdException, IdComponent, SysUtils;
|
||||||
|
|
||||||
|
{ TIdIOHandlerStream }
|
||||||
|
|
||||||
|
procedure TIdIOHandlerStream.InitComponent;
|
||||||
|
begin
|
||||||
|
inherited InitComponent;
|
||||||
|
FDefStringEncoding := IndyTextEncoding_8Bit;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIOHandlerStream.CheckForDisconnect(
|
||||||
|
ARaiseExceptionIfDisconnected: Boolean = True;
|
||||||
|
AIgnoreBuffer: Boolean = False);
|
||||||
|
var
|
||||||
|
LDisconnected: Boolean;
|
||||||
|
begin
|
||||||
|
// ClosedGracefully // Server disconnected
|
||||||
|
// IOHandler = nil // Client disconnected
|
||||||
|
if ClosedGracefully then begin
|
||||||
|
if StreamingAvailable then begin
|
||||||
|
Close;
|
||||||
|
// Call event handlers to inform the user that we were disconnected
|
||||||
|
DoStatus(hsDisconnected);
|
||||||
|
//DoOnDisconnected;
|
||||||
|
end;
|
||||||
|
LDisconnected := True;
|
||||||
|
end else begin
|
||||||
|
LDisconnected := not StreamingAvailable;
|
||||||
|
end;
|
||||||
|
// Do not raise unless all data has been read by the user
|
||||||
|
if LDisconnected then begin
|
||||||
|
if (InputBufferIsEmpty or AIgnoreBuffer) and ARaiseExceptionIfDisconnected then begin
|
||||||
|
RaiseConnClosedGracefully;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIOHandlerStream.Close;
|
||||||
|
begin
|
||||||
|
inherited Close;
|
||||||
|
if FreeStreams then begin
|
||||||
|
FreeAndNil(FReceiveStream);
|
||||||
|
FreeAndNil(FSendStream);
|
||||||
|
end else begin
|
||||||
|
FReceiveStream := nil;
|
||||||
|
FSendStream := nil;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdIOHandlerStream.StreamingAvailable: Boolean;
|
||||||
|
begin
|
||||||
|
Result := False; // Just to avoid warning message
|
||||||
|
case FStreamType of
|
||||||
|
stRead: Result := Assigned(ReceiveStream);
|
||||||
|
stWrite: Result := Assigned(SendStream);
|
||||||
|
stReadWrite: Result := Assigned(ReceiveStream) and Assigned(SendStream);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdIOHandlerStream.Connected: Boolean;
|
||||||
|
begin
|
||||||
|
Result := (StreamingAvailable and inherited Connected) or (not InputBufferIsEmpty);
|
||||||
|
end;
|
||||||
|
|
||||||
|
constructor TIdIOHandlerStream.Create(AOwner: TComponent);
|
||||||
|
begin
|
||||||
|
inherited Create(AOwner);
|
||||||
|
FFreeStreams := True;
|
||||||
|
FStreamType := stReadWrite;
|
||||||
|
end;
|
||||||
|
|
||||||
|
constructor TIdIOHandlerStream.Create(AOwner: TComponent; AReceiveStream: TStream;
|
||||||
|
ASendStream: TStream = nil);
|
||||||
|
begin
|
||||||
|
inherited Create(AOwner);
|
||||||
|
//
|
||||||
|
FFreeStreams := True;
|
||||||
|
FReceiveStream := AReceiveStream;
|
||||||
|
FSendStream := ASendStream;
|
||||||
|
//
|
||||||
|
if Assigned(FReceiveStream) and (not Assigned(FSendStream)) then begin
|
||||||
|
FStreamType := stRead;
|
||||||
|
end else if (not Assigned(FReceiveStream)) and Assigned(FSendStream) then begin
|
||||||
|
FStreamType := stWrite;
|
||||||
|
end else begin
|
||||||
|
FStreamType := stReadWrite;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIOHandlerStream.Open;
|
||||||
|
begin
|
||||||
|
inherited Open;
|
||||||
|
if Assigned(OnGetStreams) then begin
|
||||||
|
OnGetStreams(Self, FReceiveStream, FSendStream);
|
||||||
|
end;
|
||||||
|
if Assigned(FReceiveStream) and (not Assigned(FSendStream)) then begin
|
||||||
|
FStreamType := stRead;
|
||||||
|
end else if (not Assigned(FReceiveStream)) and Assigned(FSendStream) then begin
|
||||||
|
FStreamType := stWrite;
|
||||||
|
end else begin
|
||||||
|
FStreamType := stReadWrite;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdIOHandlerStream.Readable(AMSec: Integer): Boolean;
|
||||||
|
begin
|
||||||
|
Result := Assigned(ReceiveStream);
|
||||||
|
// RLebeau: not checking the Position anymore. Was
|
||||||
|
// causing deadlocks when trying to read past EOF.
|
||||||
|
// This way, when EOF is reached, ReadFromSource()
|
||||||
|
// will return 0, which will be interpretted as the
|
||||||
|
// connnection being closed...
|
||||||
|
{
|
||||||
|
if Result then begin
|
||||||
|
Result := ReceiveStream.Position < ReceiveStream.Size;
|
||||||
|
end;
|
||||||
|
}
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdIOHandlerStream.ReadDataFromSource(var VBuffer: TIdBytes): Integer;
|
||||||
|
begin
|
||||||
|
// We dont want to read the whole stream in at a time. If its a big
|
||||||
|
// file will consume way too much memory by loading it all at once.
|
||||||
|
// So lets read it in chunks.
|
||||||
|
if Assigned(FReceiveStream) then begin
|
||||||
|
Result := IndyMin(32 * 1024, Length(VBuffer));
|
||||||
|
if Result > 0 then begin
|
||||||
|
Result := TIdStreamHelper.ReadBytes(FReceiveStream, VBuffer, Result);
|
||||||
|
end;
|
||||||
|
end else begin
|
||||||
|
Result := 0;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdIOHandlerStream.WriteDataToTarget(const ABuffer: TIdBytes; const AOffset, ALength: Integer): Integer;
|
||||||
|
begin
|
||||||
|
if Assigned(FSendStream) then begin
|
||||||
|
Result := TIdStreamHelper.Write(FSendStream, ABuffer, ALength, AOffset);
|
||||||
|
end else begin
|
||||||
|
Result := IndyLength(ABuffer, ALength, AOffset);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdIOHandlerStream.SourceIsAvailable: Boolean;
|
||||||
|
begin
|
||||||
|
Result := Assigned(ReceiveStream);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdIOHandlerStream.CheckForError(ALastResult: Integer): Integer;
|
||||||
|
begin
|
||||||
|
Result := ALastResult;
|
||||||
|
if Result < 0 then begin
|
||||||
|
raise EIdException.Create('Stream error'); {do not localize}
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIOHandlerStream.RaiseError(AError: Integer);
|
||||||
|
begin
|
||||||
|
raise EIdException.Create('Stream error'); {do not localize}
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
|
@ -0,0 +1,293 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.10 2/8/05 5:29:16 PM RLebeau
|
||||||
|
Updated GetHToNBytes() to use CopyTIdWord() instead of AppendBytes() for IPv6
|
||||||
|
addresses.
|
||||||
|
|
||||||
|
Rev 1.9 28.09.2004 20:54:32 Andreas Hausladen
|
||||||
|
Removed unused functions that were moved to IdGlobal
|
||||||
|
|
||||||
|
Rev 1.8 6/11/2004 8:48:20 AM DSiders
|
||||||
|
Added "Do not Localize" comments.
|
||||||
|
|
||||||
|
Rev 1.7 5/19/2004 10:44:34 PM DSiders
|
||||||
|
Corrected spelling for TIdIPAddress.MakeAddressObject method.
|
||||||
|
|
||||||
|
Rev 1.6 14/04/2004 17:35:38 HHariri
|
||||||
|
Removed IP6 for BCB temporarily
|
||||||
|
|
||||||
|
Rev 1.5 2/11/2004 5:10:40 AM JPMugaas
|
||||||
|
Moved IPv6 address definition to System package.
|
||||||
|
|
||||||
|
Rev 1.4 2004.02.03 4:17:18 PM czhower
|
||||||
|
For unit name changes.
|
||||||
|
|
||||||
|
Rev 1.3 2/2/2004 12:22:24 PM JPMugaas
|
||||||
|
Now uses IdGlobal IPVersion Type. Added HToNBytes for things that need
|
||||||
|
to export into NetworkOrder for structures used in protocols.
|
||||||
|
|
||||||
|
Rev 1.2 1/3/2004 2:13:56 PM JPMugaas
|
||||||
|
Removed some empty function code that wasn't used.
|
||||||
|
Added some value comparison functions.
|
||||||
|
Added a function in the IPAddress object for comparing the value with another
|
||||||
|
IP address. Note that this comparison is useful as an IP address will take
|
||||||
|
several forms (especially common with IPv6).
|
||||||
|
Added a property for returning the IP address as a string which works for
|
||||||
|
both IPv4 and IPv6 addresses.
|
||||||
|
|
||||||
|
Rev 1.1 1/3/2004 1:03:14 PM JPMugaas
|
||||||
|
Removed Lo as it was not needed and is not safe in NET.
|
||||||
|
|
||||||
|
Rev 1.0 1/1/2004 4:00:18 PM JPMugaas
|
||||||
|
An object for handling both IPv4 and IPv6 addresses. This is a proposal with
|
||||||
|
some old code for conversions.
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdIPAddress;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
{$I IdCompilerDefines.inc}
|
||||||
|
//we need to put this in Delphi mode to work
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes,
|
||||||
|
IdGlobal;
|
||||||
|
|
||||||
|
type
|
||||||
|
TIdIPAddress = class(TObject)
|
||||||
|
protected
|
||||||
|
FIPv4 : UInt32;
|
||||||
|
FAddrType : TIdIPVersion;
|
||||||
|
//general conversion stuff
|
||||||
|
//property as String Get methods
|
||||||
|
function GetIPv4AsString : String;
|
||||||
|
function GetIPv6AsString : String;
|
||||||
|
function GetIPAddress : String;
|
||||||
|
public
|
||||||
|
//We can't make this into a property for C++Builder
|
||||||
|
IPv6 : TIdIPv6Address;
|
||||||
|
|
||||||
|
constructor Create; virtual;
|
||||||
|
class function MakeAddressObject(const AIP : String) : TIdIPAddress; overload;
|
||||||
|
class function MakeAddressObject(const AIP : String; const AIPVersion: TIdIPVersion) : TIdIPAddress; overload;
|
||||||
|
function CompareAddress(const AIP : String; var VErr : Boolean) : Integer;
|
||||||
|
function HToNBytes: TIdBytes;
|
||||||
|
|
||||||
|
property IPv4 : UInt32 read FIPv4 write FIPv4;
|
||||||
|
property IPv4AsString : String read GetIPv4AsString;
|
||||||
|
property IPv6AsString : String read GetIPv6AsString;
|
||||||
|
property AddrType : TIdIPVersion read FAddrType write FAddrType;
|
||||||
|
property IPAsString : String read GetIPAddress;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
IdStack, SysUtils;
|
||||||
|
|
||||||
|
//IPv4 address conversion
|
||||||
|
//Much of this is based on http://www.pc-help.org/obscure.htm
|
||||||
|
|
||||||
|
function CompareUInt16(const AWord1, AWord2 : UInt16) : Integer;
|
||||||
|
{$IFDEF USE_INLINE}inline;{$ENDIF}
|
||||||
|
{
|
||||||
|
AWord1 > AWord2 > 0
|
||||||
|
AWord1 < AWord2 < 0
|
||||||
|
AWord1 = AWord2 = 0
|
||||||
|
}
|
||||||
|
begin
|
||||||
|
if AWord1 > AWord2 then begin
|
||||||
|
Result := 1;
|
||||||
|
end else if AWord1 < AWord2 then begin
|
||||||
|
Result := -1;
|
||||||
|
end else begin
|
||||||
|
Result := 0;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function CompareUInt32(const ACard1, ACard2 : UInt32) : Integer;
|
||||||
|
{$IFDEF USE_INLINE}inline;{$ENDIF}
|
||||||
|
{
|
||||||
|
ACard1 > ACard2 > 0
|
||||||
|
ACard1 < ACard2 < 0
|
||||||
|
ACard1 = ACard2 = 0
|
||||||
|
}
|
||||||
|
begin
|
||||||
|
if ACard1 > ACard2 then begin
|
||||||
|
Result := 1;
|
||||||
|
end else if ACard1 < ACard2 then begin
|
||||||
|
Result := -1;
|
||||||
|
end else begin
|
||||||
|
Result := 0;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TIdIPAddress }
|
||||||
|
|
||||||
|
function TIdIPAddress.CompareAddress(const AIP: String; var VErr: Boolean): Integer;
|
||||||
|
var
|
||||||
|
LIP2 : TIdIPAddress;
|
||||||
|
i : Integer;
|
||||||
|
{
|
||||||
|
Note that the IP address in the object is S1.
|
||||||
|
S1 > S2 > 0
|
||||||
|
S1 < S2 < 0
|
||||||
|
S1 = S2 = 0
|
||||||
|
}
|
||||||
|
begin
|
||||||
|
Result := 0;
|
||||||
|
//LIP2 may be nil if the IP address is invalid
|
||||||
|
LIP2 := MakeAddressObject(AIP);
|
||||||
|
VErr := not Assigned(LIP2);
|
||||||
|
if not VErr then begin
|
||||||
|
try
|
||||||
|
// we can't compare an IPv4 address with an IPv6 address
|
||||||
|
VErr := FAddrType <> LIP2.FAddrType;
|
||||||
|
if not VErr then begin
|
||||||
|
if FAddrType = Id_IPv4 then begin
|
||||||
|
Result := CompareUInt32(FIPv4, LIP2.FIPv4);
|
||||||
|
end else begin
|
||||||
|
for I := 0 to 7 do begin
|
||||||
|
Result := CompareUInt16(IPv6[i], LIP2.IPv6[i]);
|
||||||
|
if Result <> 0 then begin
|
||||||
|
Break;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
FreeAndNil(LIP2);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
constructor TIdIPAddress.Create;
|
||||||
|
begin
|
||||||
|
inherited Create;
|
||||||
|
FAddrType := Id_IPv4;
|
||||||
|
FIPv4 := 0; //'0.0.0.0'
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdIPAddress.HToNBytes: TIdBytes;
|
||||||
|
var
|
||||||
|
I : Integer;
|
||||||
|
begin
|
||||||
|
if FAddrType = Id_IPv4 then begin
|
||||||
|
Result := ToBytes(GStack.HostToNetwork(FIPv4));
|
||||||
|
end else begin
|
||||||
|
SetLength(Result, 16);
|
||||||
|
for I := 0 to 7 do begin
|
||||||
|
CopyTIdUInt16(GStack.HostToNetwork(IPv6[i]), Result, 2*I);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdIPAddress.GetIPAddress: String;
|
||||||
|
begin
|
||||||
|
if FAddrType = Id_IPv4 then begin
|
||||||
|
Result := GetIPv4AsString;
|
||||||
|
end else begin
|
||||||
|
Result := GetIPv6AsString;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdIPAddress.GetIPv4AsString: String;
|
||||||
|
begin
|
||||||
|
if FAddrType = Id_IPv4 then begin
|
||||||
|
Result := IntToStr((FIPv4 shr 24) and $FF) + '.';
|
||||||
|
Result := Result + IntToStr((FIPv4 shr 16) and $FF) + '.';
|
||||||
|
Result := Result + IntToStr((FIPv4 shr 8) and $FF) + '.';
|
||||||
|
Result := Result + IntToStr(FIPv4 and $FF);
|
||||||
|
end else begin
|
||||||
|
Result := '';
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdIPAddress.GetIPv6AsString: String;
|
||||||
|
var
|
||||||
|
I: Integer;
|
||||||
|
begin
|
||||||
|
if FAddrType = Id_IPv6 then begin
|
||||||
|
Result := IntToHex(IPv6[0], 4);
|
||||||
|
for i := 1 to 7 do begin
|
||||||
|
Result := Result + ':' + IntToHex(IPv6[i], 4);
|
||||||
|
end;
|
||||||
|
end else begin
|
||||||
|
Result := '';
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
class function TIdIPAddress.MakeAddressObject(const AIP: String): TIdIPAddress;
|
||||||
|
var
|
||||||
|
LErr : Boolean;
|
||||||
|
begin
|
||||||
|
Result := TIdIPAddress.Create;
|
||||||
|
try
|
||||||
|
IPv6ToIdIPv6Address(AIP, Result.IPv6, LErr);
|
||||||
|
if not LErr then begin
|
||||||
|
Result.FAddrType := Id_IPv6;
|
||||||
|
Exit;
|
||||||
|
end;
|
||||||
|
Result.FIPv4 := IPv4ToUInt32(AIP, LErr);
|
||||||
|
if not LErr then begin
|
||||||
|
Result.FAddrType := Id_IPv4;
|
||||||
|
Exit;
|
||||||
|
end;
|
||||||
|
//this is not a valid IP address
|
||||||
|
FreeAndNil(Result);
|
||||||
|
except
|
||||||
|
FreeAndNil(Result);
|
||||||
|
raise;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
class function TIdIPAddress.MakeAddressObject(const AIP: String; const AIPVersion: TIdIPVersion): TIdIPAddress;
|
||||||
|
var
|
||||||
|
LErr : Boolean;
|
||||||
|
begin
|
||||||
|
Result := TIdIPAddress.Create;
|
||||||
|
try
|
||||||
|
case AIPVersion of
|
||||||
|
Id_IPV4:
|
||||||
|
begin
|
||||||
|
Result.FIPv4 := IPv4ToUInt32(AIP, LErr);
|
||||||
|
if not LErr then begin
|
||||||
|
Result.FAddrType := Id_IPv4;
|
||||||
|
Exit;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
Id_IPv6:
|
||||||
|
begin
|
||||||
|
IPv6ToIdIPv6Address(AIP, Result.IPv6, LErr);
|
||||||
|
if not LErr then begin
|
||||||
|
Result.FAddrType := Id_IPv6;
|
||||||
|
Exit;
|
||||||
|
end
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
//this is not a valid IP address
|
||||||
|
FreeAndNil(Result);
|
||||||
|
except
|
||||||
|
FreeAndNil(Result);
|
||||||
|
raise;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
|
@ -0,0 +1,257 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.4 2004.02.03 5:43:52 PM czhower
|
||||||
|
Name changes
|
||||||
|
|
||||||
|
Rev 1.3 1/21/2004 3:11:06 PM JPMugaas
|
||||||
|
InitComponent
|
||||||
|
|
||||||
|
Rev 1.2 10/26/2003 09:11:50 AM JPMugaas
|
||||||
|
Should now work in NET.
|
||||||
|
|
||||||
|
Rev 1.1 2003.10.12 4:03:56 PM czhower
|
||||||
|
compile todos
|
||||||
|
|
||||||
|
Rev 1.0 11/13/2002 07:55:16 AM JPMugaas
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdIPMCastBase;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
{$I IdCompilerDefines.inc}
|
||||||
|
//here to flip FPC into Delphi mode
|
||||||
|
|
||||||
|
uses
|
||||||
|
{$IFDEF WORKAROUND_INLINE_CONSTRUCTORS}
|
||||||
|
Classes,
|
||||||
|
{$ENDIF}
|
||||||
|
IdComponent, IdException, IdGlobal, IdSocketHandle,
|
||||||
|
IdStack;
|
||||||
|
|
||||||
|
(*$HPPEMIT '#if defined(_VCL_ALIAS_RECORDS)' *)
|
||||||
|
(*$HPPEMIT '#if !defined(UNICODE)' *)
|
||||||
|
(*$HPPEMIT '#pragma alias "@Idipmcastbase@TIdIPMCastBase@SetPortA$qqrxi"="@Idipmcastbase@TIdIPMCastBase@SetPort$qqrxi"' *)
|
||||||
|
(*$HPPEMIT '#else' *)
|
||||||
|
(*$HPPEMIT '#pragma alias "@Idipmcastbase@TIdIPMCastBase@SetPortW$qqrxi"="@Idipmcastbase@TIdIPMCastBase@SetPort$qqrxi"' *)
|
||||||
|
(*$HPPEMIT '#endif' *)
|
||||||
|
(*$HPPEMIT '#endif' *)
|
||||||
|
|
||||||
|
const
|
||||||
|
IPMCastLo = 224;
|
||||||
|
IPMCastHi = 239;
|
||||||
|
|
||||||
|
type
|
||||||
|
TIdIPMv6Scope = ( IdIPv6MC_InterfaceLocal,
|
||||||
|
{ Interface-Local scope spans only a single interface on a node
|
||||||
|
and is useful only for loopback transmission of multicast.}
|
||||||
|
IdIPv6MC_LinkLocal,
|
||||||
|
{ Link-Local multicast scope spans the same topological region as
|
||||||
|
the corresponding unicast scope. }
|
||||||
|
IdIPv6MC_AdminLocal,
|
||||||
|
{ Admin-Local scope is the smallest scope that must be
|
||||||
|
administratively configured, i.e., not automatically derived
|
||||||
|
from physical connectivity or other, non-multicast-related
|
||||||
|
configuration.}
|
||||||
|
IdIPv6MC_SiteLocal,
|
||||||
|
{ Site-Local scope is intended to span a single site. }
|
||||||
|
IdIPv6MC_OrgLocal,
|
||||||
|
{Organization-Local scope is intended to span multiple sites
|
||||||
|
belonging to a single organization.}
|
||||||
|
IdIPv6MC_Global);
|
||||||
|
|
||||||
|
TIdIPMCValidScopes = 0..$F;
|
||||||
|
|
||||||
|
TIdIPMCastBase = class(TIdComponent)
|
||||||
|
protected
|
||||||
|
FDsgnActive: Boolean;
|
||||||
|
FMulticastGroup: String;
|
||||||
|
FPort: Integer;
|
||||||
|
FIPVersion: TIdIPVersion;
|
||||||
|
FReuseSocket: TIdReuseSocket;
|
||||||
|
//
|
||||||
|
procedure CloseBinding; virtual; abstract;
|
||||||
|
function GetActive: Boolean; virtual;
|
||||||
|
function GetBinding: TIdSocketHandle; virtual; abstract;
|
||||||
|
procedure Loaded; override;
|
||||||
|
procedure SetActive(const Value: Boolean); virtual;
|
||||||
|
procedure SetMulticastGroup(const Value: string); virtual;
|
||||||
|
procedure SetPort(const Value: integer); virtual;
|
||||||
|
function GetIPVersion: TIdIPVersion; virtual;
|
||||||
|
procedure SetIPVersion(const AValue: TIdIPVersion); virtual;
|
||||||
|
//
|
||||||
|
property Active: Boolean read GetActive write SetActive Default False;
|
||||||
|
property MulticastGroup: string read FMulticastGroup write SetMulticastGroup;
|
||||||
|
property Port: Integer read FPort write SetPort;
|
||||||
|
property IPVersion: TIdIPVersion read GetIPVersion write SetIPVersion default ID_DEFAULT_IP_VERSION;
|
||||||
|
procedure InitComponent; override;
|
||||||
|
public
|
||||||
|
{$IFDEF WORKAROUND_INLINE_CONSTRUCTORS}
|
||||||
|
constructor Create(AOwner: TComponent); reintroduce; overload;
|
||||||
|
{$ENDIF}
|
||||||
|
function IsValidMulticastGroup(const Value: string): Boolean;
|
||||||
|
{These two items are helper functions that allow you to specify the scope for
|
||||||
|
a Variable Scope Multicast Addresses. Some are listed in IdAssignedNumbers
|
||||||
|
as the Id_IPv6MC_V_ constants. You can't use them out of the box in the
|
||||||
|
MulticastGroup property because you need to specify the scope. This provides
|
||||||
|
you with more flexibility than you would get with IPv4 multicasting.}
|
||||||
|
class function SetIPv6AddrScope(const AVarIPv6Addr : String; const AScope : TIdIPMv6Scope ) : String; overload;
|
||||||
|
class function SetIPv6AddrScope(const AVarIPv6Addr : String; const AScope : TIdIPMCValidScopes): String; overload;
|
||||||
|
//
|
||||||
|
property ReuseSocket: TIdReuseSocket read FReuseSocket write FReuseSocket default rsOSDependent;
|
||||||
|
published
|
||||||
|
end;
|
||||||
|
|
||||||
|
EIdMCastException = Class(EIdException);
|
||||||
|
EIdMCastNoBindings = class(EIdMCastException);
|
||||||
|
EIdMCastNotValidAddress = class(EIdMCastException);
|
||||||
|
EIdMCastReceiveErrorZeroBytes = class(EIdMCastException);
|
||||||
|
|
||||||
|
const
|
||||||
|
DEF_IPv6_MGROUP = 'FF01:0:0:0:0:0:0:1';
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
IdAssignedNumbers,
|
||||||
|
IdResourceStringsCore, IdStackConsts, SysUtils;
|
||||||
|
|
||||||
|
{ TIdIPMCastBase }
|
||||||
|
|
||||||
|
{$IFDEF WORKAROUND_INLINE_CONSTRUCTORS}
|
||||||
|
constructor TIdIPMCastBase.Create(AOwner: TComponent);
|
||||||
|
begin
|
||||||
|
inherited Create(AOwner);
|
||||||
|
end;
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
function TIdIPMCastBase.GetIPVersion: TIdIPVersion;
|
||||||
|
begin
|
||||||
|
Result := FIPVersion;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIPMCastBase.InitComponent;
|
||||||
|
begin
|
||||||
|
inherited InitComponent;
|
||||||
|
FMultiCastGroup := Id_IPMC_All_Systems;
|
||||||
|
FIPVersion := ID_DEFAULT_IP_VERSION;
|
||||||
|
FReuseSocket := rsOSDependent;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdIPMCastBase.GetActive: Boolean;
|
||||||
|
begin
|
||||||
|
Result := FDsgnActive;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdIPMCastBase.IsValidMulticastGroup(const Value: string): Boolean;
|
||||||
|
begin
|
||||||
|
//just here to prevent a warning from Delphi about an unitialized result
|
||||||
|
Result := False;
|
||||||
|
case FIPVersion of
|
||||||
|
Id_IPv4 : Result := GStack.IsValidIPv4MulticastGroup(Value);
|
||||||
|
Id_IPv6 : Result := GStack.IsValidIPv6MulticastGroup(Value);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIPMCastBase.Loaded;
|
||||||
|
var
|
||||||
|
b: Boolean;
|
||||||
|
begin
|
||||||
|
inherited Loaded;
|
||||||
|
b := FDsgnActive;
|
||||||
|
FDsgnActive := False;
|
||||||
|
Active := b;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIPMCastBase.SetActive(const Value: Boolean);
|
||||||
|
begin
|
||||||
|
if Active <> Value then begin
|
||||||
|
if not (IsDesignTime or IsLoading) then begin
|
||||||
|
if Value then begin
|
||||||
|
GetBinding;
|
||||||
|
end
|
||||||
|
else begin
|
||||||
|
CloseBinding;
|
||||||
|
end;
|
||||||
|
end
|
||||||
|
else begin // don't activate at designtime (or during loading of properties) {Do not Localize}
|
||||||
|
FDsgnActive := Value;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
class function TIdIPMCastBase.SetIPv6AddrScope(const AVarIPv6Addr: String;
|
||||||
|
const AScope: TIdIPMv6Scope): String;
|
||||||
|
begin
|
||||||
|
|
||||||
|
case AScope of
|
||||||
|
IdIPv6MC_InterfaceLocal : Result := SetIPv6AddrScope(AVarIPv6Addr,$1);
|
||||||
|
IdIPv6MC_LinkLocal : Result := SetIPv6AddrScope(AVarIPv6Addr,$2);
|
||||||
|
IdIPv6MC_AdminLocal : Result := SetIPv6AddrScope(AVarIPv6Addr,$4);
|
||||||
|
IdIPv6MC_SiteLocal : Result := SetIPv6AddrScope(AVarIPv6Addr,$5);
|
||||||
|
IdIPv6MC_OrgLocal : Result := SetIPv6AddrScope(AVarIPv6Addr,$8);
|
||||||
|
IdIPv6MC_Global : Result := SetIPv6AddrScope(AVarIPv6Addr,$E);
|
||||||
|
else
|
||||||
|
Result := AVarIPv6Addr;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
class function TIdIPMCastBase.SetIPv6AddrScope(const AVarIPv6Addr: String;
|
||||||
|
const AScope: TIdIPMCValidScopes): String;
|
||||||
|
begin
|
||||||
|
//Replace the X in the Id_IPv6MC_V_ constants with the specified scope
|
||||||
|
Result := ReplaceOnlyFirst(AVarIPv6Addr,'X',IntToHex(AScope,1));
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIPMCastBase.SetIPVersion(const AValue: TIdIPVersion);
|
||||||
|
begin
|
||||||
|
if AValue <> IPVersion then
|
||||||
|
begin
|
||||||
|
Active := False;
|
||||||
|
FIPVersion := AValue;
|
||||||
|
case AValue of
|
||||||
|
Id_IPv4: FMulticastGroup := Id_IPMC_All_Systems;
|
||||||
|
Id_IPv6: FMulticastGroup := DEF_IPv6_MGROUP;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIPMCastBase.SetMulticastGroup(const Value: string);
|
||||||
|
begin
|
||||||
|
if (FMulticastGroup <> Value) then begin
|
||||||
|
if IsValidMulticastGroup(Value) then
|
||||||
|
begin
|
||||||
|
Active := False;
|
||||||
|
FMulticastGroup := Value;
|
||||||
|
end else
|
||||||
|
begin
|
||||||
|
Raise EIdMCastNotValidAddress.Create(RSIPMCastInvalidMulticastAddress);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIPMCastBase.SetPort(const Value: integer);
|
||||||
|
begin
|
||||||
|
if FPort <> Value then begin
|
||||||
|
Active := False;
|
||||||
|
FPort := Value;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
|
@ -0,0 +1,312 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.6 14/06/2004 21:38:28 CCostelloe
|
||||||
|
Converted StringToTIn4Addr call
|
||||||
|
|
||||||
|
Rev 1.5 09/06/2004 10:00:34 CCostelloe
|
||||||
|
Kylix 3 patch
|
||||||
|
|
||||||
|
Rev 1.4 2004.02.03 5:43:52 PM czhower
|
||||||
|
Name changes
|
||||||
|
|
||||||
|
Rev 1.3 1/21/2004 3:11:08 PM JPMugaas
|
||||||
|
InitComponent
|
||||||
|
|
||||||
|
Rev 1.2 10/26/2003 09:11:52 AM JPMugaas
|
||||||
|
Should now work in NET.
|
||||||
|
|
||||||
|
Rev 1.1 2003.10.12 4:03:56 PM czhower
|
||||||
|
compile todos
|
||||||
|
|
||||||
|
Rev 1.0 11/13/2002 07:55:22 AM JPMugaas
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdIPMCastClient;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
{$I IdCompilerDefines.inc}
|
||||||
|
//Put FPC into Delphi mode
|
||||||
|
|
||||||
|
uses
|
||||||
|
{$IFDEF VCL_2010_OR_ABOVE}
|
||||||
|
Classes, //here to facilitate inlining
|
||||||
|
{$ENDIF}
|
||||||
|
IdException,
|
||||||
|
IdGlobal,
|
||||||
|
IdIPMCastBase,
|
||||||
|
IdUDPBase,
|
||||||
|
IdComponent,
|
||||||
|
IdSocketHandle,
|
||||||
|
IdThread;
|
||||||
|
|
||||||
|
const
|
||||||
|
DEF_IMP_THREADEDEVENT = False;
|
||||||
|
|
||||||
|
type
|
||||||
|
TIPMCastReadEvent = procedure(Sender: TObject; const AData: TIdBytes; ABinding: TIdSocketHandle) of object;
|
||||||
|
|
||||||
|
TIdIPMCastClient = class;
|
||||||
|
|
||||||
|
TIdIPMCastListenerThread = class(TIdThread)
|
||||||
|
protected
|
||||||
|
IncomingData: TIdSocketHandle;
|
||||||
|
FAcceptWait: integer;
|
||||||
|
FBuffer: TIdBytes;
|
||||||
|
FBufferSize: integer;
|
||||||
|
procedure Run; override;
|
||||||
|
public
|
||||||
|
FServer: TIdIPMCastClient;
|
||||||
|
//
|
||||||
|
constructor Create(AOwner: TIdIPMCastClient); reintroduce;
|
||||||
|
destructor Destroy; override;
|
||||||
|
|
||||||
|
procedure IPMCastRead;
|
||||||
|
//
|
||||||
|
property AcceptWait: integer read FAcceptWait write FAcceptWait;
|
||||||
|
end;
|
||||||
|
|
||||||
|
TIdIPMCastClient = class(TIdIPMCastBase)
|
||||||
|
protected
|
||||||
|
FBindings: TIdSocketHandles;
|
||||||
|
FBufferSize: Integer;
|
||||||
|
FCurrentBinding: TIdSocketHandle;
|
||||||
|
FListenerThread: TIdIPMCastListenerThread;
|
||||||
|
FOnIPMCastRead: TIPMCastReadEvent;
|
||||||
|
FThreadedEvent: boolean;
|
||||||
|
//
|
||||||
|
procedure CloseBinding; override;
|
||||||
|
procedure DoIPMCastRead(const AData: TIdBytes; ABinding: TIdSocketHandle);virtual;
|
||||||
|
function GetActive: Boolean; override;
|
||||||
|
function GetBinding: TIdSocketHandle; override;
|
||||||
|
function GetDefaultPort: integer;
|
||||||
|
procedure PacketReceived(const AData: TIdBytes; ABinding: TIdSocketHandle);
|
||||||
|
procedure SetBindings(const Value: TIdSocketHandles);
|
||||||
|
procedure SetDefaultPort(const AValue: integer);
|
||||||
|
procedure InitComponent; override;
|
||||||
|
public
|
||||||
|
destructor Destroy; override;
|
||||||
|
//
|
||||||
|
published
|
||||||
|
property IPVersion;
|
||||||
|
property Active;
|
||||||
|
property Bindings: TIdSocketHandles read FBindings write SetBindings;
|
||||||
|
property BufferSize: Integer read FBufferSize write FBufferSize default ID_UDP_BUFFERSIZE;
|
||||||
|
property DefaultPort: integer read GetDefaultPort write SetDefaultPort;
|
||||||
|
property MulticastGroup;
|
||||||
|
property ReuseSocket;
|
||||||
|
property ThreadedEvent: boolean read FThreadedEvent write FThreadedEvent default DEF_IMP_THREADEDEVENT;
|
||||||
|
property OnIPMCastRead: TIPMCastReadEvent read FOnIPMCastRead write FOnIPMCastRead;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
IdResourceStringsCore,
|
||||||
|
IdStack,
|
||||||
|
IdStackConsts,
|
||||||
|
SysUtils;
|
||||||
|
|
||||||
|
{ TIdIPMCastClient }
|
||||||
|
|
||||||
|
procedure TIdIPMCastClient.InitComponent;
|
||||||
|
begin
|
||||||
|
inherited InitComponent;
|
||||||
|
BufferSize := ID_UDP_BUFFERSIZE;
|
||||||
|
FThreadedEvent := DEF_IMP_THREADEDEVENT;
|
||||||
|
FBindings := TIdSocketHandles.Create(Self);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIPMCastClient.CloseBinding;
|
||||||
|
var
|
||||||
|
i: integer;
|
||||||
|
begin
|
||||||
|
if Assigned(FCurrentBinding) then begin
|
||||||
|
// Necessary here - cancels the recvfrom in the listener thread
|
||||||
|
FListenerThread.Stop;
|
||||||
|
try
|
||||||
|
for i := 0 to Bindings.Count - 1 do begin
|
||||||
|
if Bindings[i].HandleAllocated then begin
|
||||||
|
// RLebeau: DropMulticastMembership() can raise an exception if
|
||||||
|
// the network cable has been pulled out...
|
||||||
|
// TODO: update DropMulticastMembership() to not raise an exception...
|
||||||
|
try
|
||||||
|
Bindings[i].DropMulticastMembership(FMulticastGroup);
|
||||||
|
except
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
Bindings[i].CloseSocket;
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
FListenerThread.WaitFor;
|
||||||
|
FreeAndNil(FListenerThread);
|
||||||
|
FCurrentBinding := nil;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIPMCastClient.DoIPMCastRead(const AData: TIdBytes; ABinding: TIdSocketHandle);
|
||||||
|
begin
|
||||||
|
if Assigned(OnIPMCastRead) then begin
|
||||||
|
OnIPMCastRead(Self, AData, ABinding);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdIPMCastClient.GetActive: Boolean;
|
||||||
|
begin
|
||||||
|
// inherited GetActive keeps track of design-time Active property
|
||||||
|
Result := inherited GetActive or
|
||||||
|
(Assigned(FCurrentBinding) and FCurrentBinding.HandleAllocated);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdIPMCastClient.GetBinding: TIdSocketHandle;
|
||||||
|
var
|
||||||
|
i: integer;
|
||||||
|
begin
|
||||||
|
if not Assigned(FCurrentBinding) then
|
||||||
|
begin
|
||||||
|
if Bindings.Count < 1 then begin
|
||||||
|
if DefaultPort > 0 then begin
|
||||||
|
Bindings.Add.IPVersion := FIPVersion;
|
||||||
|
end else begin
|
||||||
|
raise EIdMCastNoBindings.Create(RSNoBindingsSpecified);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
for i := 0 to Bindings.Count - 1 do begin
|
||||||
|
Bindings[i].AllocateSocket(Id_SOCK_DGRAM);
|
||||||
|
// do not overwrite if the default. This allows ReuseSocket to be set per binding
|
||||||
|
if FReuseSocket <> rsOSDependent then begin
|
||||||
|
Bindings[i].ReuseSocket := FReuseSocket;
|
||||||
|
end;
|
||||||
|
Bindings[i].Bind;
|
||||||
|
Bindings[i].AddMulticastMembership(FMulticastGroup);
|
||||||
|
end;
|
||||||
|
FCurrentBinding := Bindings[0];
|
||||||
|
FListenerThread := TIdIPMCastListenerThread.Create(Self);
|
||||||
|
FListenerThread.Start;
|
||||||
|
end;
|
||||||
|
Result := FCurrentBinding;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdIPMCastClient.GetDefaultPort: integer;
|
||||||
|
begin
|
||||||
|
result := FBindings.DefaultPort;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIPMCastClient.PacketReceived(const AData: TIdBytes; ABinding: TIdSocketHandle);
|
||||||
|
begin
|
||||||
|
FCurrentBinding := ABinding;
|
||||||
|
DoIPMCastRead(AData, ABinding);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIPMCastClient.SetBindings(const Value: TIdSocketHandles);
|
||||||
|
begin
|
||||||
|
FBindings.Assign(Value);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIPMCastClient.SetDefaultPort(const AValue: integer);
|
||||||
|
begin
|
||||||
|
if (FBindings.DefaultPort <> AValue) then begin
|
||||||
|
FBindings.DefaultPort := AValue;
|
||||||
|
FPort := AValue;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TIdIPMCastClient.Destroy;
|
||||||
|
begin
|
||||||
|
Active := False;
|
||||||
|
FreeAndNil(FBindings);
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TIdIPMCastListenerThread }
|
||||||
|
|
||||||
|
constructor TIdIPMCastListenerThread.Create(AOwner: TIdIPMCastClient);
|
||||||
|
begin
|
||||||
|
inherited Create(True);
|
||||||
|
FAcceptWait := 1000;
|
||||||
|
FBufferSize := AOwner.BufferSize;
|
||||||
|
FBuffer := nil;
|
||||||
|
FServer := AOwner;
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TIdIPMCastListenerThread.Destroy;
|
||||||
|
begin
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIPMCastListenerThread.Run;
|
||||||
|
var
|
||||||
|
PeerIP: string;
|
||||||
|
PeerPort: TIdPort;
|
||||||
|
PeerIPVersion: TIdIPVersion;
|
||||||
|
ByteCount: Integer;
|
||||||
|
LReadList: TIdSocketList;
|
||||||
|
i: Integer;
|
||||||
|
LBuffer : TIdBytes;
|
||||||
|
begin
|
||||||
|
SetLength(LBuffer, FBufferSize);
|
||||||
|
|
||||||
|
// create a socket list to select for read
|
||||||
|
LReadList := TIdSocketList.CreateSocketList;
|
||||||
|
try
|
||||||
|
// fill list of socket handles for reading
|
||||||
|
for i := 0 to FServer.Bindings.Count - 1 do
|
||||||
|
begin
|
||||||
|
LReadList.Add(FServer.Bindings[i].Handle);
|
||||||
|
end;
|
||||||
|
|
||||||
|
// select the handles for reading
|
||||||
|
LReadList.SelectRead(AcceptWait);
|
||||||
|
|
||||||
|
for i := 0 to LReadList.Count - 1 do
|
||||||
|
begin
|
||||||
|
// Doublecheck to see if we've been stopped
|
||||||
|
// Depending on timing - may not reach here
|
||||||
|
// if stopped the run method of the ancestor
|
||||||
|
|
||||||
|
if not Stopped then
|
||||||
|
begin
|
||||||
|
IncomingData := FServer.Bindings.BindingByHandle(TIdStackSocketHandle(LReadList[i]));
|
||||||
|
ByteCount := IncomingData.RecvFrom(LBuffer, PeerIP, PeerPort, PeerIPVersion);
|
||||||
|
if ByteCount <= 0 then
|
||||||
|
begin
|
||||||
|
raise EIdUDPReceiveErrorZeroBytes.Create(RSIPMCastReceiveError0);
|
||||||
|
end;
|
||||||
|
SetLength(FBuffer, ByteCount);
|
||||||
|
CopyTIdBytes(LBuffer, 0, FBuffer, 0, ByteCount);
|
||||||
|
IncomingData.SetPeer(PeerIP, PeerPort, PeerIPVersion);
|
||||||
|
if FServer.ThreadedEvent then begin
|
||||||
|
IPMCastRead;
|
||||||
|
end else begin
|
||||||
|
Synchronize(IPMCastRead);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
LReadList.Free;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIPMCastListenerThread.IPMCastRead;
|
||||||
|
begin
|
||||||
|
FServer.PacketReceived(FBuffer, IncomingData);
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
|
@ -0,0 +1,221 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.7 14/06/2004 21:38:42 CCostelloe
|
||||||
|
Converted StringToTIn4Addr call
|
||||||
|
|
||||||
|
Rev 1.6 09/06/2004 10:00:50 CCostelloe
|
||||||
|
Kylix 3 patch
|
||||||
|
|
||||||
|
Rev 1.5 2004.02.03 5:43:52 PM czhower
|
||||||
|
Name changes
|
||||||
|
|
||||||
|
Rev 1.4 1/21/2004 3:11:10 PM JPMugaas
|
||||||
|
InitComponent
|
||||||
|
|
||||||
|
Rev 1.3 10/26/2003 09:11:54 AM JPMugaas
|
||||||
|
Should now work in NET.
|
||||||
|
|
||||||
|
Rev 1.2 2003.10.24 10:38:28 AM czhower
|
||||||
|
UDP Server todos
|
||||||
|
|
||||||
|
Rev 1.1 2003.10.12 4:03:58 PM czhower
|
||||||
|
compile todos
|
||||||
|
|
||||||
|
Rev 1.0 11/13/2002 07:55:26 AM JPMugaas
|
||||||
|
|
||||||
|
2001-10-16 DSiders
|
||||||
|
Modified TIdIPMCastServer.MulticastBuffer to
|
||||||
|
validate the AHost argument to the method instead
|
||||||
|
of the MulticastGroup property.
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdIPMCastServer;
|
||||||
|
|
||||||
|
{
|
||||||
|
Dr. Harley J. Mackenzie, Initial revision.
|
||||||
|
}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
{$I IdCompilerDefines.inc}
|
||||||
|
//Put FPC into Delphi mode
|
||||||
|
|
||||||
|
uses
|
||||||
|
IdComponent,
|
||||||
|
IdGlobal,
|
||||||
|
IdIPMCastBase,
|
||||||
|
IdSocketHandle;
|
||||||
|
|
||||||
|
const
|
||||||
|
DEF_IMP_LOOPBACK = True;
|
||||||
|
DEF_IMP_TTL = 1;
|
||||||
|
|
||||||
|
type
|
||||||
|
TIdIPMCastServer = class(TIdIPMCastBase)
|
||||||
|
protected
|
||||||
|
FBinding: TIdSocketHandle;
|
||||||
|
FBoundIP: String;
|
||||||
|
FBoundPort: TIdPort;
|
||||||
|
FLoopback: Boolean;
|
||||||
|
FTimeToLive: Byte;
|
||||||
|
//
|
||||||
|
procedure ApplyLoopback;
|
||||||
|
procedure ApplyTimeToLive;
|
||||||
|
procedure CloseBinding; override;
|
||||||
|
function GetActive: Boolean; override;
|
||||||
|
function GetBinding: TIdSocketHandle; override;
|
||||||
|
procedure Loaded; override;
|
||||||
|
procedure MulticastBuffer(const AHost: string; const APort: Integer; const ABuffer : TIdBytes);
|
||||||
|
procedure SetLoopback(const AValue: Boolean); virtual;
|
||||||
|
procedure SetTTL(const AValue: Byte); virtual;
|
||||||
|
procedure InitComponent; override;
|
||||||
|
public
|
||||||
|
procedure Send(const AData: string; AByteEncoding: IIdTextEncoding = nil
|
||||||
|
{$IFDEF STRING_IS_ANSI}; ASrcEncoding: IIdTextEncoding = nil{$ENDIF}
|
||||||
|
); overload;
|
||||||
|
procedure Send(const ABuffer : TIdBytes); overload;
|
||||||
|
destructor Destroy; override;
|
||||||
|
//
|
||||||
|
property Binding: TIdSocketHandle read GetBinding;
|
||||||
|
published
|
||||||
|
property Active;
|
||||||
|
property BoundIP: String read FBoundIP write FBoundIP;
|
||||||
|
property BoundPort: TIdPort read FBoundPort write FBoundPort;
|
||||||
|
property Loopback: Boolean read FLoopback write SetLoopback default DEF_IMP_LOOPBACK;
|
||||||
|
property MulticastGroup;
|
||||||
|
property IPVersion;
|
||||||
|
property Port;
|
||||||
|
property ReuseSocket;
|
||||||
|
property TimeToLive: Byte read FTimeToLive write SetTTL default DEF_IMP_TTL;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
{ TIdIPMCastServer }
|
||||||
|
|
||||||
|
uses
|
||||||
|
IdResourceStringsCore,
|
||||||
|
IdStack,
|
||||||
|
IdStackConsts,
|
||||||
|
SysUtils;
|
||||||
|
|
||||||
|
procedure TIdIPMCastServer.InitComponent;
|
||||||
|
begin
|
||||||
|
inherited InitComponent;
|
||||||
|
FLoopback := DEF_IMP_LOOPBACK;
|
||||||
|
FTimeToLive := DEF_IMP_TTL;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIPMCastServer.Loaded;
|
||||||
|
var
|
||||||
|
b: Boolean;
|
||||||
|
begin
|
||||||
|
inherited Loaded;
|
||||||
|
b := FDsgnActive;
|
||||||
|
FDsgnActive := False;
|
||||||
|
Active := b;
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TIdIPMCastServer.Destroy;
|
||||||
|
begin
|
||||||
|
Active := False;
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIPMCastServer.CloseBinding;
|
||||||
|
begin
|
||||||
|
FreeAndNil(FBinding);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdIPMCastServer.GetActive: Boolean;
|
||||||
|
begin
|
||||||
|
Result := (inherited GetActive) or (Assigned(FBinding) and FBinding.HandleAllocated);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdIPMCastServer.GetBinding: TIdSocketHandle;
|
||||||
|
begin
|
||||||
|
if not Assigned(FBinding) then begin
|
||||||
|
FBinding := TIdSocketHandle.Create(nil);
|
||||||
|
end;
|
||||||
|
if not FBinding.HandleAllocated then begin
|
||||||
|
FBinding.IPVersion := FIPVersion;
|
||||||
|
FBinding.AllocateSocket(Id_SOCK_DGRAM);
|
||||||
|
FBinding.IP := FBoundIP;
|
||||||
|
FBinding.Port := FBoundPort;
|
||||||
|
FBinding.ReuseSocket := FReuseSocket;
|
||||||
|
FBinding.Bind;
|
||||||
|
ApplyTimeToLive;
|
||||||
|
ApplyLoopback;
|
||||||
|
end;
|
||||||
|
Result := FBinding;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIPMCastServer.MulticastBuffer(const AHost: string; const APort: Integer; const ABuffer : TIdBytes);
|
||||||
|
begin
|
||||||
|
// DS - if not IsValidMulticastGroup(FMulticastGroup) then
|
||||||
|
if not IsValidMulticastGroup(AHost) then begin
|
||||||
|
raise EIdMCastNotValidAddress.Create(RSIPMCastInvalidMulticastAddress);
|
||||||
|
end;
|
||||||
|
Binding.SendTo(AHost, APort, ABuffer, Binding.IPVersion);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIPMCastServer.Send(const AData: string; AByteEncoding: IIdTextEncoding = nil
|
||||||
|
{$IFDEF STRING_IS_ANSI}; ASrcEncoding: IIdTextEncoding = nil{$ENDIF}
|
||||||
|
);
|
||||||
|
begin
|
||||||
|
MulticastBuffer(FMulticastGroup, FPort, ToBytes(AData, AByteEncoding{$IFDEF STRING_IS_ANSI}, ASrcEncoding{$ENDIF}));
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIPMCastServer.Send(const ABuffer : TIdBytes);
|
||||||
|
begin
|
||||||
|
MulticastBuffer(FMulticastGroup, FPort, ABuffer);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIPMCastServer.SetLoopback(const AValue: Boolean);
|
||||||
|
begin
|
||||||
|
if FLoopback <> AValue then begin
|
||||||
|
FLoopback := AValue;
|
||||||
|
ApplyLoopback;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIPMCastServer.SetTTL(const AValue: Byte);
|
||||||
|
begin
|
||||||
|
if FTimeToLive <> AValue then begin
|
||||||
|
FTimeToLive := AValue;
|
||||||
|
ApplyTimeToLive;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIPMCastServer.ApplyLoopback;
|
||||||
|
begin
|
||||||
|
if Assigned(FBinding) and FBinding.HandleAllocated then begin
|
||||||
|
FBinding.SetLoopBack(FLoopback);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIPMCastServer.ApplyTimeToLive;
|
||||||
|
begin
|
||||||
|
if Assigned(FBinding) and FBinding.HandleAllocated then begin
|
||||||
|
FBinding.SetMulticastTTL(FTimeToLive);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
||||||
|
|
|
@ -0,0 +1,824 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.8 2004-04-25 12:08:24 Mattias
|
||||||
|
Fixed multithreading issue
|
||||||
|
|
||||||
|
Rev 1.7 2004.02.03 4:16:42 PM czhower
|
||||||
|
For unit name changes.
|
||||||
|
|
||||||
|
Rev 1.6 2/1/2004 4:53:30 PM JPMugaas
|
||||||
|
Removed Todo;
|
||||||
|
|
||||||
|
Rev 1.5 2004.01.20 10:03:24 PM czhower
|
||||||
|
InitComponent
|
||||||
|
|
||||||
|
Rev 1.4 2003.12.31 10:37:54 PM czhower
|
||||||
|
GetTickcount --> Ticks
|
||||||
|
|
||||||
|
Rev 1.3 10/16/2003 11:06:14 PM SPerry
|
||||||
|
Moved ICMP_MIN to IdRawHeaders
|
||||||
|
|
||||||
|
Rev 1.2 2003.10.11 5:48:04 PM czhower
|
||||||
|
-VCL fixes for servers
|
||||||
|
-Chain suport for servers (Super core)
|
||||||
|
-Scheduler upgrades
|
||||||
|
-Full yarn support
|
||||||
|
|
||||||
|
Rev 1.1 2003.09.30 1:22:56 PM czhower
|
||||||
|
Stack split for DotNet
|
||||||
|
|
||||||
|
Rev 1.0 11/13/2002 08:44:30 AM JPMugaas
|
||||||
|
|
||||||
|
25/1/02: SGrobety:
|
||||||
|
Modified the component to support multithreaded PING and traceroute
|
||||||
|
NOTE!!!
|
||||||
|
The component no longer use the timing informations contained
|
||||||
|
in the packet to compute the roundtrip time. This is because
|
||||||
|
that information is only correctly set in case of ECHOREPLY
|
||||||
|
In case of TTL, it is incorrect.
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdIcmpClient;
|
||||||
|
|
||||||
|
{
|
||||||
|
Note that we can NOT remove the DotNET IFDEFS from this unit. The reason is
|
||||||
|
that Microsoft NET Framework 1.1 does not support ICMPv6 and that's required
|
||||||
|
for IPv6. In Win32 and Linux, we definately can and want to support IPv6.
|
||||||
|
|
||||||
|
If we support a later version of the NET framework that has a better API, I may
|
||||||
|
consider revisiting this.
|
||||||
|
}
|
||||||
|
|
||||||
|
// SG 25/1/02: Modified the component to support multithreaded PING and traceroute
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
{$I IdCompilerDefines.inc}
|
||||||
|
//Put FPC into Delphi mode
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes,
|
||||||
|
IdGlobal,
|
||||||
|
IdRawBase,
|
||||||
|
IdRawClient,
|
||||||
|
IdStackConsts,
|
||||||
|
IdBaseComponent;
|
||||||
|
|
||||||
|
const
|
||||||
|
DEF_PACKET_SIZE = 32;
|
||||||
|
MAX_PACKET_SIZE = 1024;
|
||||||
|
Id_TIDICMP_ReceiveTimeout = 5000;
|
||||||
|
|
||||||
|
type
|
||||||
|
TReplyStatusTypes = (rsEcho,
|
||||||
|
rsError, rsTimeOut, rsErrorUnreachable,
|
||||||
|
rsErrorTTLExceeded,rsErrorPacketTooBig,
|
||||||
|
rsErrorParameter,
|
||||||
|
rsErrorDatagramConversion,
|
||||||
|
rsErrorSecurityFailure,
|
||||||
|
rsSourceQuench,
|
||||||
|
rsRedirect,
|
||||||
|
rsTimeStamp,
|
||||||
|
rsInfoRequest,
|
||||||
|
rsAddressMaskRequest,
|
||||||
|
rsTraceRoute,
|
||||||
|
rsMobileHostReg,
|
||||||
|
rsMobileHostRedir,
|
||||||
|
rsIPv6WhereAreYou,
|
||||||
|
rsIPv6IAmHere,
|
||||||
|
rsSKIP);
|
||||||
|
|
||||||
|
TReplyStatus = class(TObject)
|
||||||
|
protected
|
||||||
|
FBytesReceived: integer; // number of bytes in reply from host
|
||||||
|
FFromIpAddress: string; // IP address of replying host
|
||||||
|
FToIpAddress : string; //who receives it (i.e., us. This is for multihorned machines
|
||||||
|
FMsgType: byte;
|
||||||
|
FMsgCode : Byte;
|
||||||
|
FSequenceId: word; // sequence id of ping reply
|
||||||
|
// TODO: roundtrip time in ping reply should be float, not byte
|
||||||
|
FMsRoundTripTime: UInt32; // ping round trip time in milliseconds
|
||||||
|
FTimeToLive: byte; // time to live
|
||||||
|
FReplyStatusType: TReplyStatusTypes;
|
||||||
|
FPacketNumber : Integer;//number in packet for TraceRoute
|
||||||
|
FHostName : String; //Hostname of computer that replied, used with TraceRoute
|
||||||
|
FMsg : String;
|
||||||
|
FRedirectTo : String; // valid only for rsRedirect
|
||||||
|
public
|
||||||
|
property RedirectTo : String read FRedirectTo write FRedirectTo;
|
||||||
|
property Msg : String read FMsg write FMsg;
|
||||||
|
property BytesReceived: integer read FBytesReceived write FBytesReceived; // number of bytes in reply from host
|
||||||
|
property FromIpAddress: string read FFromIpAddress write FFromIpAddress; // IP address of replying host
|
||||||
|
property ToIpAddress : string read FToIpAddress write FToIpAddress; //who receives it (i.e., us. This is for multihorned machines
|
||||||
|
property MsgType: byte read FMsgType write FMsgType;
|
||||||
|
property MsgCode : Byte read FMsgCode write FMsgCode;
|
||||||
|
property SequenceId: word read FSequenceId write FSequenceId; // sequence id of ping reply
|
||||||
|
// TODO: roundtrip time in ping reply should be float, not byte
|
||||||
|
property MsRoundTripTime: UInt32 read FMsRoundTripTime write FMsRoundTripTime; // ping round trip time in milliseconds
|
||||||
|
property TimeToLive: byte read FTimeToLive write FTimeToLive; // time to live
|
||||||
|
property ReplyStatusType: TReplyStatusTypes read FReplyStatusType write FReplyStatusType;
|
||||||
|
property HostName : String read FHostName write FHostName;
|
||||||
|
property PacketNumber : Integer read FPacketNumber write FPacketNumber;
|
||||||
|
end;
|
||||||
|
|
||||||
|
TOnReplyEvent = procedure(ASender: TComponent; const AReplyStatus: TReplyStatus) of object;
|
||||||
|
|
||||||
|
// TODO: on MacOSX (and maybe iOS?), can use a UDP socket instead of a RAW
|
||||||
|
// socket so that non-privilege processes do not require root access...
|
||||||
|
|
||||||
|
TIdCustomIcmpClient = class(TIdRawClient)
|
||||||
|
protected
|
||||||
|
FStartTime : TIdTicks; //this is a fallback if no packet is returned
|
||||||
|
FPacketSize : Integer;
|
||||||
|
FBufReceive: TIdBytes;
|
||||||
|
FBufIcmp: TIdBytes;
|
||||||
|
wSeqNo: word;
|
||||||
|
iDataSize: integer;
|
||||||
|
FReplyStatus: TReplyStatus;
|
||||||
|
FOnReply: TOnReplyEvent;
|
||||||
|
FReplydata: String;
|
||||||
|
//
|
||||||
|
{$IFNDEF DOTNET_1_1}
|
||||||
|
function DecodeIPv6Packet(BytesRead: UInt32): Boolean;
|
||||||
|
{$ENDIF}
|
||||||
|
function DecodeIPv4Packet(BytesRead: UInt32): Boolean;
|
||||||
|
function DecodeResponse(BytesRead: UInt32): Boolean;
|
||||||
|
procedure DoReply; virtual;
|
||||||
|
procedure GetEchoReply;
|
||||||
|
procedure InitComponent; override;
|
||||||
|
{$IFNDEF DOTNET_1_1}
|
||||||
|
procedure PrepareEchoRequestIPv6(const ABuffer: String);
|
||||||
|
{$ENDIF}
|
||||||
|
procedure PrepareEchoRequestIPv4(const ABuffer: String);
|
||||||
|
procedure PrepareEchoRequest(const ABuffer: String);
|
||||||
|
procedure SendEchoRequest; overload;
|
||||||
|
procedure SendEchoRequest(const AIP : String); overload;
|
||||||
|
function GetPacketSize: Integer;
|
||||||
|
procedure SetPacketSize(const AValue: Integer);
|
||||||
|
|
||||||
|
//these are made public in the client
|
||||||
|
procedure InternalPing(const AIP : String; const ABuffer: String = ''; SequenceID: Word = 0); overload; {Do not Localize}
|
||||||
|
//
|
||||||
|
property PacketSize : Integer read GetPacketSize write SetPacketSize default DEF_PACKET_SIZE;
|
||||||
|
property ReplyData: string read FReplydata;
|
||||||
|
property ReplyStatus: TReplyStatus read FReplyStatus;
|
||||||
|
|
||||||
|
property OnReply: TOnReplyEvent read FOnReply write FOnReply;
|
||||||
|
|
||||||
|
public
|
||||||
|
destructor Destroy; override;
|
||||||
|
procedure Send(const AHost: string; const APort: TIdPort; const ABuffer : TIdBytes); override;
|
||||||
|
procedure Send(const ABuffer : TIdBytes); override;
|
||||||
|
function Receive(ATimeOut: Integer): TReplyStatus;
|
||||||
|
end;
|
||||||
|
|
||||||
|
TIdIcmpClient = class(TIdCustomIcmpClient)
|
||||||
|
public
|
||||||
|
procedure Ping(const ABuffer: String = ''; SequenceID: Word = 0); {Do not Localize}
|
||||||
|
property ReplyData;
|
||||||
|
property ReplyStatus;
|
||||||
|
published
|
||||||
|
property Host;
|
||||||
|
{$IFNDEF DOTNET_1_1}
|
||||||
|
property IPVersion;
|
||||||
|
{$ENDIF}
|
||||||
|
property PacketSize;
|
||||||
|
property ReceiveTimeout default Id_TIDICMP_ReceiveTimeout;
|
||||||
|
property OnReply;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
//facilitate inlining only.
|
||||||
|
{$IFDEF WINDOWS}
|
||||||
|
Windows,
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF USE_VCL_POSIX}
|
||||||
|
{$IFDEF DARWIN}
|
||||||
|
Macapi.CoreServices,
|
||||||
|
{$ENDIF}
|
||||||
|
{$ENDIF}
|
||||||
|
IdExceptionCore, IdRawHeaders, IdResourceStringsCore,
|
||||||
|
IdStack, IdStruct, SysUtils;
|
||||||
|
|
||||||
|
{ TIdCustomIcmpClient }
|
||||||
|
|
||||||
|
procedure TIdCustomIcmpClient.PrepareEchoRequest(const ABuffer: String);
|
||||||
|
begin
|
||||||
|
{$IFNDEF DOTNET_1_1}
|
||||||
|
if IPVersion = Id_IPv6 then begin
|
||||||
|
PrepareEchoRequestIPv6(ABuffer);
|
||||||
|
Exit;
|
||||||
|
end;
|
||||||
|
{$ENDIF}
|
||||||
|
PrepareEchoRequestIPv4(ABuffer);
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TIdIPv4_ICMP }
|
||||||
|
|
||||||
|
type
|
||||||
|
TIdIPv4_ICMP = class(TIdStruct)
|
||||||
|
protected
|
||||||
|
Fip_hdr: TIdIPHdr;
|
||||||
|
Ficmp_hdr: TIdICMPHdr;
|
||||||
|
function GetBytesLen: UInt32; override;
|
||||||
|
public
|
||||||
|
constructor Create; override;
|
||||||
|
destructor Destroy; override;
|
||||||
|
procedure ReadStruct(const ABytes : TIdBytes; var VIndex : UInt32); override;
|
||||||
|
procedure WriteStruct(var VBytes : TIdBytes; var VIndex : UInt32); override;
|
||||||
|
property ip_hdr: TIdIPHdr read Fip_hdr;
|
||||||
|
property icmp_hdr: TIdICMPHdr read Ficmp_hdr;
|
||||||
|
end;
|
||||||
|
|
||||||
|
constructor TIdIPv4_ICMP.Create;
|
||||||
|
begin
|
||||||
|
inherited Create;
|
||||||
|
Fip_hdr := TIdIPHdr.Create;
|
||||||
|
Ficmp_hdr := TIdICMPHdr.Create;
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TIdIPv4_ICMP.Destroy;
|
||||||
|
begin
|
||||||
|
FreeAndNil(Fip_hdr);
|
||||||
|
FreeAndNil(Ficmp_hdr);
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdIPv4_ICMP.GetBytesLen: UInt32;
|
||||||
|
begin
|
||||||
|
Result := inherited GetBytesLen + Fip_hdr.BytesLen + Ficmp_hdr.BytesLen;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIPv4_ICMP.ReadStruct(const ABytes : TIdBytes; var VIndex : UInt32);
|
||||||
|
begin
|
||||||
|
inherited ReadStruct(ABytes, VIndex);
|
||||||
|
Fip_hdr.ReadStruct(ABytes, VIndex);
|
||||||
|
Ficmp_hdr.ReadStruct(ABytes, VIndex);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIPv4_ICMP.WriteStruct(var VBytes : TIdBytes; var VIndex : UInt32);
|
||||||
|
begin
|
||||||
|
inherited WriteStruct(VBytes, VIndex);
|
||||||
|
Fip_hdr.WriteStruct(VBytes, VIndex);
|
||||||
|
Ficmp_hdr.WriteStruct(VBytes, VIndex);
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TIdCustomIcmpClient }
|
||||||
|
|
||||||
|
procedure TIdCustomIcmpClient.SendEchoRequest;
|
||||||
|
begin
|
||||||
|
Send(FBufIcmp);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdCustomIcmpClient.DecodeResponse(BytesRead: UInt32): Boolean;
|
||||||
|
begin
|
||||||
|
if BytesRead = 0 then begin
|
||||||
|
// Timed out
|
||||||
|
FReplyStatus.MsRoundTripTime := GetElapsedTicks(FStartTime);
|
||||||
|
FReplyStatus.BytesReceived := 0;
|
||||||
|
if IPVersion = Id_IPv4 then
|
||||||
|
begin
|
||||||
|
FReplyStatus.FromIpAddress := '0.0.0.0';
|
||||||
|
FReplyStatus.ToIpAddress := '0.0.0.0';
|
||||||
|
end else
|
||||||
|
begin
|
||||||
|
FReplyStatus.FromIpAddress := '::0';
|
||||||
|
FReplyStatus.ToIpAddress := '::0';
|
||||||
|
end;
|
||||||
|
FReplyStatus.MsgType := 0;
|
||||||
|
FReplyStatus.SequenceId := wSeqNo;
|
||||||
|
FReplyStatus.TimeToLive := 0;
|
||||||
|
FReplyStatus.ReplyStatusType := rsTimeOut;
|
||||||
|
Result := True;
|
||||||
|
end else
|
||||||
|
begin
|
||||||
|
FReplyStatus.ReplyStatusType := rsError;
|
||||||
|
{$IFNDEF DOTNET_1_1}
|
||||||
|
if IPVersion = Id_IPv6 then begin
|
||||||
|
Result := DecodeIPv6Packet(BytesRead);
|
||||||
|
Exit;
|
||||||
|
end;
|
||||||
|
{$ENDIF}
|
||||||
|
Result := DecodeIPv4Packet(BytesRead);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCustomIcmpClient.GetEchoReply;
|
||||||
|
begin
|
||||||
|
Receive(FReceiveTimeout);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdCustomIcmpClient.Receive(ATimeOut: Integer): TReplyStatus;
|
||||||
|
var
|
||||||
|
BytesRead : Integer;
|
||||||
|
TripTime: UInt32;
|
||||||
|
begin
|
||||||
|
Result := FReplyStatus;
|
||||||
|
FillBytes(FBufReceive, Length(FBufReceive), 0);
|
||||||
|
FStartTime := Ticks64;
|
||||||
|
repeat
|
||||||
|
BytesRead := ReceiveBuffer(FBufReceive, ATimeOut);
|
||||||
|
if DecodeResponse(BytesRead) then begin
|
||||||
|
Break;
|
||||||
|
end;
|
||||||
|
TripTime := GetElapsedTicks(FStartTime);
|
||||||
|
ATimeOut := ATimeOut - Integer(TripTime); // compute new timeout value
|
||||||
|
FReplyStatus.MsRoundTripTime := TripTime;
|
||||||
|
FReplyStatus.Msg := RSICMPTimeout;
|
||||||
|
// We caught a response that wasn't meant for this thread - so we must
|
||||||
|
// make sure we don't report it as such in case we time out after this
|
||||||
|
FReplyStatus.BytesReceived := 0;
|
||||||
|
if IPVersion = Id_IPv4 then
|
||||||
|
begin
|
||||||
|
FReplyStatus.FromIpAddress := '0.0.0.0';
|
||||||
|
FReplyStatus.ToIpAddress := '0.0.0.0';
|
||||||
|
end else
|
||||||
|
begin
|
||||||
|
FReplyStatus.FromIpAddress := '::0';
|
||||||
|
FReplyStatus.ToIpAddress := '::0';
|
||||||
|
end;
|
||||||
|
FReplyStatus.MsgType := 0;
|
||||||
|
FReplyStatus.SequenceId := wSeqNo;
|
||||||
|
FReplyStatus.TimeToLive := 0;
|
||||||
|
FReplyStatus.ReplyStatusType := rsTimeOut;
|
||||||
|
until ATimeOut <= 0;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCustomIcmpClient.DoReply;
|
||||||
|
begin
|
||||||
|
if Assigned(FOnReply) then begin
|
||||||
|
FOnReply(Self, FReplyStatus);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCustomIcmpClient.InitComponent;
|
||||||
|
begin
|
||||||
|
inherited InitComponent;
|
||||||
|
FReplyStatus:= TReplyStatus.Create;
|
||||||
|
FProtocol := Id_IPPROTO_ICMP;
|
||||||
|
{$IFNDEF DOTNET_1_1}
|
||||||
|
ProtocolIPv6 := Id_IPPROTO_ICMPv6;
|
||||||
|
{$ENDIF}
|
||||||
|
wSeqNo := 3489; // SG 25/1/02: Arbitrary Constant <> 0
|
||||||
|
FReceiveTimeOut := Id_TIDICMP_ReceiveTimeout;
|
||||||
|
FPacketSize := DEF_PACKET_SIZE;
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TIdCustomIcmpClient.Destroy;
|
||||||
|
begin
|
||||||
|
FreeAndNil(FReplyStatus);
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdCustomIcmpClient.DecodeIPv4Packet(BytesRead: UInt32): Boolean;
|
||||||
|
var
|
||||||
|
LIPHeaderLen: UInt32;
|
||||||
|
LIdx: UInt32;
|
||||||
|
RTTime: UInt32;
|
||||||
|
LActualSeqID: UInt16;
|
||||||
|
LIcmp: TIdIPv4_ICMP;
|
||||||
|
LIcmpts: TIdICMPTs;
|
||||||
|
begin
|
||||||
|
Result := False;
|
||||||
|
|
||||||
|
LIpHeaderLen := (FBufReceive[0] and $0F) * 4;
|
||||||
|
if BytesRead < (LIpHeaderLen + ICMP_MIN) then begin
|
||||||
|
raise EIdIcmpException.Create(RSICMPNotEnoughtBytes);
|
||||||
|
end;
|
||||||
|
LIdx := 0;
|
||||||
|
|
||||||
|
LIcmp := TIdIPv4_ICMP.Create;
|
||||||
|
try
|
||||||
|
LIcmp.ReadStruct(FBufReceive, LIdx);
|
||||||
|
|
||||||
|
{$IFDEF LINUX}
|
||||||
|
// TODO: baffled as to why linux kernel sends back echo from localhost
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
case LIcmp.icmp_hdr.icmp_type of
|
||||||
|
Id_ICMP_ECHOREPLY, Id_ICMP_ECHO:
|
||||||
|
begin
|
||||||
|
FReplyStatus.ReplyStatusType := rsEcho;
|
||||||
|
FReplyData := BytesToStringRaw(FBufReceive, LIdx, -1);
|
||||||
|
// result is only valid if the seq. number is correct
|
||||||
|
end;
|
||||||
|
Id_ICMP_UNREACH:
|
||||||
|
FReplyStatus.ReplyStatusType := rsErrorUnreachable;
|
||||||
|
Id_ICMP_TIMXCEED:
|
||||||
|
FReplyStatus.ReplyStatusType := rsErrorTTLExceeded;
|
||||||
|
Id_ICMP_PARAMPROB :
|
||||||
|
FReplyStatus.ReplyStatusType := rsErrorParameter;
|
||||||
|
Id_ICMP_REDIRECT :
|
||||||
|
FReplyStatus.ReplyStatusType := rsRedirect;
|
||||||
|
Id_ICMP_TSTAMP, Id_ICMP_TSTAMPREPLY :
|
||||||
|
FReplyStatus.ReplyStatusType := rsTimeStamp;
|
||||||
|
Id_ICMP_IREQ, Id_ICMP_IREQREPLY :
|
||||||
|
FReplyStatus.ReplyStatusType := rsInfoRequest;
|
||||||
|
Id_ICMP_MASKREQ, Id_ICMP_MASKREPLY :
|
||||||
|
FReplyStatus.ReplyStatusType := rsAddressMaskRequest;
|
||||||
|
Id_ICMP_TRACEROUTE :
|
||||||
|
FReplyStatus.ReplyStatusType := rsTraceRoute;
|
||||||
|
Id_ICMP_DATAGRAM_CONV :
|
||||||
|
FReplyStatus.ReplyStatusType := rsErrorDatagramConversion;
|
||||||
|
Id_ICMP_MOB_HOST_REDIR :
|
||||||
|
FReplyStatus.ReplyStatusType := rsMobileHostRedir;
|
||||||
|
Id_ICMP_IPv6_WHERE_ARE_YOU :
|
||||||
|
FReplyStatus.ReplyStatusType := rsIPv6WhereAreYou;
|
||||||
|
Id_ICMP_IPv6_I_AM_HERE :
|
||||||
|
FReplyStatus.ReplyStatusType := rsIPv6IAmHere;
|
||||||
|
Id_ICMP_MOB_REG_REQ, Id_ICMP_MOB_REG_REPLY :
|
||||||
|
FReplyStatus.ReplyStatusType := rsMobileHostReg;
|
||||||
|
Id_ICMP_PHOTURIS :
|
||||||
|
FReplyStatus.ReplyStatusType := rsErrorSecurityFailure;
|
||||||
|
else
|
||||||
|
raise EIdICMPException.Create(RSICMPNonEchoResponse);// RSICMPNonEchoResponse = 'Non-echo type response received'
|
||||||
|
end; // case
|
||||||
|
|
||||||
|
// check if we got a reply to the packet that was actually sent
|
||||||
|
case FReplyStatus.ReplyStatusType of
|
||||||
|
rsEcho:
|
||||||
|
begin
|
||||||
|
LActualSeqID := LIcmp.icmp_hdr.icmp_hun.echo_seq;
|
||||||
|
RTTime := GetElapsedTicks(BytesToTicks(FBufReceive, LIdx));
|
||||||
|
end;
|
||||||
|
rsTimeStamp:
|
||||||
|
begin
|
||||||
|
LActualSeqID := LIcmp.icmp_hdr.icmp_hun.echo_seq;
|
||||||
|
LIcmpts := TIdICMPTs.Create;
|
||||||
|
try
|
||||||
|
LIcmpts.ReadStruct(FBufReceive, LIpHeaderLen);
|
||||||
|
RTTime := (LIcmpts.ttime and $80000000) - (LIcmpts.otime and $80000000);
|
||||||
|
finally
|
||||||
|
LIcmpts.Free;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
// not an echo or timestamp reply: the original IP frame is
|
||||||
|
// contained withing the DATA section of the packet...
|
||||||
|
// pOriginalIP := PIdIPHdr(@picmp^.icmp_dun.data);
|
||||||
|
|
||||||
|
// TODO: verify this! I don't think it is indexing far enough into the data
|
||||||
|
LActualSeqID := BytesToUInt16(FBufReceive, LIpHeaderLen+8+6);//pOriginalICMP^.icmp_hun.echo.seq;
|
||||||
|
RTTime := GetElapsedTicks(BytesToTicks(FBufReceive, LIpHeaderLen+8+8)); //pOriginalICMP^.icmp_dun.ts.otime;
|
||||||
|
|
||||||
|
// move to offset
|
||||||
|
// pOriginalICMP := Pointer(PtrUInt(pOriginalIP) + (iIpHeaderLen));
|
||||||
|
// extract information from original ICMP frame
|
||||||
|
// ActualSeqID := pOriginalICMP^.icmp_hun.echo.seq;
|
||||||
|
// RTTime := Ticks64 - pOriginalICMP^.icmp_dun.ts.otime;
|
||||||
|
// Result := pOriginalICMP^.icmp_hun.echo.seq = wSeqNo;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
Result := LActualSeqID = wSeqNo;//;picmp^.icmp_hun.echo.seq = wSeqNo;
|
||||||
|
if Result then
|
||||||
|
begin
|
||||||
|
if FReplyStatus.ReplyStatusType = rsEcho then begin
|
||||||
|
FReplyStatus.BytesReceived := BytesRead - (Id_IP_HSIZE + ICMP_MIN + SizeOf(UInt32));
|
||||||
|
end else begin
|
||||||
|
FReplyStatus.BytesReceived := BytesRead - (Id_IP_HSIZE + ICMP_MIN);
|
||||||
|
end;
|
||||||
|
|
||||||
|
FReplyStatus.FromIpAddress := MakeUInt32IntoIPv4Address(GStack.NetworkToHost(Licmp.ip_hdr.ip_src.s_l));
|
||||||
|
FReplyStatus.ToIpAddress := MakeUInt32IntoIPv4Address(GStack.NetworkToHost(Licmp.ip_hdr.ip_dst.s_l));
|
||||||
|
FReplyStatus.MsgType := LIcmp.icmp_hdr.icmp_type; //picmp^.icmp_type;
|
||||||
|
FReplyStatus.MsgCode := LIcmp.icmp_hdr.icmp_code; //picmp^.icmp_code;
|
||||||
|
FReplyStatus.SequenceId := LActualSeqID;
|
||||||
|
FReplyStatus.MsRoundTripTime := RTTime;
|
||||||
|
FReplyStatus.TimeToLive := LIcmp.ip_hdr.ip_ttl;
|
||||||
|
// now process our message stuff
|
||||||
|
|
||||||
|
case FReplyStatus.MsgType of
|
||||||
|
Id_ICMP_UNREACH:
|
||||||
|
begin
|
||||||
|
case FReplyStatus.MsgCode of
|
||||||
|
Id_ICMP_UNREACH_NET : FReplyStatus.Msg := RSICMPNetUnreachable;
|
||||||
|
Id_ICMP_UNREACH_HOST : FReplyStatus.Msg := RSICMPHostUnreachable;
|
||||||
|
Id_ICMP_UNREACH_PROTOCOL : FReplyStatus.Msg := RSICMPProtUnreachable;
|
||||||
|
Id_ICMP_UNREACH_NEEDFRAG : FReplyStatus.Msg := RSICMPFragmentNeeded;
|
||||||
|
Id_ICMP_UNREACH_SRCFAIL : FReplyStatus.Msg := RSICMPSourceRouteFailed;
|
||||||
|
Id_ICMP_UNREACH_NET_UNKNOWN : FReplyStatus.Msg := RSICMPDestNetUnknown;
|
||||||
|
Id_ICMP_UNREACH_HOST_UNKNOWN : FReplyStatus.Msg := RSICMPDestHostUnknown;
|
||||||
|
Id_ICMP_UNREACH_ISOLATED : FReplyStatus.Msg := RSICMPSourceIsolated;
|
||||||
|
Id_ICMP_UNREACH_NET_PROHIB : FReplyStatus.Msg := RSICMPDestNetProhibitted;
|
||||||
|
Id_ICMP_UNREACH_HOST_PROHIB : FReplyStatus.Msg := RSICMPDestHostProhibitted;
|
||||||
|
Id_ICMP_UNREACH_TOSNET : FReplyStatus.Msg := RSICMPTOSNetUnreach;
|
||||||
|
Id_ICMP_UNREACH_TOSHOST : FReplyStatus.Msg := RSICMPTOSHostUnreach;
|
||||||
|
Id_ICMP_UNREACH_FILTER_PROHIB : FReplyStatus.Msg := RSICMPAdminProhibitted;
|
||||||
|
Id_ICMP_UNREACH_HOST_PRECEDENCE : FReplyStatus.Msg := RSICMPHostPrecViolation;
|
||||||
|
Id_ICMP_UNREACH_PRECEDENCE_CUTOFF : FReplyStatus.Msg := RSICMPPrecedenceCutoffInEffect;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
Id_ICMP_TIMXCEED:
|
||||||
|
begin
|
||||||
|
case FReplyStatus.MsgCode of
|
||||||
|
0 : FReplyStatus.Msg := RSICMPTTLExceeded;
|
||||||
|
1 : FReplyStatus.Msg := RSICMPFragAsmExceeded;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
Id_ICMP_PARAMPROB : FReplyStatus.Msg := IndyFormat(RSICMPParamError, [FReplyStatus.MsgCode]);
|
||||||
|
Id_ICMP_REDIRECT:
|
||||||
|
begin
|
||||||
|
FReplyStatus.RedirectTo := MakeUInt32IntoIPv4Address(GStack.NetworkToHOst(LIcmp.icmp_hdr.icmp_hun.gateway_s_l));
|
||||||
|
case FReplyStatus.MsgCode of
|
||||||
|
0 : FReplyStatus.Msg := RSICMPRedirNet;
|
||||||
|
1 : FReplyStatus.Msg := RSICMPRedirHost;
|
||||||
|
2 : FReplyStatus.Msg := RSICMPRedirTOSNet;
|
||||||
|
3 : FReplyStatus.Msg := RSICMPRedirTOSHost;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
Id_ICMP_SOURCEQUENCH : FReplyStatus.Msg := RSICMPSourceQuenchMsg;
|
||||||
|
Id_ICMP_ECHOREPLY, Id_ICMP_ECHO : FReplyStatus.Msg := RSICMPEcho;
|
||||||
|
Id_ICMP_TSTAMP, Id_ICMP_TSTAMPREPLY : FReplyStatus.Msg := RSICMPTimeStamp;
|
||||||
|
Id_ICMP_IREQ, Id_ICMP_IREQREPLY : FReplyStatus.Msg := RSICMPTimeStamp;
|
||||||
|
Id_ICMP_MASKREQ, Id_ICMP_MASKREPLY : FReplyStatus.Msg := RSICMPMaskRequest;
|
||||||
|
Id_ICMP_TRACEROUTE :
|
||||||
|
begin
|
||||||
|
case FReplyStatus.MsgCode of
|
||||||
|
Id_ICMP_TRACEROUTE_PACKET_FORWARDED : FReplyStatus.Msg := RSICMPTracePacketForwarded;
|
||||||
|
Id_ICMP_TRACEROUTE_NO_ROUTE : FReplyStatus.Msg := RSICMPTraceNoRoute;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
Id_ICMP_DATAGRAM_CONV:
|
||||||
|
begin
|
||||||
|
case FReplyStatus.MsgCode of
|
||||||
|
Id_ICMP_CONV_UNSPEC : FReplyStatus.Msg := RSICMPTracePacketForwarded;
|
||||||
|
Id_ICMP_CONV_DONTCONV_OPTION : FReplyStatus.Msg := RSICMPTraceNoRoute;
|
||||||
|
Id_ICMP_CONV_UNKNOWN_MAN_OPTION : FReplyStatus.Msg := RSICMPConvUnknownMandOptPresent;
|
||||||
|
Id_ICMP_CONV_UNKNWON_UNSEP_OPTION : FReplyStatus.Msg := RSICMPConvKnownUnsupportedOptionPresent;
|
||||||
|
Id_ICMP_CONV_UNSEP_TRANSPORT : FReplyStatus.Msg := RSICMPConvUnsupportedTransportProtocol;
|
||||||
|
Id_ICMP_CONV_OVERALL_LENGTH_EXCEEDED : FReplyStatus.Msg := RSICMPConvOverallLengthExceeded;
|
||||||
|
Id_ICMP_CONV_IP_HEADER_LEN_EXCEEDED : FReplyStatus.Msg := RSICMPConvIPHeaderLengthExceeded;
|
||||||
|
Id_ICMP_CONV_TRANS_PROT_255 : FReplyStatus.Msg := RSICMPConvTransportProtocol_255;
|
||||||
|
Id_ICMP_CONV_PORT_OUT_OF_RANGE : FReplyStatus.Msg := RSICMPConvPortConversionOutOfRange;
|
||||||
|
Id_ICMP_CONV_TRANS_HEADER_LEN_EXCEEDED : FReplyStatus.Msg := RSICMPConvTransportHeaderLengthExceeded;
|
||||||
|
Id_ICMP_CONV_32BIT_ROLLOVER_AND_ACK : FReplyStatus.Msg := RSICMPConv32BitRolloverMissingAndACKSet;
|
||||||
|
Id_ICMP_CONV_UNKNOWN_MAN_TRANS_OPTION : FReplyStatus.Msg := RSICMPConvUnknownMandatoryTransportOptionPresent;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
Id_ICMP_MOB_HOST_REDIR : FReplyStatus.Msg := RSICMPMobileHostRedirect;
|
||||||
|
Id_ICMP_IPv6_WHERE_ARE_YOU : FReplyStatus.Msg := RSICMPIPv6WhereAreYou;
|
||||||
|
Id_ICMP_IPv6_I_AM_HERE : FReplyStatus.Msg := RSICMPIPv6IAmHere;
|
||||||
|
Id_ICMP_MOB_REG_REQ, Id_ICMP_MOB_REG_REPLY : FReplyStatus.Msg := RSICMPIPv6IAmHere;
|
||||||
|
Id_ICMP_SKIP : FReplyStatus.Msg := RSICMPSKIP;
|
||||||
|
Id_ICMP_PHOTURIS :
|
||||||
|
begin
|
||||||
|
case FReplyStatus.MsgCode of
|
||||||
|
Id_ICMP_BAD_SPI : FReplyStatus.Msg := RSICMPSecBadSPI;
|
||||||
|
Id_ICMP_AUTH_FAILED : FReplyStatus.Msg := RSICMPSecAuthenticationFailed;
|
||||||
|
Id_ICMP_DECOMPRESS_FAILED : FReplyStatus.Msg := RSICMPSecDecompressionFailed;
|
||||||
|
Id_ICMP_DECRYPTION_FAILED : FReplyStatus.Msg := RSICMPSecDecryptionFailed;
|
||||||
|
Id_ICMP_NEED_AUTHENTICATION : FReplyStatus.Msg := RSICMPSecNeedAuthentication;
|
||||||
|
Id_ICMP_NEED_AUTHORIZATION : FReplyStatus.Msg := RSICMPSecNeedAuthorization;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
FreeAndNil(LIcmp);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCustomIcmpClient.PrepareEchoRequestIPv4(const ABuffer: String);
|
||||||
|
var
|
||||||
|
LIcmp: TIdICMPHdr;
|
||||||
|
LIdx: UInt32;
|
||||||
|
LBuffer: TIdBytes;
|
||||||
|
LBufferLen: Integer;
|
||||||
|
begin
|
||||||
|
LBuffer := ToBytes(ABuffer, IndyTextEncoding_8Bit);
|
||||||
|
LBufferLen := IndyMin(Length(LBuffer), FPacketSize);
|
||||||
|
|
||||||
|
SetLength(FBufIcmp, ICMP_MIN + SizeOf(TIdTicks) + LBufferLen);
|
||||||
|
FillBytes(FBufIcmp, Length(FBufIcmp), 0);
|
||||||
|
SetLength(FBufReceive, Length(FBufIcmp) + Id_IP_HSIZE);
|
||||||
|
|
||||||
|
LIdx := 0;
|
||||||
|
LIcmp := TIdICMPHdr.Create;
|
||||||
|
try
|
||||||
|
LIcmp.icmp_type := Id_ICMP_ECHO;
|
||||||
|
LIcmp.icmp_code := 0;
|
||||||
|
LIcmp.icmp_sum := 0;
|
||||||
|
LIcmp.icmp_hun.echo_id := Word(CurrentProcessId);
|
||||||
|
LIcmp.icmp_hun.echo_seq := wSeqNo;
|
||||||
|
LIcmp.WriteStruct(FBufIcmp, LIdx);
|
||||||
|
CopyTIdTicks(Ticks64, FBufIcmp, LIdx);
|
||||||
|
Inc(LIdx, SizeOf(TIdTicks));
|
||||||
|
if LBufferLen > 0 then begin
|
||||||
|
CopyTIdBytes(LBuffer, 0, FBufIcmp, LIdx, LBufferLen);
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
FreeAndNil(LIcmp);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{$IFNDEF DOTNET_1_1}
|
||||||
|
procedure TIdCustomIcmpClient.PrepareEchoRequestIPv6(const ABuffer: String);
|
||||||
|
var
|
||||||
|
LIcmp : TIdicmp6_hdr;
|
||||||
|
LIdx : UInt32;
|
||||||
|
LBuffer: TIdBytes;
|
||||||
|
LBufferLen: Integer;
|
||||||
|
begin
|
||||||
|
LBuffer := ToBytes(ABuffer, IndyTextEncoding_8Bit);
|
||||||
|
LBufferLen := IndyMin(Length(LBuffer), FPacketSize);
|
||||||
|
|
||||||
|
SetLength(FBufIcmp, ICMP_MIN + SizeOf(TIdTicks) + LBufferLen);
|
||||||
|
FillBytes(FBufIcmp, Length(FBufIcmp), 0);
|
||||||
|
SetLength(FBufReceive, Length(FBufIcmp) + (Id_IPv6_HSIZE*2));
|
||||||
|
|
||||||
|
LIdx := 0;
|
||||||
|
LIcmp := TIdicmp6_hdr.Create;
|
||||||
|
try
|
||||||
|
LIcmp.icmp6_type := ICMP6_ECHO_REQUEST;
|
||||||
|
LIcmp.icmp6_code := 0;
|
||||||
|
LIcmp.data.icmp6_un_data16[0] := Word(CurrentProcessId);
|
||||||
|
LIcmp.data.icmp6_un_data16[1] := wSeqNo;
|
||||||
|
LIcmp.icmp6_cksum := 0;
|
||||||
|
LIcmp.WriteStruct(FBufIcmp, LIdx);
|
||||||
|
CopyTIdTicks(Ticks64, FBufIcmp, LIdx);
|
||||||
|
Inc(LIdx, SizeOf(TIdTicks));
|
||||||
|
if LBufferLen > 0 then begin
|
||||||
|
CopyTIdBytes(LBuffer, 0, FBufIcmp, LIdx, LBufferLen);
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
FreeAndNil(LIcmp);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdCustomIcmpClient.DecodeIPv6Packet(BytesRead: UInt32): Boolean;
|
||||||
|
var
|
||||||
|
LIdx : UInt32;
|
||||||
|
LIcmp : TIdicmp6_hdr;
|
||||||
|
RTTime : UInt32;
|
||||||
|
LActualSeqID : Word;
|
||||||
|
begin
|
||||||
|
LIdx := 0;
|
||||||
|
LIcmp := TIdicmp6_hdr.Create;
|
||||||
|
try
|
||||||
|
// Note that IPv6 raw headers are not being returned.
|
||||||
|
LIcmp.ReadStruct(FBufReceive, LIdx);
|
||||||
|
|
||||||
|
case LIcmp.icmp6_type of
|
||||||
|
ICMP6_ECHO_REQUEST,
|
||||||
|
ICMP6_ECHO_REPLY : FReplyStatus.ReplyStatusType := rsEcho;
|
||||||
|
//group membership messages
|
||||||
|
ICMP6_MEMBERSHIP_QUERY : ;
|
||||||
|
ICMP6_MEMBERSHIP_REPORT : ;
|
||||||
|
ICMP6_MEMBERSHIP_REDUCTION : ;
|
||||||
|
//errors
|
||||||
|
ICMP6_DST_UNREACH : FReplyStatus.ReplyStatusType := rsErrorUnreachable;
|
||||||
|
ICMP6_PACKET_TOO_BIG : FReplyStatus.ReplyStatusType := rsErrorPacketTooBig;
|
||||||
|
ICMP6_TIME_EXCEEDED : FReplyStatus.ReplyStatusType := rsErrorTTLExceeded;
|
||||||
|
ICMP6_PARAM_PROB : FReplyStatus.ReplyStatusType := rsErrorParameter;
|
||||||
|
else FReplyStatus.ReplyStatusType := rsError;
|
||||||
|
end;
|
||||||
|
FReplyStatus.MsgType := LIcmp.icmp6_type; //picmp^.icmp_type;
|
||||||
|
FReplyStatus.MsgCode := LIcmp.icmp6_code;
|
||||||
|
|
||||||
|
//errors are values less than ICMP6_INFOMSG_MASK
|
||||||
|
if LIcmp.icmp6_type < ICMP6_INFOMSG_MASK then
|
||||||
|
begin
|
||||||
|
//read info from the original packet part
|
||||||
|
LIcmp.ReadStruct(FBufReceive, LIdx);
|
||||||
|
end;
|
||||||
|
|
||||||
|
LActualSeqID := LIcmp.data.icmp6_seq;
|
||||||
|
Result := LActualSeqID = wSeqNo;
|
||||||
|
|
||||||
|
RTTime := GetElapsedTicks(BytesToTicks(FBufReceive, LIdx));
|
||||||
|
Inc(LIdx, SizeOf(TIdTicks));
|
||||||
|
|
||||||
|
if Result then
|
||||||
|
begin
|
||||||
|
FReplyStatus.BytesReceived := BytesRead - LIdx;
|
||||||
|
FReplyStatus.SequenceId := LActualSeqID;
|
||||||
|
FReplyStatus.MsRoundTripTime := RTTime;
|
||||||
|
// TimeToLive := FBufReceive[8];
|
||||||
|
// TimeToLive := pip^.ip_ttl;
|
||||||
|
FReplyStatus.TimeToLive := FPkt.TTL;
|
||||||
|
FReplyStatus.FromIpAddress := FPkt.SourceIP;
|
||||||
|
FReplyStatus.ToIpAddress := FPkt.DestIP;
|
||||||
|
|
||||||
|
case FReplyStatus.MsgType of
|
||||||
|
ICMP6_ECHO_REQUEST, ICMP6_ECHO_REPLY : FReplyStatus.Msg := RSICMPEcho;
|
||||||
|
ICMP6_TIME_EXCEEDED :
|
||||||
|
begin
|
||||||
|
case FReplyStatus.MsgCode of
|
||||||
|
ICMP6_TIME_EXCEED_TRANSIT : FReplyStatus.Msg := RSICMPHopLimitExceeded;
|
||||||
|
ICMP6_TIME_EXCEED_REASSEMBLY : FReplyStatus.Msg := RSICMPFragAsmExceeded;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
ICMP6_DST_UNREACH :
|
||||||
|
begin
|
||||||
|
case FReplyStatus.MsgCode of
|
||||||
|
ICMP6_DST_UNREACH_NOROUTE : FReplyStatus.Msg := RSICMPNoRouteToDest;
|
||||||
|
ICMP6_DST_UNREACH_ADMIN : FReplyStatus.Msg := RSICMPAdminProhibitted;
|
||||||
|
ICMP6_DST_UNREACH_ADDR : FReplyStatus.Msg := RSICMPHostUnreachable;
|
||||||
|
ICMP6_DST_UNREACH_NOPORT : FReplyStatus.Msg := RSICMPProtUnreachable;
|
||||||
|
ICMP6_DST_UNREACH_SOURCE_FILTERING : FReplyStatus.Msg := RSICMPSourceFilterFailed;
|
||||||
|
ICMP6_DST_UNREACH_REJCT_DST : FReplyStatus.Msg := RSICMPRejectRoutToDest;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
ICMP6_PACKET_TOO_BIG : FReplyStatus.Msg := IndyFormat(RSICMPPacketTooBig, [LIcmp.data.icmp6_mtu]);
|
||||||
|
ICMP6_PARAM_PROB :
|
||||||
|
begin
|
||||||
|
case FReplyStatus.MsgCode of
|
||||||
|
ICMP6_PARAMPROB_HEADER : FReplyStatus.Msg := IndyFormat(RSICMPParamHeader, [LIcmp.data.icmp6_pptr]);
|
||||||
|
ICMP6_PARAMPROB_NEXTHEADER : FReplyStatus.Msg := IndyFormat(RSICMPParamNextHeader, [LIcmp.data.icmp6_pptr]);
|
||||||
|
ICMP6_PARAMPROB_OPTION : FReplyStatus.Msg := IndyFormat(RSICMPUnrecognizedOpt, [LIcmp.data.icmp6_pptr]);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
ICMP6_MEMBERSHIP_QUERY : ;
|
||||||
|
ICMP6_MEMBERSHIP_REPORT : ;
|
||||||
|
ICMP6_MEMBERSHIP_REDUCTION :;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
FreeAndNil(LIcmp);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
procedure TIdCustomIcmpClient.Send(const AHost: string; const APort: TIdPort;
|
||||||
|
const ABuffer: TIdBytes);
|
||||||
|
var
|
||||||
|
LBuffer : TIdBytes;
|
||||||
|
LIP : String;
|
||||||
|
begin
|
||||||
|
LBuffer := ABuffer;
|
||||||
|
LIP := GStack.ResolveHost(AHost, IPVersion);
|
||||||
|
GStack.WriteChecksum(Binding.Handle, LBuffer, 2, LIP, APort, IPVersion);
|
||||||
|
FBinding.SendTo(LIP, APort, LBuffer, IPVersion);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCustomIcmpClient.Send(const ABuffer: TIdBytes);
|
||||||
|
var
|
||||||
|
LBuffer : TIdBytes;
|
||||||
|
LIP : String;
|
||||||
|
begin
|
||||||
|
LBuffer := ABuffer;
|
||||||
|
LIP := GStack.ResolveHost(Host, IPVersion);
|
||||||
|
GStack.WriteChecksum(Binding.Handle, LBuffer, 2, LIP, Port, IPVersion);
|
||||||
|
FBinding.SendTo(LIP, Port, LBuffer, IPVersion);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdCustomIcmpClient.GetPacketSize: Integer;
|
||||||
|
begin
|
||||||
|
Result := FPacketSize;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCustomIcmpClient.SetPacketSize(const AValue: Integer);
|
||||||
|
begin
|
||||||
|
if AValue < 0 then begin
|
||||||
|
FPacketSize := 0;
|
||||||
|
end else begin
|
||||||
|
FPacketSize := IndyMin(AValue, MAX_PACKET_SIZE);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCustomIcmpClient.InternalPing(const AIP, ABuffer: String; SequenceID: Word);
|
||||||
|
begin
|
||||||
|
if SequenceID <> 0 then begin
|
||||||
|
wSeqNo := SequenceID;
|
||||||
|
end;
|
||||||
|
PrepareEchoRequest(ABuffer);
|
||||||
|
SendEchoRequest(AIP);
|
||||||
|
GetEchoReply;
|
||||||
|
Binding.CloseSocket;
|
||||||
|
DoReply;
|
||||||
|
Inc(wSeqNo); // SG 25/1/02: Only increase sequence number when finished.
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdCustomIcmpClient.SendEchoRequest(const AIP: String);
|
||||||
|
begin
|
||||||
|
Send(AIP, 0, FBufIcmp);
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TIdIcmpClient }
|
||||||
|
|
||||||
|
procedure TIdIcmpClient.Ping(const ABuffer: String; SequenceID: Word);
|
||||||
|
begin
|
||||||
|
InternalPing(GStack.ResolveHost(Host, IPVersion), ABuffer, SequenceID);
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
|
@ -0,0 +1,256 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.10 3/10/2005 12:00:46 AM JPMugaas
|
||||||
|
Minor problem Craig Peterson had noted in an E-Mail to me.
|
||||||
|
|
||||||
|
Rev 1.9 11/30/04 6:19:12 PM RLebeau
|
||||||
|
Promoted the TIdConnectionIntercept.Intercept property from protected to
|
||||||
|
published
|
||||||
|
|
||||||
|
Rev 1.8 2004.02.03 4:16:44 PM czhower
|
||||||
|
For unit name changes.
|
||||||
|
|
||||||
|
Rev 1.7 2004.01.20 10:03:24 PM czhower
|
||||||
|
InitComponent
|
||||||
|
|
||||||
|
Rev 1.6 5/12/2003 12:33:32 AM GGrieve
|
||||||
|
add Data from BlockCipher descendent
|
||||||
|
|
||||||
|
Rev 1.5 2003.10.14 1:26:48 PM czhower
|
||||||
|
Uupdates + Intercept support
|
||||||
|
|
||||||
|
Rev 1.4 2003.10.11 5:48:16 PM czhower
|
||||||
|
-VCL fixes for servers
|
||||||
|
-Chain suport for servers (Super core)
|
||||||
|
-Scheduler upgrades
|
||||||
|
-Full yarn support
|
||||||
|
|
||||||
|
Rev 1.3 10/5/2003 3:20:46 PM BGooijen
|
||||||
|
.net
|
||||||
|
|
||||||
|
Rev 1.2 2003.10.01 1:12:34 AM czhower
|
||||||
|
.Net
|
||||||
|
|
||||||
|
Rev 1.1 3/5/2003 10:59:48 PM BGooijen
|
||||||
|
Fixed (i know, the SendBuffer looks bad)
|
||||||
|
|
||||||
|
Rev 1.0 11/13/2002 08:44:42 AM JPMugaas
|
||||||
|
|
||||||
|
2002-03-01 - Andrew P.Rybin
|
||||||
|
- Nested Intercept support (ex: ->logging->compression->encryption)
|
||||||
|
|
||||||
|
2002-04-09 - Chuck Smith
|
||||||
|
- set ABuffer.Position := 0; in OnSend/OnReceive for Nested Stream send/receive
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdIntercept;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
{$I IdCompilerDefines.inc}
|
||||||
|
//here only to put FPC in Delphi mode
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes,
|
||||||
|
IdGlobal, IdBaseComponent, IdBuffer, IdException;
|
||||||
|
|
||||||
|
type
|
||||||
|
EIdInterceptCircularLink = class(EIdException);
|
||||||
|
TIdConnectionIntercept = class;
|
||||||
|
TIdInterceptNotifyEvent = procedure(ASender: TIdConnectionIntercept) of object;
|
||||||
|
TIdInterceptStreamEvent = procedure(ASender: TIdConnectionIntercept; var ABuffer: TIdBytes) of object;
|
||||||
|
|
||||||
|
TIdConnectionIntercept = class(TIdBaseComponent)
|
||||||
|
protected
|
||||||
|
FConnection: TComponent;
|
||||||
|
{$IFDEF USE_OBJECT_ARC}[Weak]{$ENDIF} FIntercept: TIdConnectionIntercept;
|
||||||
|
FIsClient: Boolean;
|
||||||
|
{$IFDEF USE_OBJECT_ARC}
|
||||||
|
// When ARC is enabled, object references MUST be valid objects.
|
||||||
|
// It is common for users to store non-object values, though, so
|
||||||
|
// we will provide separate properties for those purposes
|
||||||
|
//
|
||||||
|
// TODO; use TValue instead of separating them
|
||||||
|
//
|
||||||
|
FDataObject: TObject;
|
||||||
|
FDataValue: PtrInt;
|
||||||
|
{$ELSE}
|
||||||
|
FData: TObject;
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
FOnConnect: TIdInterceptNotifyEvent;
|
||||||
|
FOnDisconnect: TIdInterceptNotifyEvent;
|
||||||
|
FOnReceive: TIdInterceptStreamEvent;
|
||||||
|
FOnSend: TIdInterceptStreamEvent;
|
||||||
|
//
|
||||||
|
procedure InitComponent; override;
|
||||||
|
{$IFNDEF USE_OBJECT_ARC}
|
||||||
|
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
|
||||||
|
{$ENDIF}
|
||||||
|
procedure SetIntercept(AValue: TIdConnectionIntercept);
|
||||||
|
//
|
||||||
|
public
|
||||||
|
procedure Connect(AConnection: TComponent); virtual;
|
||||||
|
procedure Disconnect; virtual;
|
||||||
|
procedure Receive(var VBuffer: TIdBytes); virtual;
|
||||||
|
procedure Send(var VBuffer: TIdBytes); virtual;
|
||||||
|
//
|
||||||
|
property Connection: TComponent read FConnection;
|
||||||
|
property IsClient: Boolean read FIsClient;
|
||||||
|
|
||||||
|
// user can use this to keep context
|
||||||
|
{$IFDEF USE_OBJECT_ARC}
|
||||||
|
property DataObject: TObject read FDataObject write FDataObject;
|
||||||
|
property DataValue: PtrInt read FDataValue write FDataValue;
|
||||||
|
{$ELSE}
|
||||||
|
property Data: TObject read FData write FData;
|
||||||
|
{$ENDIF}
|
||||||
|
published
|
||||||
|
property Intercept: TIdConnectionIntercept read FIntercept write SetIntercept;
|
||||||
|
property OnConnect: TIdInterceptNotifyEvent read FOnConnect write FOnConnect;
|
||||||
|
property OnDisconnect: TIdInterceptNotifyEvent read FOnDisconnect write FOnDisconnect;
|
||||||
|
property OnReceive: TIdInterceptStreamEvent read FOnReceive write FOnReceive;
|
||||||
|
property OnSend: TIdInterceptStreamEvent read FOnSend write FOnSend;
|
||||||
|
end;
|
||||||
|
|
||||||
|
TIdServerIntercept = class(TIdBaseComponent)
|
||||||
|
public
|
||||||
|
procedure Init; virtual; abstract;
|
||||||
|
function Accept(AConnection: TComponent): TIdConnectionIntercept; virtual; abstract;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
uses
|
||||||
|
IdResourceStringsCore;
|
||||||
|
|
||||||
|
{ TIdIntercept }
|
||||||
|
|
||||||
|
procedure TIdConnectionIntercept.Disconnect;
|
||||||
|
var
|
||||||
|
// under ARC, convert a weak reference to a strong reference before working with it
|
||||||
|
LIntercept: TIdConnectionIntercept;
|
||||||
|
begin
|
||||||
|
LIntercept := Intercept;
|
||||||
|
if LIntercept <> nil then begin
|
||||||
|
LIntercept.Disconnect;
|
||||||
|
end;
|
||||||
|
if Assigned(OnDisconnect) then begin
|
||||||
|
OnDisconnect(Self);
|
||||||
|
end;
|
||||||
|
FConnection := nil;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdConnectionIntercept.Connect(AConnection: TComponent);
|
||||||
|
var
|
||||||
|
// under ARC, convert a weak reference to a strong reference before working with it
|
||||||
|
LIntercept: TIdConnectionIntercept;
|
||||||
|
begin
|
||||||
|
FConnection := AConnection;
|
||||||
|
if Assigned(OnConnect) then begin
|
||||||
|
OnConnect(Self);
|
||||||
|
end;
|
||||||
|
LIntercept := Intercept;
|
||||||
|
if LIntercept <> nil then begin
|
||||||
|
LIntercept.Connect(AConnection);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdConnectionIntercept.Receive(var VBuffer: TIdBytes);
|
||||||
|
var
|
||||||
|
// under ARC, convert a weak reference to a strong reference before working with it
|
||||||
|
LIntercept: TIdConnectionIntercept;
|
||||||
|
begin
|
||||||
|
LIntercept := Intercept;
|
||||||
|
if LIntercept <> nil then begin
|
||||||
|
LIntercept.Receive(VBuffer);
|
||||||
|
end;
|
||||||
|
if Assigned(OnReceive) then begin
|
||||||
|
OnReceive(Self, VBuffer);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdConnectionIntercept.Send(var VBuffer: TIdBytes);
|
||||||
|
var
|
||||||
|
// under ARC, convert a weak reference to a strong reference before working with it
|
||||||
|
LIntercept: TIdConnectionIntercept;
|
||||||
|
begin
|
||||||
|
if Assigned(OnSend) then begin
|
||||||
|
OnSend(Self, VBuffer);
|
||||||
|
end;
|
||||||
|
LIntercept := Intercept;
|
||||||
|
if LIntercept <> nil then begin
|
||||||
|
LIntercept.Send(VBuffer);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdConnectionIntercept.SetIntercept(AValue: TIdConnectionIntercept);
|
||||||
|
var
|
||||||
|
// under ARC, convert a weak reference to a strong reference before working with it
|
||||||
|
LIntercept: TIdConnectionIntercept;
|
||||||
|
LNextValue: TIdConnectionIntercept;
|
||||||
|
begin
|
||||||
|
LIntercept := FIntercept;
|
||||||
|
if LIntercept <> AValue then
|
||||||
|
begin
|
||||||
|
LNextValue := AValue;
|
||||||
|
while Assigned(LNextValue) do begin
|
||||||
|
if LNextValue = Self then begin //recursion
|
||||||
|
raise EIdInterceptCircularLink.CreateFmt(RSInterceptCircularLink, [ClassName]);
|
||||||
|
end;
|
||||||
|
LNextValue := LNextValue.Intercept;
|
||||||
|
end;
|
||||||
|
|
||||||
|
// under ARC, all weak references to a freed object get nil'ed automatically
|
||||||
|
|
||||||
|
{$IFNDEF USE_OBJECT_ARC}
|
||||||
|
// remove self from the Intercept's free notification list {Do not Localize}
|
||||||
|
if Assigned(LIntercept) then begin
|
||||||
|
LIntercept.RemoveFreeNotification(Self);
|
||||||
|
end;
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
FIntercept := AValue;
|
||||||
|
|
||||||
|
{$IFNDEF USE_OBJECT_ARC}
|
||||||
|
// add self to the Intercept's free notification list {Do not Localize}
|
||||||
|
if Assigned(AValue) then begin
|
||||||
|
AValue.FreeNotification(Self);
|
||||||
|
end;
|
||||||
|
{$ENDIF}
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
// under ARC, all weak references to a freed object get nil'ed automatically
|
||||||
|
{$IFNDEF USE_OBJECT_ARC}
|
||||||
|
procedure TIdConnectionIntercept.Notification(AComponent: TComponent; Operation: TOperation);
|
||||||
|
begin
|
||||||
|
if (Operation = opRemove) and (AComponent = Intercept) then begin
|
||||||
|
FIntercept := nil;
|
||||||
|
end;
|
||||||
|
inherited Notification(AComponent, OPeration);
|
||||||
|
end;
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
procedure TIdConnectionIntercept.InitComponent;
|
||||||
|
begin
|
||||||
|
inherited InitComponent;
|
||||||
|
FIsClient := True;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
|
@ -0,0 +1,157 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.6 7/23/04 6:40:08 PM RLebeau
|
||||||
|
Added extra exception handling to Connect()
|
||||||
|
|
||||||
|
Rev 1.5 2004.05.20 11:39:10 AM czhower
|
||||||
|
IdStreamVCL
|
||||||
|
|
||||||
|
Rev 1.4 2004.02.03 4:17:18 PM czhower
|
||||||
|
For unit name changes.
|
||||||
|
|
||||||
|
Rev 1.3 10/19/2003 11:38:26 AM DSiders
|
||||||
|
Added localization comments.
|
||||||
|
|
||||||
|
Rev 1.2 2003.10.18 1:56:46 PM czhower
|
||||||
|
Now uses ASCII instead of binary format.
|
||||||
|
|
||||||
|
Rev 1.1 2003.10.17 6:16:20 PM czhower
|
||||||
|
Functional complete.
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdInterceptSimLog;
|
||||||
|
|
||||||
|
{
|
||||||
|
This file uses string outputs instead of binary so that the results can be
|
||||||
|
viewed and modified with notepad if necessary.
|
||||||
|
|
||||||
|
Most times a Send/Receive includes a writeln, but may not always. We write out
|
||||||
|
an additional EOL to guarantee separation in notepad.
|
||||||
|
|
||||||
|
It also auto detects when an EOL can be used instead.
|
||||||
|
|
||||||
|
TODO: Can also change it to detect several EOLs and non binary and use :Lines:x
|
||||||
|
}
|
||||||
|
|
||||||
|
interface
|
||||||
|
{$i IdCompilerDefines.inc}
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes,
|
||||||
|
IdGlobal, IdIntercept, IdBaseComponent;
|
||||||
|
|
||||||
|
type
|
||||||
|
TIdInterceptSimLog = class(TIdConnectionIntercept)
|
||||||
|
private
|
||||||
|
protected
|
||||||
|
FFilename: string;
|
||||||
|
FStream: TStream;
|
||||||
|
//
|
||||||
|
procedure SetFilename(const AValue: string);
|
||||||
|
procedure WriteRecord(const ATag: string; const ABuffer: TIdBytes);
|
||||||
|
public
|
||||||
|
procedure Connect(AConnection: TComponent); override;
|
||||||
|
procedure Disconnect; override;
|
||||||
|
procedure Receive(var ABuffer: TIdBytes); override;
|
||||||
|
procedure Send(var ABuffer: TIdBytes); override;
|
||||||
|
published
|
||||||
|
property Filename: string read FFilename write SetFilename;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
{$IFDEF DOTNET}
|
||||||
|
IdStreamNET,
|
||||||
|
{$ELSE}
|
||||||
|
IdStreamVCL,
|
||||||
|
{$ENDIF}
|
||||||
|
IdException, IdResourceStringsCore, SysUtils;
|
||||||
|
|
||||||
|
{ TIdInterceptSimLog }
|
||||||
|
|
||||||
|
procedure TIdInterceptSimLog.Connect(AConnection: TComponent);
|
||||||
|
begin
|
||||||
|
inherited Connect(AConnection);
|
||||||
|
// Warning! This will overwrite any existing file. It makes no sense
|
||||||
|
// to concatenate sim logs.
|
||||||
|
FStream := TIdFileCreateStream.Create(Filename);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdInterceptSimLog.Disconnect;
|
||||||
|
begin
|
||||||
|
FreeAndNil(FStream);
|
||||||
|
inherited Disconnect;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdInterceptSimLog.Receive(var ABuffer: TIdBytes);
|
||||||
|
begin
|
||||||
|
// let the next Intercept in the chain decode its data first
|
||||||
|
inherited Receive(ABuffer);
|
||||||
|
WriteRecord('Recv', ABuffer); {do not localize}
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdInterceptSimLog.Send(var ABuffer: TIdBytes);
|
||||||
|
begin
|
||||||
|
WriteRecord('Send', ABuffer); {do not localize}
|
||||||
|
// let the next Intercept in the chain encode its data next
|
||||||
|
inherited Send(ABuffer);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdInterceptSimLog.SetFilename(const AValue: string);
|
||||||
|
begin
|
||||||
|
if Assigned(FStream) then begin
|
||||||
|
raise EIdException.Create(RSLogFileAlreadyOpen);
|
||||||
|
end;
|
||||||
|
FFilename := AValue;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdInterceptSimLog.WriteRecord(const ATag: string; const ABuffer: TIdBytes);
|
||||||
|
var
|
||||||
|
i: Integer;
|
||||||
|
LUseEOL: Boolean;
|
||||||
|
LSize: Integer;
|
||||||
|
begin
|
||||||
|
LUseEOL := False;
|
||||||
|
LSize := Length(ABuffer);
|
||||||
|
if LSize > 1 then begin
|
||||||
|
if (ABuffer[LSize - 2] = 13) and (ABuffer[LSize - 1] = 10) then begin
|
||||||
|
LUseEOL := True;
|
||||||
|
for i := 0 to LSize - 3 do begin
|
||||||
|
// If any binary, CR or LF
|
||||||
|
if (ABuffer[i] < 32) or (ABuffer[i] > 127) then begin
|
||||||
|
LUseEOL := False;
|
||||||
|
Break;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
with FStream do begin
|
||||||
|
if LUseEOL then begin
|
||||||
|
WriteLn(ATag + ':EOL'); {do not localize}
|
||||||
|
end else begin
|
||||||
|
WriteLn(ATag + ':Bytes:' + IntToStr(LSize)); {do not localize}
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
WriteStringToStream(FStream, '');
|
||||||
|
WriteTIdBytesToStream(FStream, ABuffer, LSize);
|
||||||
|
WriteStringToStream(FStream, EOL);
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
|
@ -0,0 +1,106 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.2 2004.02.03 4:17:18 PM czhower
|
||||||
|
For unit name changes.
|
||||||
|
|
||||||
|
Rev 1.1 2003.10.19 12:10:00 AM czhower
|
||||||
|
Changed formula to be accurate with smaller numbers.
|
||||||
|
|
||||||
|
Rev 1.0 2003.10.18 11:32:00 PM czhower
|
||||||
|
Initial checkin
|
||||||
|
|
||||||
|
Rev 1.1 2003.10.14 1:27:16 PM czhower
|
||||||
|
Uupdates + Intercept support
|
||||||
|
|
||||||
|
Rev 1.0 2003.10.13 6:40:40 PM czhower
|
||||||
|
Moved from root
|
||||||
|
|
||||||
|
Rev 1.0 11/13/2002 07:55:12 AM JPMugaas
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdInterceptThrottler;
|
||||||
|
|
||||||
|
interface
|
||||||
|
{$i IdCompilerDefines.inc}
|
||||||
|
|
||||||
|
uses
|
||||||
|
IdComponent, IdIntercept, IdGlobal;
|
||||||
|
|
||||||
|
type
|
||||||
|
TIdInterceptThrottler = class(TIdConnectionIntercept)
|
||||||
|
protected
|
||||||
|
FBitsPerSec: Integer;
|
||||||
|
FRecvBitsPerSec: Integer;
|
||||||
|
FSendBitsPerSec: Integer;
|
||||||
|
procedure SetBitsPerSec(AValue: Integer);
|
||||||
|
public
|
||||||
|
procedure Receive(var ABuffer: TIdBytes); override;
|
||||||
|
procedure Send(var ABuffer: TIdBytes); override;
|
||||||
|
published
|
||||||
|
property BitsPerSec: Integer read FBitsPerSec write SetBitsPerSec;
|
||||||
|
property RecvBitsPerSec: Integer read FRecvBitsPerSec write FRecvBitsPerSec;
|
||||||
|
property SendBitsPerSec: Integer read FSendBitsPerSec write FSendBitsPerSec;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
IdAntiFreezeBase, IdException;
|
||||||
|
|
||||||
|
{ TIdInterceptThrottler }
|
||||||
|
|
||||||
|
procedure TIdInterceptThrottler.Receive(var ABuffer: TIdBytes);
|
||||||
|
var
|
||||||
|
LInterval: Int64;
|
||||||
|
begin
|
||||||
|
inherited Receive(ABuffer);
|
||||||
|
if RecvBitsPerSec > 0 then begin
|
||||||
|
LInterval := (Int64(Length(ABuffer)) * 8 * 1000) div RecvBitsPerSec;
|
||||||
|
while LInterval > MaxInt do begin
|
||||||
|
TIdAntiFreezeBase.Sleep(MaxInt);
|
||||||
|
Dec(LInterval, MaxInt);
|
||||||
|
end;
|
||||||
|
TIdAntiFreezeBase.Sleep(Integer(LInterval));
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdInterceptThrottler.Send(var ABuffer: TIdBytes);
|
||||||
|
var
|
||||||
|
LInterval: Int64;
|
||||||
|
begin
|
||||||
|
inherited Send(ABuffer);
|
||||||
|
if SendBitsPerSec > 0 then begin
|
||||||
|
LInterval := (Int64(Length(ABuffer)) * 8 * 1000) div SendBitsPerSec;
|
||||||
|
while LInterval > MaxInt do begin
|
||||||
|
TIdAntiFreezeBase.Sleep(MaxInt);
|
||||||
|
Dec(LInterval, MaxInt);
|
||||||
|
end;
|
||||||
|
TIdAntiFreezeBase.Sleep(Integer(LInterval));
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdInterceptThrottler.SetBitsPerSec(AValue: Integer);
|
||||||
|
begin
|
||||||
|
FBitsPerSec := AValue;
|
||||||
|
FRecvBitsPerSec := AValue;
|
||||||
|
FSendBitsPerSec := AValue;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
||||||
|
|
|
@ -0,0 +1,198 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.5 2004.02.03 4:17:14 PM czhower
|
||||||
|
For unit name changes.
|
||||||
|
|
||||||
|
Rev 1.4 2004.01.20 10:03:28 PM czhower
|
||||||
|
InitComponent
|
||||||
|
|
||||||
|
Rev 1.3 2003.10.17 6:15:54 PM czhower
|
||||||
|
Upgrades
|
||||||
|
|
||||||
|
Rev 1.2 2003.10.14 1:27:08 PM czhower
|
||||||
|
Uupdates + Intercept support
|
||||||
|
|
||||||
|
Rev 1.1 6/16/2003 10:39:02 AM EHill
|
||||||
|
Done: Expose Open/Close as public in TIdLogBase
|
||||||
|
|
||||||
|
Rev 1.0 11/13/2002 07:55:58 AM JPMugaas
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdLogBase;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
{$I IdCompilerDefines.inc}
|
||||||
|
//Put FPC into Delphi mode
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes,
|
||||||
|
IdIntercept, IdGlobal, IdSocketHandle, IdBaseComponent;
|
||||||
|
|
||||||
|
type
|
||||||
|
TIdLogBase = class(TIdConnectionIntercept)
|
||||||
|
protected
|
||||||
|
FActive: Boolean;
|
||||||
|
FLogTime: Boolean;
|
||||||
|
FReplaceCRLF: Boolean;
|
||||||
|
FStreamedActive: Boolean;
|
||||||
|
//
|
||||||
|
procedure InitComponent; override;
|
||||||
|
procedure LogStatus(const AText: string); virtual; abstract;
|
||||||
|
procedure LogReceivedData(const AText, AData: string); virtual; abstract;
|
||||||
|
procedure LogSentData(const AText, AData: string); virtual; abstract;
|
||||||
|
procedure SetActive(AValue: Boolean); virtual;
|
||||||
|
procedure Loaded; override;
|
||||||
|
function ReplaceCR(const AString : String) : String;
|
||||||
|
public
|
||||||
|
procedure Open; virtual;
|
||||||
|
procedure Close; virtual;
|
||||||
|
procedure Connect(AConnection: TComponent); override;
|
||||||
|
destructor Destroy; override;
|
||||||
|
procedure Disconnect; override;
|
||||||
|
procedure Receive(var ABuffer: TIdBytes); override;
|
||||||
|
procedure Send(var ABuffer: TIdBytes); override;
|
||||||
|
published
|
||||||
|
property Active: Boolean read FActive write SetActive default False;
|
||||||
|
property LogTime: Boolean read FLogTime write FLogTime default True;
|
||||||
|
property ReplaceCRLF: Boolean read FReplaceCRLF write FReplaceCRLF default true;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
IdResourceStringsCore, SysUtils;
|
||||||
|
|
||||||
|
const
|
||||||
|
LOldStr : array [0..2] of string =
|
||||||
|
( EOL, CR, LF );
|
||||||
|
LNewStr : array [0..2] of string =
|
||||||
|
( RSLogEOL, RSLogCR, RSLogLF );
|
||||||
|
|
||||||
|
{ TIdLogBase }
|
||||||
|
|
||||||
|
procedure TIdLogBase.Close;
|
||||||
|
begin
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdLogBase.Connect(AConnection: TComponent);
|
||||||
|
begin
|
||||||
|
inherited Connect(AConnection);
|
||||||
|
if FActive then begin
|
||||||
|
LogStatus(RSLogConnected);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TIdLogBase.Destroy;
|
||||||
|
begin
|
||||||
|
Active := False;
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdLogBase.Disconnect;
|
||||||
|
begin
|
||||||
|
if FActive then begin
|
||||||
|
LogStatus(RSLogDisconnected);
|
||||||
|
end;
|
||||||
|
inherited Disconnect;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdLogBase.InitComponent;
|
||||||
|
begin
|
||||||
|
inherited InitComponent;
|
||||||
|
FLogTime := True;
|
||||||
|
ReplaceCRLF := True;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdLogBase.Loaded;
|
||||||
|
begin
|
||||||
|
inherited Loaded;
|
||||||
|
Active := FStreamedActive;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdLogBase.Open;
|
||||||
|
begin
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdLogBase.Receive(var ABuffer: TIdBytes);
|
||||||
|
var
|
||||||
|
s: string;
|
||||||
|
LMsg: string;
|
||||||
|
begin
|
||||||
|
// let the next Intercept in the chain decode its data first
|
||||||
|
inherited Receive(ABuffer);
|
||||||
|
|
||||||
|
if FActive then begin
|
||||||
|
LMsg := '';
|
||||||
|
if LogTime then begin
|
||||||
|
LMsg := DateTimeToStr(Now);
|
||||||
|
end;
|
||||||
|
s := BytesToStringRaw(ABuffer);
|
||||||
|
if FReplaceCRLF then begin
|
||||||
|
s := ReplaceCR(S);
|
||||||
|
end;
|
||||||
|
LogReceivedData(LMsg, s);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdLogBase.ReplaceCR(const AString: String): String;
|
||||||
|
begin
|
||||||
|
Result := StringsReplace(AString, LOldStr, LNewStr);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdLogBase.Send(var ABuffer: TIdBytes);
|
||||||
|
var
|
||||||
|
s: string;
|
||||||
|
LMsg: string;
|
||||||
|
begin
|
||||||
|
if FActive then begin
|
||||||
|
LMsg := '';
|
||||||
|
if LogTime then begin
|
||||||
|
LMsg := DateTimeToStr(Now);
|
||||||
|
end;
|
||||||
|
s := BytesToStringRaw(ABuffer);
|
||||||
|
if FReplaceCRLF then begin
|
||||||
|
s := ReplaceCR(S);
|
||||||
|
end;
|
||||||
|
LogSentData(LMsg, s);
|
||||||
|
end;
|
||||||
|
|
||||||
|
// let the next Intercept in the chain encode its data next
|
||||||
|
inherited Send(ABuffer);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdLogBase.SetActive(AValue: Boolean);
|
||||||
|
begin
|
||||||
|
if IsDesignTime or IsLoading then begin
|
||||||
|
FStreamedActive := AValue;
|
||||||
|
end
|
||||||
|
else if FActive <> AValue then
|
||||||
|
begin
|
||||||
|
FActive := AValue;
|
||||||
|
if FActive then begin
|
||||||
|
Open;
|
||||||
|
end else begin
|
||||||
|
Close;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1,72 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.4 8/6/04 12:21:28 AM RLebeau
|
||||||
|
Removed TIdLogDebugTarget type, not used anywhere
|
||||||
|
|
||||||
|
Rev 1.3 2004.02.03 4:17:16 PM czhower
|
||||||
|
For unit name changes.
|
||||||
|
|
||||||
|
Rev 1.2 2003.10.17 8:17:22 PM czhower
|
||||||
|
Removed const
|
||||||
|
|
||||||
|
Rev 1.1 4/22/2003 4:34:22 PM BGooijen
|
||||||
|
DebugOutput is now in IdGlobal
|
||||||
|
|
||||||
|
Rev 1.0 11/13/2002 07:56:02 AM JPMugaas
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdLogDebug;
|
||||||
|
|
||||||
|
interface
|
||||||
|
{$I IdCompilerDefines.inc}
|
||||||
|
//Put FPC into Delphi mode
|
||||||
|
uses
|
||||||
|
IdLogBase;
|
||||||
|
|
||||||
|
type
|
||||||
|
TIdLogDebug = class(TIdLogBase)
|
||||||
|
protected
|
||||||
|
procedure LogStatus(const AText: string); override;
|
||||||
|
procedure LogReceivedData(const AText, AData: string); override;
|
||||||
|
procedure LogSentData(const AText, AData: string); override;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
IdGlobal;
|
||||||
|
|
||||||
|
{ TIdLogDebug }
|
||||||
|
|
||||||
|
procedure TIdLogDebug.LogReceivedData(const AText, AData: string);
|
||||||
|
begin
|
||||||
|
DebugOutput('Recv ' + AText + ': ' + AData); {Do not Localize}
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdLogDebug.LogSentData(const AText, AData: string);
|
||||||
|
begin
|
||||||
|
DebugOutput('Sent ' + AText + ': ' + AData); {Do not Localize}
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdLogDebug.LogStatus(const AText: string);
|
||||||
|
begin
|
||||||
|
DebugOutput('Stat ' + AText); {Do not Localize}
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
|
@ -0,0 +1,83 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.2 2004.05.20 12:34:28 PM czhower
|
||||||
|
Removed more non .NET compatible stream read and writes
|
||||||
|
|
||||||
|
Rev 1.1 2003.10.17 8:17:22 PM czhower
|
||||||
|
Removed const
|
||||||
|
|
||||||
|
Rev 1.0 11/13/2002 07:56:08 AM JPMugaas
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdLogEvent;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
{$I IdCompilerDefines.inc}
|
||||||
|
//Put FPC into Delphi mode
|
||||||
|
|
||||||
|
uses
|
||||||
|
IdLogBase, IdBaseComponent, Classes;
|
||||||
|
|
||||||
|
type
|
||||||
|
TLogItemStatusEvent = procedure(ASender: TComponent; const AText: string) of object;
|
||||||
|
TLogItemDataEvent = procedure(ASender: TComponent; const AText, AData: string) of object;
|
||||||
|
|
||||||
|
TIdLogEvent = class(TIdLogBase)
|
||||||
|
protected
|
||||||
|
FOnReceived: TLogItemDataEvent;
|
||||||
|
FOnSent: TLogItemDataEvent;
|
||||||
|
FOnStatus: TLogItemStatusEvent;
|
||||||
|
//
|
||||||
|
procedure LogStatus(const AText: string); override;
|
||||||
|
procedure LogReceivedData(const AText, AData: string); override;
|
||||||
|
procedure LogSentData(const AText, AData: string); override;
|
||||||
|
public
|
||||||
|
published
|
||||||
|
property OnReceived: TLogItemDataEvent read FOnReceived write FOnReceived;
|
||||||
|
property OnSent: TLogItemDataEvent read FOnSent write FOnSent;
|
||||||
|
property OnStatus: TLogItemStatusEvent read FOnStatus write FOnStatus;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
{ TIdLogEvent }
|
||||||
|
|
||||||
|
procedure TIdLogEvent.LogReceivedData(const AText, AData: string);
|
||||||
|
begin
|
||||||
|
if Assigned(OnReceived) then begin
|
||||||
|
OnReceived(Self, AText, AData);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdLogEvent.LogSentData(const AText, AData: string);
|
||||||
|
begin
|
||||||
|
if Assigned(OnSent) then begin
|
||||||
|
OnSent(Self, AText, AData);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdLogEvent.LogStatus(const AText: string);
|
||||||
|
begin
|
||||||
|
if Assigned(OnStatus) then begin
|
||||||
|
OnStatus(Self, AText);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
|
@ -0,0 +1,171 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.8 7/23/04 6:36:54 PM RLebeau
|
||||||
|
Added extra exception handling to Open()
|
||||||
|
|
||||||
|
Rev 1.7 2004.05.20 12:34:30 PM czhower
|
||||||
|
Removed more non .NET compatible stream read and writes
|
||||||
|
|
||||||
|
Rev 1.6 2004.02.03 4:17:16 PM czhower
|
||||||
|
For unit name changes.
|
||||||
|
|
||||||
|
Rev 1.5 2003.10.17 6:15:54 PM czhower
|
||||||
|
Upgrades
|
||||||
|
|
||||||
|
Rev 1.4 2003.10.16 11:24:36 AM czhower
|
||||||
|
Bug fix
|
||||||
|
|
||||||
|
Rev 1.3 10/15/2003 8:00:10 PM DSiders
|
||||||
|
Added resource string for exception raised in TIdLogFile.SetFilename.
|
||||||
|
|
||||||
|
Rev 1.2 2003.10.14 1:27:10 PM czhower
|
||||||
|
Uupdates + Intercept support
|
||||||
|
|
||||||
|
Rev 1.1 6/16/2003 11:01:06 AM EHill
|
||||||
|
Throw exception if the filename is set while the log is open.
|
||||||
|
Expose Open and Close as public instead of protected.
|
||||||
|
|
||||||
|
Rev 1.0 11/13/2002 07:56:12 AM JPMugaas
|
||||||
|
|
||||||
|
19-Aug-2001 DSiders
|
||||||
|
Fixed bug in Open. Use file mode fmCreate when Filename does *not* exist.
|
||||||
|
|
||||||
|
19-Aug-2001 DSiders
|
||||||
|
Added protected method TIdLogFile.LogWriteString.
|
||||||
|
|
||||||
|
19-Aug-2001 DSiders
|
||||||
|
Changed implementation of TIdLogFile methods LogStatus, LogReceivedData, and
|
||||||
|
LogSentData to use LogWriteString.
|
||||||
|
|
||||||
|
19-Aug-2001 DSiders
|
||||||
|
Added class TIdLogFileEx with the LogFormat method.
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdLogFile;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
{$I IdCompilerDefines.inc}
|
||||||
|
//Put FPC into Delphi mode
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes,
|
||||||
|
IdLogBase;
|
||||||
|
|
||||||
|
type
|
||||||
|
TIdLogFile = class(TIdLogBase)
|
||||||
|
protected
|
||||||
|
FFilename: String;
|
||||||
|
FFileStream: TStream;
|
||||||
|
//
|
||||||
|
procedure LogFormat(const AFormat: string; const AArgs: array of const); virtual;
|
||||||
|
procedure LogReceivedData(const AText, AData: string); override;
|
||||||
|
procedure LogSentData(const AText, AData: string); override;
|
||||||
|
procedure LogStatus(const AText: string); override;
|
||||||
|
procedure LogWriteString(const AText: string); virtual;
|
||||||
|
//
|
||||||
|
procedure SetFilename(const AFilename: String);
|
||||||
|
public
|
||||||
|
procedure Open; override;
|
||||||
|
procedure Close; override;
|
||||||
|
published
|
||||||
|
property Filename: String read FFilename write SetFilename;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
IdGlobal, IdException, IdResourceStringsCore, IdBaseComponent, SysUtils;
|
||||||
|
|
||||||
|
{ TIdLogFile }
|
||||||
|
|
||||||
|
procedure TIdLogFile.Close;
|
||||||
|
begin
|
||||||
|
FreeAndNil(FFileStream);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdLogFile.LogReceivedData(const AText, AData: string);
|
||||||
|
begin
|
||||||
|
LogWriteString(RSLogRecv + AText + ': ' + AData + EOL); {Do not translate}
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdLogFile.LogSentData(const AText, AData: string);
|
||||||
|
begin
|
||||||
|
LogWriteString(RSLogSent + AText + ': ' + AData + EOL); {Do not translate}
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdLogFile.LogStatus(const AText: string);
|
||||||
|
begin
|
||||||
|
LogWriteString(RSLogStat + AText + EOL);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdLogFile.Open;
|
||||||
|
begin
|
||||||
|
if not IsDesignTime then begin
|
||||||
|
FFileStream := TIdAppendFileStream.Create(Filename);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdLogFile.LogWriteString(const AText: string);
|
||||||
|
var
|
||||||
|
LEncoding: IIdTextEncoding;
|
||||||
|
begin
|
||||||
|
if Assigned(FFileStream) then begin
|
||||||
|
LEncoding := IndyTextEncoding_8Bit;
|
||||||
|
WriteStringToStream(FFileStream, AText, LEncoding{$IFDEF STRING_IS_ANSI}, LEncoding{$ENDIF});
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdLogFile.LogFormat(const AFormat: string; const AArgs: array of const);
|
||||||
|
var
|
||||||
|
sPre: string;
|
||||||
|
sMsg: string;
|
||||||
|
sData: string;
|
||||||
|
begin
|
||||||
|
// forces Open to be called prior to Connect
|
||||||
|
if not Active then begin
|
||||||
|
Active := True;
|
||||||
|
end;
|
||||||
|
|
||||||
|
sPre := ''; {Do not translate}
|
||||||
|
sMsg := ''; {Do not translate}
|
||||||
|
|
||||||
|
if LogTime then begin
|
||||||
|
sPre := DateTimeToStr(Now) + ' '; {Do not translate}
|
||||||
|
end;
|
||||||
|
|
||||||
|
sData := IndyFormat(AFormat, AArgs);
|
||||||
|
if FReplaceCRLF then begin
|
||||||
|
sData := ReplaceCR(sData);
|
||||||
|
end;
|
||||||
|
sMsg := sPre + sData + EOL;
|
||||||
|
|
||||||
|
LogWriteString(sMsg);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdLogFile.SetFilename(const AFilename: String);
|
||||||
|
begin
|
||||||
|
if Assigned(FFileStream) then begin
|
||||||
|
raise EIdException.Create(RSLogFileAlreadyOpen);
|
||||||
|
end;
|
||||||
|
FFilename := AFilename;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
||||||
|
|
|
@ -0,0 +1,118 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.5 2004.05.20 12:34:32 PM czhower
|
||||||
|
Removed more non .NET compatible stream read and writes
|
||||||
|
|
||||||
|
Rev 1.4 2004.01.20 10:03:30 PM czhower
|
||||||
|
InitComponent
|
||||||
|
|
||||||
|
Rev 1.3 2003.10.17 6:15:56 PM czhower
|
||||||
|
Upgrades
|
||||||
|
|
||||||
|
Rev 1.2 2003.10.17 4:28:54 PM czhower
|
||||||
|
Changed stream names to be consistent with IOHandlerStream
|
||||||
|
|
||||||
|
Rev 1.1 2003.10.14 1:27:12 PM czhower
|
||||||
|
Uupdates + Intercept support
|
||||||
|
|
||||||
|
Rev 1.0 11/13/2002 07:56:18 AM JPMugaas
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdLogStream;
|
||||||
|
|
||||||
|
interface
|
||||||
|
{$I IdCompilerDefines.inc}
|
||||||
|
//Put FPC into Delphi mode
|
||||||
|
uses
|
||||||
|
Classes,
|
||||||
|
IdLogBase, IdGlobal;
|
||||||
|
|
||||||
|
type
|
||||||
|
TIdLogStream = class(TIdLogBase)
|
||||||
|
protected
|
||||||
|
FFreeStreams: Boolean;
|
||||||
|
FReceiveStream: TStream;
|
||||||
|
FSendStream: TStream;
|
||||||
|
//
|
||||||
|
procedure InitComponent; override;
|
||||||
|
procedure LogStatus(const AText: string); override;
|
||||||
|
procedure LogReceivedData(const AText, AData: string); override;
|
||||||
|
procedure LogSentData(const AText, AData: string); override;
|
||||||
|
public
|
||||||
|
procedure Disconnect; override;
|
||||||
|
//
|
||||||
|
property FreeStreams: Boolean read FFreeStreams write FFreeStreams;
|
||||||
|
property ReceiveStream: TStream read FReceiveStream write FReceiveStream;
|
||||||
|
property SendStream: TStream read FSendStream write FSendStream;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
uses SysUtils;
|
||||||
|
|
||||||
|
// TODO: This was orginally for VCL. For .Net what do we do? Convert back to
|
||||||
|
// 7 bit? Log all? Logging all seems to be a disaster.
|
||||||
|
// Text seems to be best, users are expecting text in this class. But
|
||||||
|
// this write stream will dump unicode out in .net.....
|
||||||
|
// So just convert it again back to 7 bit? How is proper to write
|
||||||
|
// 7 bit to file? Use AnsiString?
|
||||||
|
|
||||||
|
{ TIdLogStream }
|
||||||
|
|
||||||
|
procedure TIdLogStream.Disconnect;
|
||||||
|
begin
|
||||||
|
inherited Disconnect;
|
||||||
|
if FreeStreams then begin
|
||||||
|
FreeAndNil(FReceiveStream);
|
||||||
|
FreeAndNil(FSendStream);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdLogStream.InitComponent;
|
||||||
|
begin
|
||||||
|
inherited InitComponent;
|
||||||
|
FFreeStreams := True;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdLogStream.LogReceivedData(const AText, AData: string);
|
||||||
|
var
|
||||||
|
LEncoding: IIdTextEncoding;
|
||||||
|
begin
|
||||||
|
if FReceiveStream <> nil then begin
|
||||||
|
LEncoding := IndyTextEncoding_8Bit;
|
||||||
|
WriteStringToStream(FReceiveStream, AData, LEncoding{$IFDEF STRING_IS_ANSI}, LEncoding{$ENDIF});
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdLogStream.LogSentData(const AText, AData: string);
|
||||||
|
var
|
||||||
|
LEncoding: IIdTextEncoding;
|
||||||
|
begin
|
||||||
|
if FSendStream <> nil then begin
|
||||||
|
LEncoding := IndyTextEncoding_8Bit;
|
||||||
|
WriteStringToStream(FSendStream, AData, LEncoding{$IFDEF STRING_IS_ANSI}, LEncoding{$ENDIF});
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdLogStream.LogStatus(const AText: string);
|
||||||
|
begin
|
||||||
|
// We just leave this empty because the AText is not part of the stream and we
|
||||||
|
// do not want to raise an abstract method exception.
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
|
@ -0,0 +1,306 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.15 7/9/04 4:26:28 PM RLebeau
|
||||||
|
Removed TIdBytes local variable from Send()
|
||||||
|
|
||||||
|
Rev 1.14 09/06/2004 00:28:00 CCostelloe
|
||||||
|
Kylix 3 patch
|
||||||
|
|
||||||
|
Rev 1.13 4/25/2004 7:54:26 AM JPMugaas
|
||||||
|
Fix for AV.
|
||||||
|
|
||||||
|
Rev 1.12 2/8/2004 12:58:42 PM JPMugaas
|
||||||
|
Should now compile in DotNET.
|
||||||
|
|
||||||
|
Rev 1.11 2004.02.03 4:16:48 PM czhower
|
||||||
|
For unit name changes.
|
||||||
|
|
||||||
|
Rev 1.10 2/1/2004 6:10:14 PM JPMugaas
|
||||||
|
Should compile better.
|
||||||
|
|
||||||
|
Rev 1.9 2/1/2004 4:52:34 PM JPMugaas
|
||||||
|
Removed the rest of the Todo; items.
|
||||||
|
|
||||||
|
Rev 1.8 2004.01.20 10:03:30 PM czhower
|
||||||
|
InitComponent
|
||||||
|
|
||||||
|
Rev 1.7 2004.01.02 9:38:46 PM czhower
|
||||||
|
Removed warning
|
||||||
|
|
||||||
|
Rev 1.6 2003.10.24 10:09:54 AM czhower
|
||||||
|
Compiles
|
||||||
|
|
||||||
|
Rev 1.5 2003.10.20 12:03:08 PM czhower
|
||||||
|
Added IdStackBSDBase to make it compile again.
|
||||||
|
|
||||||
|
Rev 1.4 10/19/2003 10:41:12 PM BGooijen
|
||||||
|
Compiles in DotNet and D7 again
|
||||||
|
|
||||||
|
Rev 1.3 10/19/2003 9:34:28 PM BGooijen
|
||||||
|
SetSocketOption
|
||||||
|
|
||||||
|
Rev 1.2 2003.10.11 5:48:58 PM czhower
|
||||||
|
-VCL fixes for servers
|
||||||
|
-Chain suport for servers (Super core)
|
||||||
|
-Scheduler upgrades
|
||||||
|
-Full yarn support
|
||||||
|
|
||||||
|
Rev 1.1 2003.09.30 1:23:00 PM czhower
|
||||||
|
Stack split for DotNet
|
||||||
|
|
||||||
|
Rev 1.0 11/13/2002 08:45:24 AM JPMugaas
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdRawBase;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
{
|
||||||
|
We need to selectively disable some functionality in DotNET with buffers as
|
||||||
|
we don't want to impact anything else such as TIdICMPClient.
|
||||||
|
}
|
||||||
|
|
||||||
|
{$I IdCompilerDefines.inc}
|
||||||
|
|
||||||
|
uses
|
||||||
|
IdComponent, IdGlobal, IdSocketHandle, IdStack,
|
||||||
|
{$IFDEF MSWINDOWS}
|
||||||
|
IdWship6,
|
||||||
|
{$ENDIF}
|
||||||
|
IdStackConsts;
|
||||||
|
|
||||||
|
const
|
||||||
|
Id_TIdRawBase_Port = 0;
|
||||||
|
Id_TIdRawBase_BufferSize = 8192;
|
||||||
|
GReceiveTimeout = 0;
|
||||||
|
GFTTL = 128;
|
||||||
|
|
||||||
|
type
|
||||||
|
TIdRawBase = class(TIdComponent)
|
||||||
|
protected
|
||||||
|
FBinding: TIdSocketHandle;
|
||||||
|
FHost: string;
|
||||||
|
FPort: TIdPort;
|
||||||
|
FReceiveTimeout: integer;
|
||||||
|
FProtocol: TIdSocketProtocol;
|
||||||
|
FProtocolIPv6 : TIdSocketProtocol;
|
||||||
|
FTTL: Integer;
|
||||||
|
FPkt : TIdPacketInfo;
|
||||||
|
FConnected : Boolean;
|
||||||
|
//
|
||||||
|
function GetBinding: TIdSocketHandle;
|
||||||
|
function GetIPVersion: TIdIPVersion;
|
||||||
|
//
|
||||||
|
procedure InitComponent; override;
|
||||||
|
procedure SetIPVersion(const AValue: TIdIPVersion);
|
||||||
|
procedure SetTTL(const Value: Integer);
|
||||||
|
procedure SetHost(const AValue : String); virtual;
|
||||||
|
//
|
||||||
|
// TODO: figure out which ReceiveXXX functions we want
|
||||||
|
//
|
||||||
|
property IPVersion : TIdIPVersion read GetIPVersion write SetIPVersion;
|
||||||
|
//
|
||||||
|
property Port: TIdPort read FPort write FPort default Id_TIdRawBase_Port;
|
||||||
|
property Protocol: TIdSocketProtocol read FProtocol write FProtocol default Id_IPPROTO_RAW;
|
||||||
|
property ProtocolIPv6 : TIdSocketProtocol read FProtocolIPv6 write FProtocolIPv6;
|
||||||
|
property TTL: Integer read FTTL write SetTTL default GFTTL;
|
||||||
|
|
||||||
|
public
|
||||||
|
destructor Destroy; override;
|
||||||
|
|
||||||
|
function ReceiveBuffer(var VBuffer : TIdBytes; ATimeOut: Integer = -1): Integer;
|
||||||
|
procedure Send(const AData: string; AByteEncoding: IIdTextEncoding = nil
|
||||||
|
{$IFDEF STRING_IS_ANSI}; ASrcEncoding: IIdTextEncoding = nil{$ENDIF}
|
||||||
|
); overload; virtual;
|
||||||
|
procedure Send(const AData: TIdBytes); overload; virtual;
|
||||||
|
procedure Send(const AHost: string; const APort: TIdPort; const AData: string;
|
||||||
|
AByteEncoding: IIdTextEncoding = nil
|
||||||
|
{$IFDEF STRING_IS_ANSI}; ASrcEncoding: IIdTextEncoding = nil{$ENDIF}
|
||||||
|
); overload; virtual;
|
||||||
|
procedure Send(const AHost: string; const APort: TIdPort; const ABuffer : TIdBytes); overload; virtual;
|
||||||
|
//
|
||||||
|
property Binding: TIdSocketHandle read GetBinding;
|
||||||
|
property ReceiveTimeout: integer read FReceiveTimeout write FReceiveTimeout Default GReceiveTimeout;
|
||||||
|
published
|
||||||
|
property Host: string read FHost write SetHost;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
SysUtils;
|
||||||
|
|
||||||
|
{ TIdRawBase }
|
||||||
|
|
||||||
|
destructor TIdRawBase.Destroy;
|
||||||
|
begin
|
||||||
|
FreeAndNil(FBinding);
|
||||||
|
FreeAndNil(FPkt);
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdRawBase.GetBinding: TIdSocketHandle;
|
||||||
|
begin
|
||||||
|
if not FBinding.HandleAllocated then begin
|
||||||
|
if FBinding.IPVersion = Id_IPv4 then
|
||||||
|
begin
|
||||||
|
FBinding.AllocateSocket(Id_SOCK_RAW, FProtocol);
|
||||||
|
end else
|
||||||
|
begin
|
||||||
|
FBinding.AllocateSocket(Id_SOCK_RAW, FProtocolIPv6);
|
||||||
|
{$IFDEF DOTNET}
|
||||||
|
{$IFDEF DOTNET_2_OR_ABOVE}
|
||||||
|
{
|
||||||
|
Microsoft NET Framework 1.1 may actually have the packetinfo option but that
|
||||||
|
will not do you any good because you need a RecvMsg function which is not
|
||||||
|
in NET 1.1. NET 2.0 does have a RecvMsg function, BTW.
|
||||||
|
}
|
||||||
|
//indicate we want packet information with RecvMsg calls
|
||||||
|
FBinding.SetSockOpt(Id_SOL_IPv6, Id_IPV6_PKTINFO, 1);
|
||||||
|
{$ENDIF}
|
||||||
|
{$ELSE}
|
||||||
|
//indicate we want packet information with RecvMsg WSARecvMsg calls
|
||||||
|
FBinding.SetSockOpt(Id_SOL_IPv6, Id_IPV6_PKTINFO, 1);
|
||||||
|
FBinding.SetSockOpt(Id_SOL_IPv6, Id_IPV6_HOPLIMIT, 1);
|
||||||
|
{$ENDIF}
|
||||||
|
end;
|
||||||
|
//set hop limit (or TTL as it was called in IPv4
|
||||||
|
FBinding.SetTTL(FTTL);
|
||||||
|
end;
|
||||||
|
Result := FBinding;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdRawBase.ReceiveBuffer(var VBuffer : TIdBytes; ATimeOut: Integer = -1): Integer;
|
||||||
|
var
|
||||||
|
LIP : String;
|
||||||
|
LPort : TIdPort;
|
||||||
|
LIPVersion: TIdIPVersion;
|
||||||
|
begin
|
||||||
|
Result := 0;
|
||||||
|
// TODO: pass flags to recv()
|
||||||
|
if ATimeOut < 0 then
|
||||||
|
begin
|
||||||
|
ATimeOut := FReceiveTimeout;
|
||||||
|
end;
|
||||||
|
if Length(VBuffer) > 0 then
|
||||||
|
begin
|
||||||
|
if Binding.Readable(ATimeOut) then begin
|
||||||
|
if FBinding.IPVersion = Id_IPv4 then
|
||||||
|
begin
|
||||||
|
Result := Binding.RecvFrom(VBuffer, LIP, LPort, LIPVersion);
|
||||||
|
FPkt.Reset;
|
||||||
|
FPkt.SourceIP := LIP;
|
||||||
|
FPkt.SourcePort := LPort;
|
||||||
|
FPkt.SourceIPVersion := LIPVersion;
|
||||||
|
FPkt.DestIPVersion := LIPVersion;
|
||||||
|
end else
|
||||||
|
begin
|
||||||
|
{
|
||||||
|
IMPORTANT!!!!
|
||||||
|
|
||||||
|
Do NOT call GStack.ReceiveMsg unless it is absolutely necessary.
|
||||||
|
The reasons are:
|
||||||
|
|
||||||
|
1) WSARecvMsg is only supported on WindowsXP or later. I think Linux
|
||||||
|
might have a RecvMsg function as well but I'm not sure.
|
||||||
|
2) GStack.ReceiveMsg is not supported in the Microsoft NET framework 1.1.
|
||||||
|
It may be supported in later versions.
|
||||||
|
|
||||||
|
For IPv4 and raw sockets, it usually isn't because we get the raw header itself.
|
||||||
|
|
||||||
|
For IPv6 and raw sockets, we call this to get information about the destination
|
||||||
|
IP address and hopefully, the TTL (hop count).
|
||||||
|
}
|
||||||
|
|
||||||
|
Result := GStack.ReceiveMsg(Binding.Handle, VBuffer, FPkt);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdRawBase.Send(const AHost: string; const APort: TIdPort; const AData: string;
|
||||||
|
AByteEncoding: IIdTextEncoding = nil
|
||||||
|
{$IFDEF STRING_IS_ANSI}; ASrcEncoding: IIdTextEncoding = nil{$ENDIF}
|
||||||
|
);
|
||||||
|
begin
|
||||||
|
Send(AHost, APort, ToBytes(AData, AByteEncoding{$IFDEF STRING_IS_ANSI}, ASrcEncoding{$ENDIF}));
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdRawBase.Send(const AData: string;
|
||||||
|
AByteEncoding: IIdTextEncoding = nil
|
||||||
|
{$IFDEF STRING_IS_ANSI}; ASrcEncoding: IIdTextEncoding = nil{$ENDIF}
|
||||||
|
);
|
||||||
|
begin
|
||||||
|
Send(ToBytes(AData, AByteEncoding{$IFDEF STRING_IS_ANSI}, ASrcEncoding{$ENDIF}));
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdRawBase.Send(const AData: TIdBytes);
|
||||||
|
begin
|
||||||
|
Send(Host, Port, AData);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdRawBase.Send(const AHost: string; const APort: TIdPort; const ABuffer : TIdBytes);
|
||||||
|
var
|
||||||
|
LIP : String;
|
||||||
|
begin
|
||||||
|
LIP := GStack.ResolveHost(AHost, FBinding.IPVersion);
|
||||||
|
Binding.SendTo(LIP, APort, ABuffer, FBinding.IPVersion);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdRawBase.SetTTL(const Value: Integer);
|
||||||
|
begin
|
||||||
|
if FTTL <> Value then
|
||||||
|
begin
|
||||||
|
FTTL := Value;
|
||||||
|
if FBinding.HandleAllocated then
|
||||||
|
begin
|
||||||
|
FBinding.SetTTL(FTTL);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdRawBase.InitComponent;
|
||||||
|
begin
|
||||||
|
inherited InitComponent;
|
||||||
|
FBinding := TIdSocketHandle.Create(nil);
|
||||||
|
FBinding.IPVersion := Id_IPv4;
|
||||||
|
FPkt := TIdPacketInfo.Create;
|
||||||
|
ReceiveTimeout := GReceiveTimeout;
|
||||||
|
FPort := Id_TIdRawBase_Port;
|
||||||
|
FProtocol := Id_IPPROTO_RAW;
|
||||||
|
FTTL := GFTTL;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdRawBase.GetIPVersion;
|
||||||
|
begin
|
||||||
|
Result := FBinding.IPVersion;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdRawBase.SetIPVersion(const AValue: TIdIPVersion);
|
||||||
|
begin
|
||||||
|
FBinding.IPVersion := AValue;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdRawBase.SetHost(const AValue: String);
|
||||||
|
begin
|
||||||
|
FHost := AValue;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
|
@ -0,0 +1,47 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.0 11/13/2002 08:45:32 AM JPMugaas
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdRawClient;
|
||||||
|
|
||||||
|
interface
|
||||||
|
{$i IdCompilerDefines.inc}
|
||||||
|
|
||||||
|
uses
|
||||||
|
IdGlobal,
|
||||||
|
IdRawBase;
|
||||||
|
|
||||||
|
type
|
||||||
|
TIdRawClient = class(TIdRawBase)
|
||||||
|
|
||||||
|
published
|
||||||
|
property ReceiveTimeout;
|
||||||
|
property Host;
|
||||||
|
property Port;
|
||||||
|
property Protocol;
|
||||||
|
property ProtocolIPv6;
|
||||||
|
property IPVersion;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
{ TIdRawClient }
|
||||||
|
|
||||||
|
end.
|
|
@ -0,0 +1,710 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.5 2004.02.03 4:16:50 PM czhower
|
||||||
|
For unit name changes.
|
||||||
|
|
||||||
|
Rev 1.4 2/1/2004 4:52:30 PM JPMugaas
|
||||||
|
Removed the rest of the Todo; items.
|
||||||
|
|
||||||
|
Rev 1.3 2/1/2004 4:20:30 PM JPMugaas
|
||||||
|
Should work in Win32. TODO: See about DotNET.
|
||||||
|
|
||||||
|
Rev 1.2 2003.10.11 5:49:06 PM czhower
|
||||||
|
-VCL fixes for servers
|
||||||
|
-Chain suport for servers (Super core)
|
||||||
|
-Scheduler upgrades
|
||||||
|
-Full yarn support
|
||||||
|
|
||||||
|
Rev 1.1 2003.09.30 1:23:00 PM czhower
|
||||||
|
Stack split for DotNet
|
||||||
|
|
||||||
|
Rev 1.0 11/13/2002 08:45:36 AM JPMugaas
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdRawFunctions;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
{$i IdCompilerDefines.inc}
|
||||||
|
|
||||||
|
uses
|
||||||
|
IdGlobal, IdRawHeaders, IdStack;
|
||||||
|
|
||||||
|
// ARP
|
||||||
|
procedure IdRawBuildArp(const AHwAddressFormat, AProtocolFormat: UInt16;
|
||||||
|
const AHwAddressLen, AProtocolLen: UInt8; const AnOpType: UInt16;
|
||||||
|
ASenderHw: TIdEtherAddr; ASenderPr: TIdInAddr; ATargetHw: TIdEtherAddr;
|
||||||
|
ATargetPr: TIdInAddr; const APayload: TIdBytes; var VBuffer: TIdBytes);
|
||||||
|
|
||||||
|
// DNS
|
||||||
|
procedure IdRawBuildDns(const AnId, AFlags, ANumQuestions, ANumAnswerRecs, ANumAuthRecs, ANumAddRecs: UInt16;
|
||||||
|
const APayload: TIdBytes; var VBuffer: TIdBytes);
|
||||||
|
|
||||||
|
// Ethernet
|
||||||
|
procedure IdRawBuildEthernet(ADest, ASource: TIdEtherAddr; AType: UInt16;
|
||||||
|
const APayload: TIdBytes; var VBuffer: TIdBytes);
|
||||||
|
|
||||||
|
// ICMP
|
||||||
|
procedure IdRawBuildIcmpEcho(AType, ACode: UInt8; AnId, ASeq: UInt16;
|
||||||
|
const APayload: TIdBytes; var VBuffer: TIdBytes);
|
||||||
|
procedure IdRawBuildIcmpMask(AType, ACode: UInt8; AnId, ASeq: UInt16; AMask: UInt32;
|
||||||
|
const APayload: TIdBytes; var VBuffer: TIdBytes);
|
||||||
|
procedure IdRawBuildIcmpRedirect(const AType, ACode: UInt8; AGateway: TIdInAddr;
|
||||||
|
const AnOrigLen: UInt16; const AnOrigTos: UInt8; const AnOrigId, AnOrigFrag: UInt16;
|
||||||
|
const AnOrigTtl, AnOrigProtocol: UInt8; AnOrigSource, AnOrigDest: TIdInAddr;
|
||||||
|
const AnOrigPayload: TIdBytes; var VBuffer: TIdBytes);
|
||||||
|
procedure IdRawBuildIcmpTimeExceed(const AType, ACode: UInt8; const AnOrigLen: UInt16;
|
||||||
|
const AnOrigTos: UInt8; const AnOrigId, AnOrigFrag: UInt16;
|
||||||
|
const AnOrigTtl, AnOrigProtocol: UInt8; const AnOrigSource, AnOrigDest: TIdInAddr;
|
||||||
|
const AnOrigPayload: TIdBytes; var VBuffer: TIdBytes);
|
||||||
|
procedure IdRawBuildIcmpTimestamp(const AType, ACode: UInt8; const AnId, ASeq: UInt16;
|
||||||
|
const AnOtime, AnRtime, ATtime: TIdNetTime; const APayload: TIdBytes;
|
||||||
|
var VBuffer: TIdBytes);
|
||||||
|
procedure IdRawBuildIcmpUnreach(AType, ACode: UInt8; AnOrigLen: UInt16;
|
||||||
|
AnOrigTos: UInt8; AnOrigId, AnOrigFrag: UInt16; AnOrigTtl, AnOrigProtocol: UInt8;
|
||||||
|
AnOrigSource, AnOrigDest: TIdInAddr; const AnOrigPayload, APayloadSize: Integer;
|
||||||
|
var VBuffer: TIdBytes);
|
||||||
|
|
||||||
|
// IGMP
|
||||||
|
procedure IdRawBuildIgmp(AType, ACode: UInt8; AnIp: TIdInAddr;
|
||||||
|
const APayload: UInt16; var VBuffer: TIdBytes);
|
||||||
|
|
||||||
|
// IP
|
||||||
|
procedure IdRawBuildIp(ALen: UInt16; ATos: UInt8; AnId, AFrag: UInt16;
|
||||||
|
ATtl, AProtocol: UInt8; ASource, ADest: TIdInAddr; const APayload: TIdBytes;
|
||||||
|
var VBuffer: TIdBytes; const AIdx: Integer = 0);
|
||||||
|
|
||||||
|
// RIP
|
||||||
|
procedure IdRawBuildRip(const ACommand, AVersion: UInt8;
|
||||||
|
const ARoutingDomain, AnAddressFamily, ARoutingTag: UInt16;
|
||||||
|
const AnAddr, AMask, ANextHop, AMetric: UInt32;
|
||||||
|
const APayload: TIdBytes; var VBuffer: TIdBytes);
|
||||||
|
|
||||||
|
// TCP
|
||||||
|
procedure IdRawBuildTcp(const ASourcePort, ADestPort: UInt16;
|
||||||
|
const ASeq, AnAck: UInt32; const AControl: UInt8;
|
||||||
|
const AWindowSize, AnUrgent: UInt16; const APayload: TIdBytes;
|
||||||
|
var VBuffer: TIdBytes);
|
||||||
|
|
||||||
|
// UDP
|
||||||
|
procedure IdRawBuildUdp(const ASourcePort, ADestPort: UInt16;
|
||||||
|
const APayload: TIdBytes; var VBuffer: TIdBytes);
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
SysUtils;
|
||||||
|
|
||||||
|
procedure IdRawBuildArp(const AHwAddressFormat, AProtocolFormat: UInt16;
|
||||||
|
const AHwAddressLen, AProtocolLen: UInt8; const AnOpType: UInt16;
|
||||||
|
ASenderHw: TIdEtherAddr; ASenderPr: TIdInAddr; ATargetHw: TIdEtherAddr;
|
||||||
|
ATargetPr: TIdInAddr; const APayload: TIdBytes; var VBuffer: TIdBytes);
|
||||||
|
var
|
||||||
|
HdrArp: TIdArpHdr;
|
||||||
|
LIdx: UInt32;
|
||||||
|
LLen : UInt32;
|
||||||
|
begin
|
||||||
|
// check input
|
||||||
|
LIdx := Id_ARP_HSIZE + Length(VBuffer);
|
||||||
|
LLen := Length(VBuffer);
|
||||||
|
if LLen < LIdx then begin
|
||||||
|
SetLength(VBuffer, LIdx);
|
||||||
|
end;
|
||||||
|
|
||||||
|
// construct header
|
||||||
|
HdrArp := TIdArpHdr.Create;
|
||||||
|
try
|
||||||
|
HdrArp.arp_hrd := GStack.HostToNetwork(AHwAddressFormat);
|
||||||
|
HdrArp.arp_pro := GStack.HostToNetwork(AProtocolFormat);
|
||||||
|
HdrArp.arp_hln := AHwAddressLen;
|
||||||
|
HdrArp.arp_pln := AProtocolLen;
|
||||||
|
HdrArp.arp_op := GStack.HostToNetwork(AnOpType);
|
||||||
|
HdrArp.arp_sha.CopyFrom(ASenderHw);
|
||||||
|
HdrArp.arp_spa.s_l := ASenderPr.s_l;
|
||||||
|
HdrArp.arp_tha.CopyFrom(ATargetHw);
|
||||||
|
HdrArp.arp_tpa.CopyFrom(ATargetPr);
|
||||||
|
|
||||||
|
// copy payload
|
||||||
|
if Length(APayload) > 0 then begin
|
||||||
|
CopyTIdBytes(APayload, 0, VBuffer, Id_ICMP_ECHO_HSIZE, Length(APayload));
|
||||||
|
end;
|
||||||
|
|
||||||
|
// copy header
|
||||||
|
LIdx := 0;
|
||||||
|
HdrArp.WriteStruct(VBuffer, LIdx);
|
||||||
|
finally
|
||||||
|
FreeAndNil(HdrArp);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure IdRawBuildDns(const AnId, AFlags, ANumQuestions, ANumAnswerRecs,
|
||||||
|
ANumAuthRecs, ANumAddRecs: UInt16; const APayload: TIdBytes;
|
||||||
|
var VBuffer: TIdBytes);
|
||||||
|
var
|
||||||
|
HdrDns: TIdDnsHdr;
|
||||||
|
LIdx: UInt32;
|
||||||
|
LLen : UInt32;
|
||||||
|
begin
|
||||||
|
// check input
|
||||||
|
LIdx := Length(APayload) + Id_DNS_HSIZE;
|
||||||
|
LLen := UInt32(Length(VBuffer));
|
||||||
|
if LLen < LIdx then begin
|
||||||
|
SetLength(VBuffer, LIdx);
|
||||||
|
end;
|
||||||
|
|
||||||
|
// construct header
|
||||||
|
HdrDns := TIdDnsHdr.Create;
|
||||||
|
try
|
||||||
|
HdrDns.dns_id := GStack.HostToNetwork(AnId);
|
||||||
|
HdrDns.dns_flags := GStack.HostToNetwork(AFlags);
|
||||||
|
HdrDns.dns_num_q := GStack.HostToNetwork(ANumQuestions);
|
||||||
|
HdrDns.dns_num_answ_rr := GStack.HostToNetwork(ANumAnswerRecs);
|
||||||
|
HdrDns.dns_num_auth_rr := GStack.HostToNetwork(ANumAuthRecs);
|
||||||
|
HdrDns.dns_num_addi_rr := GStack.HostToNetwork(ANumAddRecs);
|
||||||
|
|
||||||
|
// copy payload
|
||||||
|
if Length(APayload) > 0 then begin
|
||||||
|
CopyTIdBytes(APayload, 0, VBuffer, Id_DNS_HSIZE, Length(APayload));
|
||||||
|
end;
|
||||||
|
|
||||||
|
// copy header
|
||||||
|
LIdx := 0;
|
||||||
|
HdrDns.WriteStruct(VBuffer, LIdx);
|
||||||
|
finally
|
||||||
|
FreeAndNil(HdrDns);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure IdRawBuildEthernet(ADest, ASource: TIdEtherAddr; AType: UInt16;
|
||||||
|
const APayload: TIdBytes; var VBuffer: TIdBytes);
|
||||||
|
var
|
||||||
|
HdrEth: TIdEthernetHdr;
|
||||||
|
LIdx: UInt32;
|
||||||
|
LLen : UInt32;
|
||||||
|
begin
|
||||||
|
// make sure VBuffer will be long enough
|
||||||
|
LIdx := Length(ASource.Data) + Length(ADest.Data) + 2 + Length(APayload);
|
||||||
|
LLen := Length(VBuffer);
|
||||||
|
if LLen < LIdx then begin
|
||||||
|
SetLength(VBuffer, LIdx);
|
||||||
|
end;
|
||||||
|
|
||||||
|
// construct header
|
||||||
|
HdrEth := TIdEthernetHdr.Create;
|
||||||
|
try
|
||||||
|
HdrEth.ether_dhost.CopyFrom(ADest);
|
||||||
|
HdrEth.ether_shost.CopyFrom(ASource);
|
||||||
|
HdrEth.ether_type := GStack.HostToNetwork(AType);
|
||||||
|
|
||||||
|
// copy header
|
||||||
|
LIdx := 0;
|
||||||
|
HdrEth.WriteStruct(VBuffer, LIdx);
|
||||||
|
|
||||||
|
// copy payload if present
|
||||||
|
if Length(APayload) > 0 then begin
|
||||||
|
CopyTIdBytes(APayload, 0, VBuffer, LIdx, Length(APayload));
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
FreeAndNil(HdrEth);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
// TODO: check nibbles in IP header
|
||||||
|
procedure IdRawBuildIp(ALen: UInt16; ATos: UInt8; AnId, AFrag: UInt16; ATtl, AProtocol: UInt8;
|
||||||
|
ASource, ADest: TIdInAddr; const APayload: TIdBytes; var VBuffer: TIdBytes;
|
||||||
|
const AIdx: Integer = 0);
|
||||||
|
var
|
||||||
|
HdrIp: TIdIpHdr;
|
||||||
|
LIdx: UInt32;
|
||||||
|
LLen : UInt32;
|
||||||
|
begin
|
||||||
|
// check input
|
||||||
|
LIdx := Id_IP_HSIZE + Length(APayload) + AIdx;
|
||||||
|
LLen := Length(VBuffer);
|
||||||
|
if LLen < LIdx then begin
|
||||||
|
SetLength(VBuffer, LIdx);
|
||||||
|
end;
|
||||||
|
|
||||||
|
// construct header
|
||||||
|
HdrIp := TIdIpHdr.Create;
|
||||||
|
try
|
||||||
|
HdrIp.ip_verlen := (4 shl 4) + (Id_IP_HSIZE div 4); // IPv4 shl 4, 20 bytes div 4
|
||||||
|
HdrIp.ip_tos := ATos;
|
||||||
|
HdrIp.ip_len := GStack.HostToNetwork(UInt16(ALen + Id_IP_HSIZE));
|
||||||
|
HdrIp.ip_id := GStack.HostToNetwork(AnId);
|
||||||
|
HdrIp.ip_off := GStack.HostToNetwork(AFrag);
|
||||||
|
HdrIp.ip_ttl := ATtl;
|
||||||
|
HdrIp.ip_p := AProtocol;
|
||||||
|
HdrIp.ip_sum := 0; // do checksum later
|
||||||
|
HdrIp.ip_src.CopyFrom(ASource);
|
||||||
|
HdrIp.ip_dst.CopyFrom(ADest);
|
||||||
|
|
||||||
|
// copy header
|
||||||
|
LIdx := AIdx;
|
||||||
|
HdrIp.WriteStruct(VBuffer, LIdx);
|
||||||
|
|
||||||
|
// copy payload
|
||||||
|
if Length(APayload) > 0 then begin
|
||||||
|
CopyTIdBytes(APayload, 0, VBuffer, LIdx, Length(APayload));
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
FreeANdNil(HdrIp);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure IdRawBuildIcmpEcho(AType, ACode: UInt8; AnId, ASeq: UInt16;
|
||||||
|
const APayload: TIdBytes; var VBuffer: TIdBytes);
|
||||||
|
var
|
||||||
|
HdrIcmp: TIdIcmpHdr;
|
||||||
|
LIdx, LLen : UInt32;
|
||||||
|
begin
|
||||||
|
// check input
|
||||||
|
LIdx := Id_ICMP_ECHO_HSIZE + Length(APayload);
|
||||||
|
LLen := Length(VBuffer);
|
||||||
|
if LLen < LIdx then begin
|
||||||
|
SetLength(VBuffer, LIdx);
|
||||||
|
end;
|
||||||
|
|
||||||
|
// construct header
|
||||||
|
HdrIcmp := TIdIcmpHdr.Create;
|
||||||
|
try
|
||||||
|
HdrIcmp.icmp_type := AType;
|
||||||
|
HdrIcmp.icmp_code := ACode;
|
||||||
|
HdrIcmp.icmp_hun.echo_id := GStack.HostToNetwork(AnId);
|
||||||
|
HdrIcmp.icmp_hun.echo_seq := GStack.HostToNetwork(ASeq);
|
||||||
|
|
||||||
|
// copy payload
|
||||||
|
if Length(APayload) > 0 then begin
|
||||||
|
CopyTIdBytes(APayload, 0, VBuffer, Id_ICMP_ECHO_HSIZE, Length(APayload));
|
||||||
|
end;
|
||||||
|
|
||||||
|
// copy header
|
||||||
|
LIdx := 0;
|
||||||
|
HdrIcmp.WriteStruct(VBuffer, LIdx);
|
||||||
|
finally
|
||||||
|
FreeAndNil(HdrIcmp);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
type
|
||||||
|
TIdICMPMask = class(TIdICMPHdr)
|
||||||
|
protected
|
||||||
|
Ficmp_mask: UInt32;
|
||||||
|
function GetBytesLen: UInt32; override;
|
||||||
|
public
|
||||||
|
procedure ReadStruct(const ABytes : TIdBytes; var VIndex : UInt32); override;
|
||||||
|
procedure WriteStruct(var VBytes : TIdBytes; var VIndex : UInt32); override;
|
||||||
|
property icmp_mask: UInt32 read Ficmp_mask write Ficmp_mask;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdICMPMask.GetBytesLen: UInt32;
|
||||||
|
begin
|
||||||
|
Result := inherited GetBytesLen + 4;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdICMPMask.ReadStruct(const ABytes : TIdBytes; var VIndex : UInt32);
|
||||||
|
begin
|
||||||
|
inherited ReadStruct(ABytes, VIndex);
|
||||||
|
Ficmp_mask := BytesToUInt32(ABytes, VIndex);
|
||||||
|
Inc(VIndex, 4);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdICMPMask.WriteStruct(var VBytes : TIdBytes; var VIndex : UInt32);
|
||||||
|
begin
|
||||||
|
inherited WriteStruct(VBytes, VIndex);
|
||||||
|
CopyTIdUInt32(Ficmp_mask, VBytes, VIndex);
|
||||||
|
Inc(VIndex, 4);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure IdRawBuildIcmpMask(AType, ACode: UInt8; AnId, ASeq: UInt16; AMask: UInt32;
|
||||||
|
const APayload: TIdBytes; var VBuffer: TIdBytes);
|
||||||
|
var
|
||||||
|
HdrIcmp: TIdICMPMask;
|
||||||
|
LIdx: UInt32;
|
||||||
|
LLen : UInt32;
|
||||||
|
begin
|
||||||
|
// check input
|
||||||
|
LIdx := Id_ICMP_MASK_HSIZE + Length(APayload);
|
||||||
|
LLen := Length(VBuffer);
|
||||||
|
if LLen < LIdx then begin
|
||||||
|
SetLength(VBuffer, LIdx);
|
||||||
|
end;
|
||||||
|
|
||||||
|
// construct header
|
||||||
|
HdrIcmp := TIdICMPMask.Create;
|
||||||
|
try
|
||||||
|
HdrIcmp.icmp_type := AType;
|
||||||
|
HdrIcmp.icmp_code := ACode;
|
||||||
|
HdrIcmp.icmp_hun.echo_id := GStack.HostToNetwork(AnId);
|
||||||
|
HdrIcmp.icmp_hun.echo_seq := GStack.HostToNetwork(ASeq);
|
||||||
|
HdrIcmp.icmp_mask := GStack.HostToNetwork(AMask);
|
||||||
|
|
||||||
|
// copy header
|
||||||
|
LIdx := 0;
|
||||||
|
HdrIcmp.WriteStruct(VBuffer, LIdx);
|
||||||
|
|
||||||
|
// copy payload
|
||||||
|
if Length(APayload) > 0 then begin
|
||||||
|
CopyTIdBytes(APayload, 0, VBuffer, LIdx, Length(APayload));
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
FreeAndNil(HdrIcmp);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure IdRawBuildIcmpUnreach(AType, ACode: UInt8; AnOrigLen: UInt16;
|
||||||
|
AnOrigTos: UInt8; AnOrigId, AnOrigFrag: UInt16; AnOrigTtl, AnOrigProtocol: UInt8;
|
||||||
|
AnOrigSource, AnOrigDest: TIdInAddr; const AnOrigPayload, APayloadSize: Integer;
|
||||||
|
var VBuffer: TIdBytes);
|
||||||
|
var
|
||||||
|
HdrIcmp: TIdIcmpHdr;
|
||||||
|
LIdx: UInt32;
|
||||||
|
LLen : UInt32;
|
||||||
|
begin
|
||||||
|
// check input
|
||||||
|
LIdx := Id_ICMP_UNREACH_HSIZE + Id_IP_HSIZE + 2;
|
||||||
|
LLen := Length(VBuffer);
|
||||||
|
if LLen < LIdx then begin
|
||||||
|
SetLength(VBuffer, LIdx);
|
||||||
|
end;
|
||||||
|
|
||||||
|
// construct header
|
||||||
|
HdrIcmp := TIdIcmpHdr.Create;
|
||||||
|
try
|
||||||
|
HdrIcmp.icmp_type := AType;
|
||||||
|
HdrIcmp.icmp_code := ACode;
|
||||||
|
HdrIcmp.icmp_hun.echo_id := 0;
|
||||||
|
HdrIcmp.icmp_hun.echo_seq := 0;
|
||||||
|
|
||||||
|
// attach original header
|
||||||
|
IdRawBuildIp(0, AnOrigTos, AnOrigId, AnOrigFrag, AnOrigTtl, AnOrigProtocol,
|
||||||
|
AnOrigSource, AnOrigDest, ToBytes(AnOrigPayload), VBuffer, Id_ICMP_UNREACH_HSIZE);
|
||||||
|
|
||||||
|
// copy header
|
||||||
|
LIdx := 0;
|
||||||
|
HdrIcmp.WriteStruct(VBuffer, LIdx);
|
||||||
|
finally
|
||||||
|
FreeAndNil(HdrIcmp);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure IdRawBuildIcmpTimeExceed(const AType, ACode: UInt8; const AnOrigLen: UInt16;
|
||||||
|
const AnOrigTos: UInt8; const AnOrigId, AnOrigFrag: UInt16;
|
||||||
|
const AnOrigTtl, AnOrigProtocol: UInt8; const AnOrigSource, AnOrigDest: TIdInAddr;
|
||||||
|
const AnOrigPayload: TIdBytes; var VBuffer: TIdBytes);
|
||||||
|
var
|
||||||
|
HdrIcmp: TIdIcmpHdr;
|
||||||
|
LIdx: UInt32;
|
||||||
|
LLen : UInt32;
|
||||||
|
begin
|
||||||
|
// check input
|
||||||
|
LIdx := Id_ICMP_TIMEXCEED_HSIZE + Id_IP_HSIZE + Length(AnOrigPayload);
|
||||||
|
Llen := Length(VBuffer);
|
||||||
|
if Llen < LIdx then begin
|
||||||
|
SetLength(VBuffer, LIdx);
|
||||||
|
end;
|
||||||
|
|
||||||
|
// construct header
|
||||||
|
HdrIcmp := TIdIcmpHdr.Create;
|
||||||
|
try
|
||||||
|
HdrIcmp.icmp_type := AType;
|
||||||
|
HdrIcmp.icmp_code := ACode;
|
||||||
|
HdrIcmp.icmp_hun.echo_id := 0;
|
||||||
|
HdrIcmp.icmp_hun.echo_seq := 0;
|
||||||
|
|
||||||
|
// attach original header
|
||||||
|
IdRawBuildIp(0, AnOrigTos, AnOrigId, AnOrigFrag, AnOrigTtl, AnOrigProtocol,
|
||||||
|
AnOrigSource, AnOrigDest, AnOrigPayload, VBuffer, Id_ICMP_TIMEXCEED_HSIZE);
|
||||||
|
|
||||||
|
// copy header
|
||||||
|
LIdx := 0;
|
||||||
|
HdrIcmp.WriteStruct(VBuffer, LIdx);
|
||||||
|
finally
|
||||||
|
FreeAndNil(HdrIcmp);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
type
|
||||||
|
TIdIcmpTS = class(TIdIcmpHdr)
|
||||||
|
protected
|
||||||
|
Ficmp_dun: TIdicmp_dun;
|
||||||
|
function GetBytesLen: UInt32; override;
|
||||||
|
public
|
||||||
|
constructor Create; override;
|
||||||
|
destructor Destroy; override;
|
||||||
|
procedure ReadStruct(const ABytes : TIdBytes; var VIndex : UInt32); override;
|
||||||
|
procedure WriteStruct(var VBytes : TIdBytes; var VIndex : UInt32); override;
|
||||||
|
property icmp_dun: TIdicmp_dun read Ficmp_dun;
|
||||||
|
end;
|
||||||
|
|
||||||
|
constructor TIdIcmpTS.Create;
|
||||||
|
begin
|
||||||
|
inherited Create;
|
||||||
|
Ficmp_dun := TIdicmp_dun.Create;
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TIdIcmpTS.Destroy;
|
||||||
|
begin
|
||||||
|
Ficmp_dun.Free;
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdIcmpTS.GetBytesLen: UInt32;
|
||||||
|
begin
|
||||||
|
Result := inherited GetBytesLen + Ficmp_dun.BytesLen;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIcmpTS.ReadStruct(const ABytes : TIdBytes; var VIndex : UInt32);
|
||||||
|
begin
|
||||||
|
inherited ReadStruct(ABytes, VIndex);
|
||||||
|
Ficmp_dun.ReadStruct(ABytes, VIndex);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdIcmpTS.WriteStruct(var VBytes : TIdBytes; var VIndex : UInt32);
|
||||||
|
begin
|
||||||
|
inherited WriteStruct(VBytes, VIndex);
|
||||||
|
Ficmp_dun.WriteStruct(VBytes, VIndex);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure IdRawBuildIcmpTimestamp(const AType, ACode: UInt8; const AnId, ASeq: UInt16;
|
||||||
|
const AnOtime, AnRtime, ATtime: TIdNetTime; const APayload: TIdBytes;
|
||||||
|
var VBuffer: TIdBytes);
|
||||||
|
var
|
||||||
|
HdrIcmp: TIdIcmpTS;
|
||||||
|
LIdx, LLen : UInt32;
|
||||||
|
begin
|
||||||
|
// check input
|
||||||
|
LIdx := Id_ICMP_TS_HSIZE + Length(APayload);
|
||||||
|
LLen := Length(VBuffer);
|
||||||
|
if LLen < LIdx then begin
|
||||||
|
SetLength(VBuffer, LIdx);
|
||||||
|
end;
|
||||||
|
|
||||||
|
// construct header
|
||||||
|
HdrIcmp := TIdIcmpTS.Create;
|
||||||
|
try
|
||||||
|
HdrIcmp.icmp_type := AType;
|
||||||
|
HdrIcmp.icmp_code := ACode;
|
||||||
|
HdrIcmp.icmp_hun.echo_id := GStack.HostToNetwork(AnId);
|
||||||
|
HdrIcmp.icmp_hun.echo_seq := GStack.HostToNetwork(ASeq);
|
||||||
|
HdrIcmp.icmp_dun.ts_otime := GStack.HostToNetwork(AnOtime); // original timestamp
|
||||||
|
HdrIcmp.icmp_dun.ts_rtime := GStack.HostToNetwork(AnRtime); // receive timestamp
|
||||||
|
HdrIcmp.icmp_dun.ts_ttime := GStack.HostToNetwork(ATtime); // transmit timestamp
|
||||||
|
|
||||||
|
// copy header
|
||||||
|
LIdx := 0;
|
||||||
|
HdrIcmp.WriteStruct(VBuffer, LIdx);
|
||||||
|
|
||||||
|
// copy payload
|
||||||
|
if Length(APayload) > 0 then begin
|
||||||
|
CopyTIdBytes(APayload, 0, VBuffer, LIdx, Length(APayload));
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
FreeAndNil(HdrIcmp);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure IdRawBuildIcmpRedirect(const AType, ACode: UInt8; AGateway: TIdInAddr;
|
||||||
|
const AnOrigLen: UInt16; const AnOrigTos: UInt8; const AnOrigId, AnOrigFrag: UInt16;
|
||||||
|
const AnOrigTtl, AnOrigProtocol: UInt8; AnOrigSource, AnOrigDest: TIdInAddr;
|
||||||
|
const AnOrigPayload: TIdBytes; var VBuffer: TIdBytes);
|
||||||
|
var
|
||||||
|
HdrIcmp: TIdIcmpHdr;
|
||||||
|
LIdx, LLen : UInt32;
|
||||||
|
begin
|
||||||
|
// check input
|
||||||
|
LIdx := Id_ICMP_REDIRECT_HSIZE + Id_IP_HSIZE + Length(AnOrigPayload);
|
||||||
|
LLen := Length(VBuffer);
|
||||||
|
if LLen < LIdx then begin
|
||||||
|
SetLength(VBuffer, LIdx);
|
||||||
|
end;
|
||||||
|
|
||||||
|
// construct header
|
||||||
|
HdrIcmp := TIdIcmpHdr.Create;
|
||||||
|
try
|
||||||
|
HdrIcmp.icmp_type := AType;
|
||||||
|
HdrIcmp.icmp_code := ACode;
|
||||||
|
HdrIcmp.icmp_hun.gateway_s_b1 := AGateway.s_l; // gateway address
|
||||||
|
|
||||||
|
// attach original header
|
||||||
|
IdRawBuildIp(0, AnOrigTos, AnOrigId, AnOrigFrag, AnOrigTtl, AnOrigProtocol,
|
||||||
|
AnOrigSource, AnOrigDest, AnOrigPayload, VBuffer, Id_ICMP_REDIRECT_HSIZE);
|
||||||
|
|
||||||
|
// copy header
|
||||||
|
LIdx := 0;
|
||||||
|
HdrIcmp.WriteStruct(VBuffer, LIdx);
|
||||||
|
finally
|
||||||
|
FreeAndNil(HdrIcmp);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure IdRawBuildIgmp(AType, ACode: UInt8; AnIp: TIdInAddr;
|
||||||
|
const APayload: UInt16; var VBuffer: TIdBytes);
|
||||||
|
var
|
||||||
|
HdrIgmp: TIdIgmpHdr;
|
||||||
|
LIdx: UInt32;
|
||||||
|
LLen : UInt32;
|
||||||
|
begin
|
||||||
|
// check input
|
||||||
|
LIdx := 2 + Id_IGMP_HSIZE;
|
||||||
|
LLen := Length(VBuffer);
|
||||||
|
if LLen < LIdx then begin
|
||||||
|
SetLength(VBuffer, LIdx);
|
||||||
|
end;
|
||||||
|
|
||||||
|
// construct header
|
||||||
|
HdrIgmp := TIdIgmpHdr.Create;
|
||||||
|
try
|
||||||
|
HdrIgmp.igmp_type := AType;
|
||||||
|
HdrIgmp.igmp_code := ACode;
|
||||||
|
HdrIgmp.igmp_sum := 0;
|
||||||
|
HdrIgmp.igmp_group.s_l := AnIp.s_l; // group address or 0
|
||||||
|
|
||||||
|
// copy payload
|
||||||
|
CopyTIdUInt16(APayload, VBuffer, Id_IGMP_HSIZE);
|
||||||
|
|
||||||
|
// copy header
|
||||||
|
LIdx := 0;
|
||||||
|
HdrIgmp.WriteStruct(VBuffer, LIdx);
|
||||||
|
finally
|
||||||
|
FreeAndNil(HdrIgmp);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure IdRawBuildRip(const ACommand, AVersion: UInt8;
|
||||||
|
const ARoutingDomain, AnAddressFamily, ARoutingTag: UInt16;
|
||||||
|
const AnAddr, AMask, ANextHop, AMetric: UInt32;
|
||||||
|
const APayload: TIdBytes; var VBuffer: TIdBytes);
|
||||||
|
var
|
||||||
|
HdrRip: TIdRipHdr;
|
||||||
|
LIdx: UInt32;
|
||||||
|
LLen : UInt32;
|
||||||
|
begin
|
||||||
|
// check input
|
||||||
|
LIdx := Id_RIP_HSIZE + Length(APayload);
|
||||||
|
LLen := Length(VBuffer);
|
||||||
|
if LLen < LIdx then begin
|
||||||
|
SetLength(VBuffer, LIdx);
|
||||||
|
end;
|
||||||
|
|
||||||
|
// construct header
|
||||||
|
HdrRip := TIdRipHdr.Create;
|
||||||
|
try
|
||||||
|
HdrRip.rip_cmd := ACommand;
|
||||||
|
HdrRip.rip_ver := AVersion;
|
||||||
|
HdrRip.rip_rd := GStack.HostToNetwork(ARoutingDomain);
|
||||||
|
HdrRip.rip_af := GStack.HostToNetwork(AnAddressFamily);
|
||||||
|
HdrRip.rip_rt := GStack.HostToNetwork(ARoutingTag);
|
||||||
|
HdrRip.rip_addr := GStack.HostToNetwork(AnAddr);
|
||||||
|
HdrRip.rip_mask := GStack.HostToNetwork(AMask);
|
||||||
|
HdrRip.rip_next_hop := GStack.HostToNetwork(ANextHop);
|
||||||
|
HdrRip.rip_metric := GStack.HostToNetwork(AMetric);
|
||||||
|
|
||||||
|
// copy payload
|
||||||
|
if Length(APayload) > 0 then begin
|
||||||
|
CopyTIdBytes(APayload, 0, VBuffer, Id_RIP_HSIZE, Length(APayload));
|
||||||
|
end;
|
||||||
|
|
||||||
|
// copy header
|
||||||
|
LIdx := 0;
|
||||||
|
HdrRip.WriteStruct(VBuffer, LIdx);
|
||||||
|
finally
|
||||||
|
FreeAndNil(HdrRip);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
// TODO: check nibbles in TCP header
|
||||||
|
procedure IdRawBuildTcp(const ASourcePort, ADestPort: UInt16;
|
||||||
|
const ASeq, AnAck: UInt32; const AControl: UInt8;
|
||||||
|
const AWindowSize, AnUrgent: UInt16; const APayload: TIdBytes;
|
||||||
|
var VBuffer: TIdBytes);
|
||||||
|
var
|
||||||
|
HdrTcp: TIdTcpHdr;
|
||||||
|
LIdx, LLen: UInt32;
|
||||||
|
begin
|
||||||
|
// check input
|
||||||
|
LIdx := Id_TCP_HSIZE + Length(VBuffer);
|
||||||
|
LLen := Length(VBuffer);
|
||||||
|
if LLen < LIdx then begin
|
||||||
|
SetLength(VBuffer, LIdx);
|
||||||
|
end;
|
||||||
|
|
||||||
|
// construct header
|
||||||
|
HdrTcp := TIdTcpHdr.Create;
|
||||||
|
try
|
||||||
|
HdrTcp.tcp_sport := GStack.HostToNetwork(ASourcePort);
|
||||||
|
HdrTcp.tcp_dport := GStack.HostToNetwork(ADestPort);
|
||||||
|
HdrTcp.tcp_seq := GStack.HostToNetwork(ASeq);
|
||||||
|
HdrTcp.tcp_ack := GStack.HostToNetwork(AnAck); // acknowledgement number
|
||||||
|
HdrTcp.tcp_flags := AControl; // control flags
|
||||||
|
HdrTcp.tcp_x2off := ((Id_TCP_HSIZE div 4) shl 4) + 0; // 20 bytes div 4, x2 unused
|
||||||
|
HdrTcp.tcp_win := GStack.HostToNetwork(AWindowSize); // window size
|
||||||
|
HdrTcp.tcp_sum := 0;
|
||||||
|
HdrTcp.tcp_urp := AnUrgent; // urgent pointer
|
||||||
|
|
||||||
|
// copy payload
|
||||||
|
if Length(APayload) > 0 then begin
|
||||||
|
CopyTIdBytes(APayload, 0, VBuffer, Id_TCP_HSIZE, Length(APayload));
|
||||||
|
end;
|
||||||
|
|
||||||
|
// copy header
|
||||||
|
LIdx := 0;
|
||||||
|
HdrTcp.WriteStruct(VBuffer, LIdx);
|
||||||
|
finally
|
||||||
|
FreeAndNil(HdrTcp);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure IdRawBuildUdp(const ASourcePort, ADestPort: UInt16;
|
||||||
|
const APayload: TIdBytes; var VBuffer: TIdBytes);
|
||||||
|
var
|
||||||
|
HdrUdp: TIdUdpHdr;
|
||||||
|
LIdx: UInt32;
|
||||||
|
LLen : UInt32;
|
||||||
|
begin
|
||||||
|
// check input
|
||||||
|
LIdx := Id_UDP_HSIZE + Length(APayload);
|
||||||
|
LLen := Length(VBuffer);
|
||||||
|
if LLen < Lidx then begin
|
||||||
|
SetLength(VBuffer, LIdx);
|
||||||
|
end;
|
||||||
|
|
||||||
|
// construct header
|
||||||
|
HdrUdp := TIdUdpHdr.Create;
|
||||||
|
try
|
||||||
|
HdrUdp.udp_dport := GStack.HostToNetwork(ASourcePort);
|
||||||
|
HdrUdp.udp_dport := GStack.HostToNetwork(ADestPort);
|
||||||
|
//LIdx should be okay here since we set that to the packet length earlier
|
||||||
|
HdrUdp.udp_ulen := GStack.HostToNetwork(LIdx);
|
||||||
|
HdrUdp.udp_sum := 0;
|
||||||
|
|
||||||
|
// copy payload
|
||||||
|
if Length(APayload) > 0 then begin
|
||||||
|
CopyTIdBytes(APayload, 0, VBuffer, Id_UDP_HSIZE, Length(APayload));
|
||||||
|
end;
|
||||||
|
|
||||||
|
// copy header
|
||||||
|
LIdx := 0;
|
||||||
|
HdrUdp.WriteStruct(VBuffer, LIdx);
|
||||||
|
finally
|
||||||
|
FreeAndNil(HdrUdp);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
|
@ -0,0 +1,675 @@
|
||||||
|
LazarusResources.Add('TIdTCPClient','XPM',[
|
||||||
|
'/* XPM */'#13#10'static char *Pixmap[] = {'#13#10'"24 24 16 2",'#13#10'"00 c'
|
||||||
|
+' black",'#13#10'"01 c #800000",'#13#10'"02 c #008000",'#13#10'"03 c #808000'
|
||||||
|
+'",'#13#10'"04 c #000080",'#13#10'"05 c none",'#13#10'"06 c #008080",'#13#10
|
||||||
|
+'"07 c #C0C0C0",'#13#10'"08 c #808080",'#13#10'"09 c red",'#13#10'"10 c gree'
|
||||||
|
+'n",'#13#10'"11 c yellow",'#13#10'"12 c blue",'#13#10'"13 c magenta",'#13#10
|
||||||
|
+'"14 c cyan",'#13#10'"15 c Gray100",'#13#10'"0505050505050505050505050505050'
|
||||||
|
+'50505050505050505",'#13#10'"05050404040404040404040404040404040404040404040'
|
||||||
|
+'5",'#13#10'"050415151515151515151515151515151515151515150404",'#13#10'"0504'
|
||||||
|
+'03030303030303030303030303030315151515150404",'#13#10'"05041111111111111111'
|
||||||
|
+'1111111111110315151515150404",'#13#10'"050411111111111111111111111111031515'
|
||||||
|
+'151515150404",'#13#10'"050403030303030303030311111103151515151515150404",'
|
||||||
|
+#13#10'"050415151515151515031111110303030303030303030404",'#13#10'"050415151'
|
||||||
|
+'515151503111111111111111111111111110404",'#13#10'"0504151515151503111111111'
|
||||||
|
+'11111111111111111110404",'#13#10'"05041515151515030303030303030303030303030'
|
||||||
|
+'3030404",'#13#10'"050415151515151515151515151515151515151515150404",'#13#10
|
||||||
|
+'"050415151515151515151515151515151515151515150404",'#13#10'"050415000000000'
|
||||||
|
+'000150000000000150000000000150404",'#13#10'"0504151515000015151500001515151'
|
||||||
|
+'50000150000150404",'#13#10'"05041515150000151515000015151515000015000015040'
|
||||||
|
+'4",'#13#10'"050415151500001515150000151515150000000000150404",'#13#10'"0504'
|
||||||
|
+'15151500001515150000151515150000151515150404",'#13#10'"05041515150000151515'
|
||||||
|
+'0000151515150000151515150404",'#13#10'"050415151500001515150000000000150000'
|
||||||
|
+'151515150404",'#13#10'"050415151515151515151515151515151515151515150404",'
|
||||||
|
+#13#10'"050415151515151515151515151515151515151515150404",'#13#10'"050404040'
|
||||||
|
+'404040404040404040404040404040404040404",'#13#10'"0505040404040404040404040'
|
||||||
|
+'40404040404040404040405"'#13#10'};'#13#10
|
||||||
|
]);
|
||||||
|
LazarusResources.Add('TIdUDPClient','XPM',[
|
||||||
|
'/* XPM */'#13#10'static char *Pixmap[] = {'#13#10'"24 24 16 2",'#13#10'"00 c'
|
||||||
|
+' black",'#13#10'"01 c #800000",'#13#10'"02 c #008000",'#13#10'"03 c none",'
|
||||||
|
+#13#10'"04 c #000080",'#13#10'"05 c #800080",'#13#10'"06 c #008080",'#13#10
|
||||||
|
+'"07 c #C0C0C0",'#13#10'"08 c #808080",'#13#10'"09 c red",'#13#10'"10 c gree'
|
||||||
|
+'n",'#13#10'"11 c yellow",'#13#10'"12 c blue",'#13#10'"13 c magenta",'#13#10
|
||||||
|
+'"14 c cyan",'#13#10'"15 c Gray100",'#13#10'"0303030303030303030303030303030'
|
||||||
|
+'30303030303030303",'#13#10'"03030404040404040404040404040404040404040404040'
|
||||||
|
+'3",'#13#10'"030415151515151515151515151515151515151515150404",'#13#10'"0304'
|
||||||
|
+'08080808080808080808080808080815151515150404",'#13#10'"03040707070707070707'
|
||||||
|
+'0707070707070815151515150404",'#13#10'"030407070707070707070707070707081515'
|
||||||
|
+'151515150404",'#13#10'"030408080808080808080807070708151515151515150404",'
|
||||||
|
+#13#10'"030415151515151515080707070808080808080808080404",'#13#10'"030415151'
|
||||||
|
+'515151508070707070707070707070707070404",'#13#10'"0304151515151508070707070'
|
||||||
|
+'70707070707070707070404",'#13#10'"03041515151515080808080808080808080808080'
|
||||||
|
+'8080404",'#13#10'"030415151515151515151515151515151515151515150404",'#13#10
|
||||||
|
+'"030415151515151515151515151515151515151515150404",'#13#10'"030415000015150'
|
||||||
|
+'000150000000015150000000000150404",'#13#10'"0304150000151500001500001500001'
|
||||||
|
+'50000150000150404",'#13#10'"03041500001515000015000015000015000015000015040'
|
||||||
|
+'4",'#13#10'"030415000015150000150000150000150000000000150404",'#13#10'"0304'
|
||||||
|
+'15000015150000150000150000150000151515150404",'#13#10'"03041500001515000015'
|
||||||
|
+'0000150000150000151515150404",'#13#10'"030415150000000015150000000015150000'
|
||||||
|
+'151515150404",'#13#10'"030415151515151515151515151515151515151515150404",'
|
||||||
|
+#13#10'"030415151515151515151515151515151515151515150404",'#13#10'"030404040'
|
||||||
|
+'404040404040404040404040404040404040404",'#13#10'"0303040404040404040404040'
|
||||||
|
+'40404040404040404040403"'#13#10'};'#13#10
|
||||||
|
]);
|
||||||
|
LazarusResources.Add('TIdCmdTCPClient','XPM',[
|
||||||
|
'/* XPM */'#13#10'static char *Pixmap[] = {'#13#10'"24 24 16 2",'#13#10'"00 c'
|
||||||
|
+' black",'#13#10'"01 c #800000",'#13#10'"02 c #008000",'#13#10'"03 c none",'
|
||||||
|
+#13#10'"04 c #000080",'#13#10'"05 c #800080",'#13#10'"06 c #008080",'#13#10
|
||||||
|
+'"07 c #808080",'#13#10'"08 c #C0C0C0",'#13#10'"09 c red",'#13#10'"10 c gree'
|
||||||
|
+'n",'#13#10'"11 c yellow",'#13#10'"12 c blue",'#13#10'"13 c magenta",'#13#10
|
||||||
|
+'"14 c cyan",'#13#10'"15 c Gray100",'#13#10'"0303030303030303030303030303030'
|
||||||
|
+'30303030303030303",'#13#10'"03030404040404040404040404040404040404040404040'
|
||||||
|
+'3",'#13#10'"030415151515151515151515151515151515151515150404",'#13#10'"0304'
|
||||||
|
+'15151515151515151515151515151515151515150404",'#13#10'"03041515151515151515'
|
||||||
|
+'1515151515151515151515150404",'#13#10'"030415151515151515151515151515151515'
|
||||||
|
+'151515150404",'#13#10'"030415151515151515151515151515151515151515150404",'
|
||||||
|
+#13#10'"030415070000000015000008150800000000000007150404",'#13#10'"030400000'
|
||||||
|
+'815080015150007150700151500000800000404",'#13#10'"0304000015151515151500001'
|
||||||
|
+'50000151500001500000404",'#13#10'"03040000151515151515000707070015150000150'
|
||||||
|
+'0000404",'#13#10'"030400001515151515150008000800151500001500000404",'#13#10
|
||||||
|
+'"030400000815080015150015071500151500000800000404",'#13#10'"030415070000000'
|
||||||
|
+'815000000150000000000000007150404",'#13#10'"0304151515151515151515151515151'
|
||||||
|
+'51515151515150404",'#13#10'"03041515151515151515151515151515151515151515040'
|
||||||
|
+'4",'#13#10'"030415151515151515151515151515151515151515150404",'#13#10'"0304'
|
||||||
|
+'15151515151515151515151515151515151515150404",'#13#10'"03041515151515151515'
|
||||||
|
+'1515151515151515151515150404",'#13#10'"030415151515151515151515151515151515'
|
||||||
|
+'151515150404",'#13#10'"030415151515151515151515151515151515151515150404",'
|
||||||
|
+#13#10'"030415151515151515151515151515151515151515150404",'#13#10'"030404040'
|
||||||
|
+'404040404040404040404040404040404040404",'#13#10'"0303040404040404040404040'
|
||||||
|
+'40404040404040404040403"'#13#10'};'#13#10
|
||||||
|
]);
|
||||||
|
LazarusResources.Add('TIdIPMCastClient','XPM',[
|
||||||
|
'/* XPM */'#13#10'static char *Pixmap[] = {'#13#10'"24 24 16 2",'#13#10'"00 c'
|
||||||
|
+' black",'#13#10'"01 c #800000",'#13#10'"02 c #008000",'#13#10'"03 c #808000'
|
||||||
|
+'",'#13#10'"04 c #000080",'#13#10'"05 c none",'#13#10'"06 c #008080",'#13#10
|
||||||
|
+'"07 c #C0C0C0",'#13#10'"08 c #808080",'#13#10'"09 c red",'#13#10'"10 c gree'
|
||||||
|
+'n",'#13#10'"11 c yellow",'#13#10'"12 c blue",'#13#10'"13 c magenta",'#13#10
|
||||||
|
+'"14 c cyan",'#13#10'"15 c Gray100",'#13#10'"0505050505050505050505050505050'
|
||||||
|
+'50505050505050505",'#13#10'"05050404040404040404040404040404040404040404040'
|
||||||
|
+'5",'#13#10'"050415151515151515080808080808151515151515150404",'#13#10'"0504'
|
||||||
|
+'15151515150808150708070707080715151515150404",'#13#10'"05041515151507070708'
|
||||||
|
+'0707070708070707151515150404",'#13#10'"050415151515080707070708080815080708'
|
||||||
|
+'151515150404",'#13#10'"050415151508150815080715070707150815081515150404",'
|
||||||
|
+#13#10'"050415151508070708150708080707080707081515150404",'#13#10'"050415151'
|
||||||
|
+'508080708070807070707080707081515150404",'#13#10'"0504151515080815080707080'
|
||||||
|
+'70815080708081515150404",'#13#10'"05041515150807070815070808150708070708151'
|
||||||
|
+'5150404",'#13#10'"050415151508150807081500001508150815081515150404",'#13#10
|
||||||
|
+'"050415151507070707150800000715070708071515150404",'#13#10'"050415151515080'
|
||||||
|
+'708070800000708081508151515150404",'#13#10'"0504151515151508071500000008150'
|
||||||
|
+'70815151515150404",'#13#10'"05041515151515151507000808001507151515151515040'
|
||||||
|
+'4",'#13#10'"050415151515151515080000000015151515151515150404",'#13#10'"0504'
|
||||||
|
+'15151515151515000008070007151515151515150404",'#13#10'"05041515151515150700'
|
||||||
|
+'0700080008151515151515150404",'#13#10'"050415151515151507000800080008151515'
|
||||||
|
+'151515150404",'#13#10'"050415151515151508000808150000071515151515150404",'
|
||||||
|
+#13#10'"050415151515151500080800080800071515151515150404",'#13#10'"050404040'
|
||||||
|
+'404040700070800001500080404040404040404",'#13#10'"0505040404040407000808080'
|
||||||
|
+'70008080404040404040405"'#13#10'};'#13#10
|
||||||
|
]);
|
||||||
|
LazarusResources.Add('TIdIOHandlerStack','XPM',[
|
||||||
|
'/* XPM */'#13#10'static char *Pixmap[] = {'#13#10'"24 24 16 2",'#13#10'"00 c'
|
||||||
|
+' black",'#13#10'"01 c #800000",'#13#10'"02 c #008000",'#13#10'"03 c #808000'
|
||||||
|
+'",'#13#10'"04 c #000080",'#13#10'"05 c none",'#13#10'"06 c #008080",'#13#10
|
||||||
|
+'"07 c #C0C0C0",'#13#10'"08 c #808080",'#13#10'"09 c red",'#13#10'"10 c gree'
|
||||||
|
+'n",'#13#10'"11 c yellow",'#13#10'"12 c blue",'#13#10'"13 c magenta",'#13#10
|
||||||
|
+'"14 c cyan",'#13#10'"15 c Gray100",'#13#10'"0505050505050505050505050505050'
|
||||||
|
+'50505050505050505",'#13#10'"05050008000004040004040004040000070404040404040'
|
||||||
|
+'5",'#13#10'"050408080708121212121212121212040815151515150704",'#13#10'"0504'
|
||||||
|
+'08080700120412041204120412040815151515150404",'#13#10'"05040007080808080808'
|
||||||
|
+'0808080808030815151515150404",'#13#10'"050408151515151515151515151515080815'
|
||||||
|
+'151515150704",'#13#10'"050408151507070707070708151515080815151515150404",'
|
||||||
|
+#13#10'"050408150707070708070708081515080815151515150404",'#13#10'"050408070'
|
||||||
|
+'707070800080707080815080815151515150704",'#13#10'"0504081507070708080807070'
|
||||||
|
+'80815080815151515150404",'#13#10'"05040807070708080707000708081508081515151'
|
||||||
|
+'5150704",'#13#10'"050408150707080807080807030807080815151515150404",'#13#10
|
||||||
|
+'"050408150707080807080808080707000807151515150704",'#13#10'"050408071508080'
|
||||||
|
+'807080808081515070008070715150404",'#13#10'"0504081515150800080008080407150'
|
||||||
|
+'80808150807150404",'#13#10'"05040815151515151515151508000708070707070708040'
|
||||||
|
+'4",'#13#10'"050408070707070707070707070800070707070707080704",'#13#10'"0504'
|
||||||
|
+'08000800080008000803040308070707070707080804",'#13#10'"05041515151507151515'
|
||||||
|
+'0715070808080707070707080704",'#13#10'"050415151515151515151515150708080707'
|
||||||
|
+'070707000704",'#13#10'"050415151515151515151515151508080808080807080704",'
|
||||||
|
+#13#10'"050415151515151515151515151515080800080008070804",'#13#10'"050404040'
|
||||||
|
+'404040404040404040404040707070708070704",'#13#10'"0505040404040404040404040'
|
||||||
|
+'40404040404040404040405"'#13#10'};'#13#10
|
||||||
|
]);
|
||||||
|
LazarusResources.Add('TIdIOHandlerStream','XPM',[
|
||||||
|
'/* XPM */'#13#10'static char *Pixmap[] = {'#13#10'"24 24 16 2",'#13#10'"00 c'
|
||||||
|
+' black",'#13#10'"01 c #800000",'#13#10'"02 c #008000",'#13#10'"03 c #808000'
|
||||||
|
+'",'#13#10'"04 c #000080",'#13#10'"05 c none",'#13#10'"06 c #008080",'#13#10
|
||||||
|
+'"07 c #C0C0C0",'#13#10'"08 c #808080",'#13#10'"09 c red",'#13#10'"10 c gree'
|
||||||
|
+'n",'#13#10'"11 c yellow",'#13#10'"12 c blue",'#13#10'"13 c magenta",'#13#10
|
||||||
|
+'"14 c cyan",'#13#10'"15 c Gray100",'#13#10'"0505050505050505050505000000050'
|
||||||
|
+'50505050505050505",'#13#10'"05050404040404040404040008040404040404040404040'
|
||||||
|
+'5",'#13#10'"050415151515151515150306061515151515151515150404",'#13#10'"0504'
|
||||||
|
+'15151515151515151506060615151515151515150404",'#13#10'"05041515151515151515'
|
||||||
|
+'1500061206151515151515150404",'#13#10'"050415151515150715151504060606081515'
|
||||||
|
+'151515150404",'#13#10'"050415151515150800150006040604071515151515150404",'
|
||||||
|
+#13#10'"050415151515151508000604060600151515151515150404",'#13#10'"050415151'
|
||||||
|
+'515150006060606040015151515151515150404",'#13#10'"0504151515150406061206060'
|
||||||
|
+'60015151515151515150404",'#13#10'"05041515150006060606061206081515151515151'
|
||||||
|
+'5150404",'#13#10'"050415151506060406120606060300151515151515150404",'#13#10
|
||||||
|
+'"050415150004060406060606120015151515151515150404",'#13#10'"050415150603060'
|
||||||
|
+'400061207070015001508151515150404",'#13#10'"0504151506080606060604060600031'
|
||||||
|
+'50002031515150404",'#13#10'"05041515000604061206060606060608000015151515040'
|
||||||
|
+'4",'#13#10'"050415150006060406060604061206060000151515150404",'#13#10'"0504'
|
||||||
|
+'15151504060806060606060606060606000815150404",'#13#10'"05041515150006080006'
|
||||||
|
+'0406040006040612060615150404",'#13#10'"050415151515060002060408060604000606'
|
||||||
|
+'060615150404",'#13#10'"050415151515030606020006060604000604040615150404",'
|
||||||
|
+#13#10'"050415151515150302000008040606061206061515150404",'#13#10'"050404040'
|
||||||
|
+'404040404000606060604040608040404040404",'#13#10'"0505040404040404040404040'
|
||||||
|
+'40404040404040404040405"'#13#10'};'#13#10
|
||||||
|
]);
|
||||||
|
LazarusResources.Add('TIdServerIOHandlerStack','XPM',[
|
||||||
|
'/* XPM */'#13#10'static char *Pixmap[] = {'#13#10'"24 24 16 2",'#13#10'"00 c'
|
||||||
|
+' black",'#13#10'"01 c #800000",'#13#10'"02 c #008000",'#13#10'"03 c #808000'
|
||||||
|
+'",'#13#10'"04 c #000080",'#13#10'"05 c none",'#13#10'"06 c #008080",'#13#10
|
||||||
|
+'"07 c #C0C0C0",'#13#10'"08 c #808080",'#13#10'"09 c red",'#13#10'"10 c gree'
|
||||||
|
+'n",'#13#10'"11 c yellow",'#13#10'"12 c blue",'#13#10'"13 c magenta",'#13#10
|
||||||
|
+'"14 c cyan",'#13#10'"15 c Gray100",'#13#10'"0505000000000000000505050505050'
|
||||||
|
+'50505050505050505",'#13#10'"05050015151515150004040004040000070404040404040'
|
||||||
|
+'5",'#13#10'"050400151414141500121212121212040815151515150704",'#13#10'"0504'
|
||||||
|
+'00151414141500041204120412040815151515150404",'#13#10'"05040015080808080008'
|
||||||
|
+'0808080808030815151515150404",'#13#10'"050400000000000000151515151515080815'
|
||||||
|
+'151515150704",'#13#10'"000000151507070700000008151515080815151515150404",'
|
||||||
|
+#13#10'"001515070707070707080008081515080815151515150404",'#13#10'"001508080'
|
||||||
|
+'808080808080007080815080815151515150704",'#13#10'"0000000000000000000000070'
|
||||||
|
+'80815080815151515150404",'#13#10'"05040807070708080707000708081508081515151'
|
||||||
|
+'5150704",'#13#10'"050408150707080807080807030807080815151515150404",'#13#10
|
||||||
|
+'"050408150707080807080808080707000807151515150704",'#13#10'"050408071508080'
|
||||||
|
+'807080808081515070008070715150404",'#13#10'"0504081515150800080008080407150'
|
||||||
|
+'80808150807150404",'#13#10'"05040815151515151515151508000708070707070708040'
|
||||||
|
+'4",'#13#10'"050408070707070707070707070800070707070707080704",'#13#10'"0504'
|
||||||
|
+'08000800080008000803040308070707070707080804",'#13#10'"05041515151507151515'
|
||||||
|
+'0715070808080707070707080704",'#13#10'"050415151515151515151515150708080707'
|
||||||
|
+'070707000704",'#13#10'"050415151515151515151515151508080808080807080704",'
|
||||||
|
+#13#10'"050415151515151515151515151515080800080008070804",'#13#10'"050404040'
|
||||||
|
+'404040404040404040404040707070708070704",'#13#10'"0505040404040404040404040'
|
||||||
|
+'40404040404040404040405"'#13#10'};'#13#10
|
||||||
|
]);
|
||||||
|
LazarusResources.Add('TIdConnectionIntercept','XPM',[
|
||||||
|
'/* XPM */'#13#10'static char *Pixmap[] = {'#13#10'"24 24 16 2",'#13#10'"00 c'
|
||||||
|
+' black",'#13#10'"01 c #800000",'#13#10'"02 c #008000",'#13#10'"03 c #808000'
|
||||||
|
+'",'#13#10'"04 c #000080",'#13#10'"05 c none",'#13#10'"06 c #008080",'#13#10
|
||||||
|
+'"07 c #C0C0C0",'#13#10'"08 c #808080",'#13#10'"09 c red",'#13#10'"10 c gree'
|
||||||
|
+'n",'#13#10'"11 c yellow",'#13#10'"12 c blue",'#13#10'"13 c magenta",'#13#10
|
||||||
|
+'"14 c cyan",'#13#10'"15 c Gray100",'#13#10'"0505050505050505050505050505050'
|
||||||
|
+'50505050505050505",'#13#10'"05050404040404040404040404040404040404040404040'
|
||||||
|
+'5",'#13#10'"050415151515151515151515151515151515151515150404",'#13#10'"0504'
|
||||||
|
+'15151515150215151515151515151515151515150404",'#13#10'"05040303030302020303'
|
||||||
|
+'0303030303030303030303030404",'#13#10'"050415151502020215151515151515151515'
|
||||||
|
+'151515150404",'#13#10'"050415150202020202020202020202151515151515150404",'
|
||||||
|
+#13#10'"050415150202020202020202020202021515151515150404",'#13#10'"050415151'
|
||||||
|
+'502020215151515151515020215151515150404",'#13#10'"0504151515150202151515151'
|
||||||
|
+'51515150202151515150404",'#13#10'"05041515151515021515151515151515150202151'
|
||||||
|
+'5150404",'#13#10'"050415151515151515151509090909090909090909150404",'#13#10
|
||||||
|
+'"050415151515151515151509090909090909090909150404",'#13#10'"050415150215151'
|
||||||
|
+'515151515151515151502021515150404",'#13#10'"0504151502021515151515151515151'
|
||||||
|
+'50202151515150404",'#13#10'"05041515020202151515151515151502021515151515040'
|
||||||
|
+'4",'#13#10'"050415150202020202020202020202021515151515150404",'#13#10'"0504'
|
||||||
|
+'15150202020202020202020202151515151515150404",'#13#10'"05041515020202151515'
|
||||||
|
+'1515151515151515151515150404",'#13#10'"050415150202151515151515151515151515'
|
||||||
|
+'151515150404",'#13#10'"050415150215151515151515151515151515151515150404",'
|
||||||
|
+#13#10'"050415151515151515151515151515151515151515150404",'#13#10'"050404040'
|
||||||
|
+'404040404040404040404040404040404040404",'#13#10'"0505040404040404040404040'
|
||||||
|
+'40404040404040404040405"'#13#10'};'#13#10
|
||||||
|
]);
|
||||||
|
LazarusResources.Add('TIdInterceptSimLog','XPM',[
|
||||||
|
'/* XPM */'#13#10'static char *Pixmap[] = {'#13#10'"24 24 16 2",'#13#10'"00 c'
|
||||||
|
+' black",'#13#10'"01 c #800000",'#13#10'"02 c #008000",'#13#10'"03 c #808000'
|
||||||
|
+'",'#13#10'"04 c #000080",'#13#10'"05 c none",'#13#10'"06 c #008080",'#13#10
|
||||||
|
+'"07 c #C0C0C0",'#13#10'"08 c #808080",'#13#10'"09 c red",'#13#10'"10 c gree'
|
||||||
|
+'n",'#13#10'"11 c yellow",'#13#10'"12 c blue",'#13#10'"13 c magenta",'#13#10
|
||||||
|
+'"14 c cyan",'#13#10'"15 c Gray100",'#13#10'"0505050505050505050505050505050'
|
||||||
|
+'50505050505050505",'#13#10'"05050404040404040404040404040404040404040404040'
|
||||||
|
+'5",'#13#10'"050415151515151515151515151515151515151515150404",'#13#10'"0504'
|
||||||
|
+'15151515151515151515151515151515151515150404",'#13#10'"05040303030303000300'
|
||||||
|
+'0300030003000303030303030404",'#13#10'"050415151515001500080008000800080015'
|
||||||
|
+'151515150404",'#13#10'"050415151500151500080008000800080015151515150404",'
|
||||||
|
+#13#10'"050415151500150000150015001500150000151515150404",'#13#10'"050415151'
|
||||||
|
+'500150015151515151515151500151515150404",'#13#10'"0504151515001500151414141'
|
||||||
|
+'41414141500151515150404",'#13#10'"05041515150015001515080815081515150015151'
|
||||||
|
+'5150404",'#13#10'"050415151500150015141414141414141500151515150404",'#13#10
|
||||||
|
+'"050415151500150015150815080808151500151515150404",'#13#10'"050415151500150'
|
||||||
|
+'015141414141414141500151515150404",'#13#10'"0504151515001500151508080815151'
|
||||||
|
+'51500151515150404",'#13#10'"05041515150015001514141414141414150015151515040'
|
||||||
|
+'4",'#13#10'"050415151500150015151515151515151500151515150404",'#13#10'"0504'
|
||||||
|
+'15151500150015141414141414141500151515150404",'#13#10'"05041515151500001515'
|
||||||
|
+'1515151515151500151515150404",'#13#10'"050415151515151500000000000000000015'
|
||||||
|
+'151515150404",'#13#10'"050415151515151515151515151515151515151515150404",'
|
||||||
|
+#13#10'"050415151515151515151515151515151515151515150404",'#13#10'"050404040'
|
||||||
|
+'404040404040404040404040404040404040404",'#13#10'"0505040404040404040404040'
|
||||||
|
+'40404040404040404040405"'#13#10'};'#13#10
|
||||||
|
]);
|
||||||
|
LazarusResources.Add('TIdInterceptThrottler','XPM',[
|
||||||
|
'/* XPM */'#13#10'static char *Pixmap[] = {'#13#10'"24 24 16 2",'#13#10'"00 c'
|
||||||
|
+' black",'#13#10'"01 c #800000",'#13#10'"02 c #008000",'#13#10'"03 c #808000'
|
||||||
|
+'",'#13#10'"04 c #000080",'#13#10'"05 c none",'#13#10'"06 c #008080",'#13#10
|
||||||
|
+'"07 c #C0C0C0",'#13#10'"08 c #808080",'#13#10'"09 c red",'#13#10'"10 c gree'
|
||||||
|
+'n",'#13#10'"11 c yellow",'#13#10'"12 c blue",'#13#10'"13 c magenta",'#13#10
|
||||||
|
+'"14 c cyan",'#13#10'"15 c Gray100",'#13#10'"0505050707070707070707070707070'
|
||||||
|
+'70707070708050505",'#13#10'"05050407151515151515151515151515151515150704040'
|
||||||
|
+'5",'#13#10'"050415071507071507071507071507071507071507150404",'#13#10'"0504'
|
||||||
|
+'15071508070708070807070707070707081507150404",'#13#10'"05040307150708070808'
|
||||||
|
+'0708080708070815070707030404",'#13#10'"050415071508080707150708070708070708'
|
||||||
|
+'081507150404",'#13#10'"050415071515151515151515151515151515151507150404",'
|
||||||
|
+#13#10'"050415071515151515151515151507150715151507150404",'#13#10'"050415071'
|
||||||
|
+'515070715080807070808070807151507150404",'#13#10'"0504150715151507150807080'
|
||||||
|
+'70807150815151507150404",'#13#10'"05041507151507080708070807080715081515150'
|
||||||
|
+'7150404",'#13#10'"050415071515151515151515151515151515151507150404",'#13#10
|
||||||
|
+'"050415071515150804030407150700080815151507150404",'#13#10'"050415071515150'
|
||||||
|
+'007070715150015070015151507150404",'#13#10'"0504150715151500151515150708151'
|
||||||
|
+'50808151507150404",'#13#10'"05041507151507000800081508081515080815150715040'
|
||||||
|
+'4",'#13#10'"050415071515150815150007080815150808151507150404",'#13#10'"0504'
|
||||||
|
+'15071515151515150808080815150808151507150404",'#13#10'"05041507151508081515'
|
||||||
|
+'0808070015150808151507150404",'#13#10'"050415071515150008080015150808080015'
|
||||||
|
+'151507150404",'#13#10'"050415071515151508071515151508071515151507150404",'
|
||||||
|
+#13#10'"050415071515151515151515151515151515151507150404",'#13#10'"050404071'
|
||||||
|
+'515151515151515151515151515151507040404",'#13#10'"0505040707070707070707070'
|
||||||
|
+'70707070707070707040405"'#13#10'};'#13#10
|
||||||
|
]);
|
||||||
|
LazarusResources.Add('TIdLogDebug','XPM',[
|
||||||
|
'/* XPM */'#13#10'static char *Pixmap[] = {'#13#10'"24 24 16 2",'#13#10'"00 c'
|
||||||
|
+' black",'#13#10'"01 c #800000",'#13#10'"02 c #008000",'#13#10'"03 c #808000'
|
||||||
|
+'",'#13#10'"04 c #000080",'#13#10'"05 c none",'#13#10'"06 c #008080",'#13#10
|
||||||
|
+'"07 c #C0C0C0",'#13#10'"08 c #808080",'#13#10'"09 c red",'#13#10'"10 c gree'
|
||||||
|
+'n",'#13#10'"11 c yellow",'#13#10'"12 c blue",'#13#10'"13 c magenta",'#13#10
|
||||||
|
+'"14 c cyan",'#13#10'"15 c Gray100",'#13#10'"0505050505050505050505050505050'
|
||||||
|
+'50505050505050505",'#13#10'"05050404040404040404040404040404040404040404040'
|
||||||
|
+'5",'#13#10'"050415151515151515151515151515151515151515150404",'#13#10'"0504'
|
||||||
|
+'15151515151515151515151515151515151515150404",'#13#10'"05040303030303030303'
|
||||||
|
+'0303030303030303030303030404",'#13#10'"050415151515151507151515151515151515'
|
||||||
|
+'151515150404",'#13#10'"050415151515151507070715150707151515151515150404",'
|
||||||
|
+#13#10'"050415151515151507080808080708151515151515150404",'#13#10'"050415151'
|
||||||
|
+'515151507080803030808071515151515150404",'#13#10'"0504151515151515070901010'
|
||||||
|
+'10108071515151515150404",'#13#10'"05041515151515070808080909010108151515151'
|
||||||
|
+'5150404",'#13#10'"050415151507080708010109010101080807151515150404",'#13#10
|
||||||
|
+'"050415151508070801010109010101080708151515150404",'#13#10'"050415150707070'
|
||||||
|
+'808000909090100030708071515150404",'#13#10'"0504151515151508080101010101080'
|
||||||
|
+'80807071515150404",'#13#10'"05041515151515080708000000000807080815151515040'
|
||||||
|
+'4",'#13#10'"050415151515080707150708070807151508151515150404",'#13#10'"0504'
|
||||||
|
+'15151515150707151515151515151515151515150404",'#13#10'"05041515151515151515'
|
||||||
|
+'1515151515151515151515150404",'#13#10'"050415151515151515151515151515151515'
|
||||||
|
+'151515150404",'#13#10'"050415151515151515151515151515151515151515150404",'
|
||||||
|
+#13#10'"050415151515151515151515151515151515151515150404",'#13#10'"050404040'
|
||||||
|
+'404040404040404040404040404040404040404",'#13#10'"0505040404040404040404040'
|
||||||
|
+'40404040404040404040405"'#13#10'};'#13#10
|
||||||
|
]);
|
||||||
|
LazarusResources.Add('TIdLogEvent','XPM',[
|
||||||
|
'/* XPM */'#13#10'static char *Pixmap[] = {'#13#10'"24 24 16 2",'#13#10'"00 c'
|
||||||
|
+' black",'#13#10'"01 c #800000",'#13#10'"02 c #008000",'#13#10'"03 c #808000'
|
||||||
|
+'",'#13#10'"04 c #000080",'#13#10'"05 c none",'#13#10'"06 c #008080",'#13#10
|
||||||
|
+'"07 c #C0C0C0",'#13#10'"08 c #808080",'#13#10'"09 c red",'#13#10'"10 c gree'
|
||||||
|
+'n",'#13#10'"11 c yellow",'#13#10'"12 c blue",'#13#10'"13 c magenta",'#13#10
|
||||||
|
+'"14 c cyan",'#13#10'"15 c Gray100",'#13#10'"0505050505050505050505051215150'
|
||||||
|
+'50505050505050505",'#13#10'"05050404040404040404040412151504040404040404040'
|
||||||
|
+'5",'#13#10'"050411111111111111111111121515111111111111110404",'#13#10'"0504'
|
||||||
|
+'11111111111111111111151512111111111111110404",'#13#10'"05040303030303030303'
|
||||||
|
+'0303151512030303030303030404",'#13#10'"050411111111111111111212151512111111'
|
||||||
|
+'111111110404",'#13#10'"050411111111111111121215151515111111111111110404",'
|
||||||
|
+#13#10'"050412121111111111121515121215121212111111110404",'#13#10'"050412121'
|
||||||
|
+'212111112121512111215151515121111110404",'#13#10'"0504121412151215151512121'
|
||||||
|
+'11112151212151515110404",'#13#10'"05041215151515151215120111111215151212121'
|
||||||
|
+'2110404",'#13#10'"050412151212121212151211111111121515121311110404",'#13#10
|
||||||
|
+'"050411111111111214121111111111121512151212110404",'#13#10'"050411111111121'
|
||||||
|
+'215121201111111121512151515121204",'#13#10'"0504111111121515151512121111111'
|
||||||
|
+'21512121215151212",'#13#10'"05041111111212121112151511111215151511121512131'
|
||||||
|
+'2",'#13#10'"050411121214120111121215111112151215111215110404",'#13#10'"0504'
|
||||||
|
+'11121515121111121415111112121215111215120404",'#13#10'"05041215121201121215'
|
||||||
|
+'1512111215121415121212151512",'#13#10'"050412121201111215151212111215121212'
|
||||||
|
+'121112121515",'#13#10'"121214120111111215121201111215111112120811121212",'
|
||||||
|
+#13#10'"121512121111111215111111111111111112151212110404",'#13#10'"121512010'
|
||||||
|
+'404041215040404040404040404151512010404",'#13#10'"0515120404040412150404040'
|
||||||
|
+'40404040404121512040405"'#13#10'};'#13#10
|
||||||
|
]);
|
||||||
|
LazarusResources.Add('TIdLogFile','XPM',[
|
||||||
|
'/* XPM */'#13#10'static char *Pixmap[] = {'#13#10'"24 24 16 2",'#13#10'"00 c'
|
||||||
|
+' black",'#13#10'"01 c #800000",'#13#10'"02 c #008000",'#13#10'"03 c #808000'
|
||||||
|
+'",'#13#10'"04 c #000080",'#13#10'"05 c none",'#13#10'"06 c #008080",'#13#10
|
||||||
|
+'"07 c #C0C0C0",'#13#10'"08 c #808080",'#13#10'"09 c red",'#13#10'"10 c gree'
|
||||||
|
+'n",'#13#10'"11 c yellow",'#13#10'"12 c blue",'#13#10'"13 c magenta",'#13#10
|
||||||
|
+'"14 c cyan",'#13#10'"15 c Gray100",'#13#10'"0505050505050505050505050505050'
|
||||||
|
+'50505050505050505",'#13#10'"05050404040404040404040404040404040404040404040'
|
||||||
|
+'5",'#13#10'"050415151515151515151515151515151515151515150404",'#13#10'"0504'
|
||||||
|
+'15151515151515151515151515151515151515150404",'#13#10'"05040303030000090909'
|
||||||
|
+'0909090909090000030303030404",'#13#10'"050415150000001515151515151515150000'
|
||||||
|
+'001515150404",'#13#10'"050415150000001515151515151515150008001515150404",'
|
||||||
|
+#13#10'"050415150000001515151515151515150000001515150404",'#13#10'"050415150'
|
||||||
|
+'000001515151515151515150000001515150404",'#13#10'"0504151500000015151515151'
|
||||||
|
+'51515150000001515150404",'#13#10'"05041515000000151515151515151515000000151'
|
||||||
|
+'5150404",'#13#10'"050415150000001515151515151515150000001515150404",'#13#10
|
||||||
|
+'"050415150000000000000000000000000000001515150404",'#13#10'"050415150000000'
|
||||||
|
+'000000000000000000000001515150404",'#13#10'"0504151500000000000807070707070'
|
||||||
|
+'70000001515150404",'#13#10'"05041515000000000008070000070707000000151515040'
|
||||||
|
+'4",'#13#10'"050415150000000000080700000707070000001515150404",'#13#10'"0504'
|
||||||
|
+'15150000000000080707070707070000001515150404",'#13#10'"05041515070000000008'
|
||||||
|
+'0808080808080000071515150404",'#13#10'"050415151515151515151515151515151515'
|
||||||
|
+'151515150404",'#13#10'"050415151515151515151515151515151515151515150404",'
|
||||||
|
+#13#10'"050415151515151515151515151515151515151515150404",'#13#10'"050404040'
|
||||||
|
+'404040404040404040404040404040404040404",'#13#10'"0505040404040404040404040'
|
||||||
|
+'40404040404040404040405"'#13#10'};'#13#10
|
||||||
|
]);
|
||||||
|
LazarusResources.Add('TIdLogStream','XPM',[
|
||||||
|
'/* XPM */'#13#10'static char *Pixmap[] = {'#13#10'"24 24 16 2",'#13#10'"00 c'
|
||||||
|
+' black",'#13#10'"01 c #800000",'#13#10'"02 c #008000",'#13#10'"03 c #808000'
|
||||||
|
+'",'#13#10'"04 c #000080",'#13#10'"05 c none",'#13#10'"06 c #008080",'#13#10
|
||||||
|
+'"07 c #C0C0C0",'#13#10'"08 c #808080",'#13#10'"09 c red",'#13#10'"10 c gree'
|
||||||
|
+'n",'#13#10'"11 c yellow",'#13#10'"12 c blue",'#13#10'"13 c magenta",'#13#10
|
||||||
|
+'"14 c cyan",'#13#10'"15 c Gray100",'#13#10'"0505050505050505050505000000050'
|
||||||
|
+'50505050505050505",'#13#10'"05050404040404040404040008040404040404040404040'
|
||||||
|
+'5",'#13#10'"050411111111111111110306061111111111111111110404",'#13#10'"0504'
|
||||||
|
+'11111111111111111106060611111111111111110404",'#13#10'"05040303030303030303'
|
||||||
|
+'0300061206030303030303030404",'#13#10'"050411111111110711111104060606081111'
|
||||||
|
+'111111110404",'#13#10'"050411111111110800110006040604071111111111110404",'
|
||||||
|
+#13#10'"050411111111111108000604060600111111111111110404",'#13#10'"050411111'
|
||||||
|
+'111110006060606040011111111111111110404",'#13#10'"0504111111110406061206060'
|
||||||
|
+'60011111111111111110404",'#13#10'"05041111110006060606061206081111111111111'
|
||||||
|
+'1110404",'#13#10'"050411111106060406120606060300111111111111110404",'#13#10
|
||||||
|
+'"050411110004060406060606120011111111111111110404",'#13#10'"050411110603060'
|
||||||
|
+'400061207070011001108111111110404",'#13#10'"0504111106080606060604060600031'
|
||||||
|
+'50002031111110404",'#13#10'"05041111000604061206060606060608000011111111040'
|
||||||
|
+'4",'#13#10'"050411110006060406060604061206060000111111110404",'#13#10'"0504'
|
||||||
|
+'11111104060806060606060606060606000811110404",'#13#10'"05041111110006080006'
|
||||||
|
+'0406040006040612060611110404",'#13#10'"050411111111060002060408060604000606'
|
||||||
|
+'060611110404",'#13#10'"050411111111030606020006060604000604040611110404",'
|
||||||
|
+#13#10'"050411111111110302000008040606061206061111110404",'#13#10'"050404040'
|
||||||
|
+'404040404000606060604040608040404040404",'#13#10'"0505040404040404040404040'
|
||||||
|
+'40404040404040404040405"'#13#10'};'#13#10
|
||||||
|
]);
|
||||||
|
LazarusResources.Add('TIdUDPServer','XPM',[
|
||||||
|
'/* XPM */'#13#10'static char *Pixmap[] = {'#13#10'"24 24 16 2",'#13#10'"00 c'
|
||||||
|
+' black",'#13#10'"01 c #800000",'#13#10'"02 c #008000",'#13#10'"03 c none",'
|
||||||
|
+#13#10'"04 c #000080",'#13#10'"05 c #800080",'#13#10'"06 c #008080",'#13#10
|
||||||
|
+'"07 c #C0C0C0",'#13#10'"08 c #808080",'#13#10'"09 c red",'#13#10'"10 c gree'
|
||||||
|
+'n",'#13#10'"11 c yellow",'#13#10'"12 c blue",'#13#10'"13 c magenta",'#13#10
|
||||||
|
+'"14 c cyan",'#13#10'"15 c Gray100",'#13#10'"0303000000000000000303030303030'
|
||||||
|
+'30303030303030303",'#13#10'"03030015151515150004040404040404040404040404040'
|
||||||
|
+'3",'#13#10'"030400151414141500151515151515151515151515150404",'#13#10'"0304'
|
||||||
|
+'00151414141500151515151515151515151515150404",'#13#10'"03040015080808080008'
|
||||||
|
+'0808080808080808080815150404",'#13#10'"030400000000000000070707070707070707'
|
||||||
|
+'070815150404",'#13#10'"000000151507070700000007070707070707081515150404",'
|
||||||
|
+#13#10'"001515070707070707080008080808070708080808080404",'#13#10'"001508080'
|
||||||
|
+'808080808080015150807070707070707070404",'#13#10'"0000000000000000000000150'
|
||||||
|
+'80707070707070707070404",'#13#10'"03041515151515151515151508080808080808080'
|
||||||
|
+'8080404",'#13#10'"030415151515151515151515151515151515151515150404",'#13#10
|
||||||
|
+'"030415151515151515151515151515151515151515150404",'#13#10'"030415000015150'
|
||||||
|
+'000150000000015150000000000150404",'#13#10'"0304150000151500001500001500001'
|
||||||
|
+'50000150000150404",'#13#10'"03041500001515000015000015000015000015000015040'
|
||||||
|
+'4",'#13#10'"030415000015150000150000150000150000000000150404",'#13#10'"0304'
|
||||||
|
+'15000015150000150000150000150000151515150404",'#13#10'"03041500001515000015'
|
||||||
|
+'0000150000150000151515150404",'#13#10'"030415150000000015150000000015150000'
|
||||||
|
+'151515150404",'#13#10'"030415151515151515151515151515151515151515150404",'
|
||||||
|
+#13#10'"030415151515151515151515151515151515151515150404",'#13#10'"030404040'
|
||||||
|
+'404040404040404040404040404040404040404",'#13#10'"0303040404040404040404040'
|
||||||
|
+'40404040404040404040403"'#13#10'};'#13#10
|
||||||
|
]);
|
||||||
|
LazarusResources.Add('TIdCmdTCPServer','XPM',[
|
||||||
|
'/* XPM */'#13#10'static char *Pixmap[] = {'#13#10'"24 24 16 2",'#13#10'"00 c'
|
||||||
|
+' black",'#13#10'"01 c #800000",'#13#10'"02 c #008000",'#13#10'"03 c none",'
|
||||||
|
+#13#10'"04 c #000080",'#13#10'"05 c #800080",'#13#10'"06 c #008080",'#13#10
|
||||||
|
+'"07 c #808080",'#13#10'"08 c #C0C0C0",'#13#10'"09 c red",'#13#10'"10 c gree'
|
||||||
|
+'n",'#13#10'"11 c yellow",'#13#10'"12 c blue",'#13#10'"13 c magenta",'#13#10
|
||||||
|
+'"14 c cyan",'#13#10'"15 c Gray100",'#13#10'"0303030303030303030303030303030'
|
||||||
|
+'30303030303030303",'#13#10'"03030404040404040404040404040404040404040404040'
|
||||||
|
+'3",'#13#10'"030415151515151515151515151515151515151515150404",'#13#10'"0304'
|
||||||
|
+'15151515151515151515151515151515151515150404",'#13#10'"03041515151515151515'
|
||||||
|
+'1515151515151515151515150404",'#13#10'"030415151515151515151515151515151515'
|
||||||
|
+'151515150404",'#13#10'"030415151515151515151515151515151515151515150404",'
|
||||||
|
+#13#10'"030415070000000015000008150800000000000007150404",'#13#10'"030400000'
|
||||||
|
+'815080015150007150700151500000800000404",'#13#10'"0304000015151515151500001'
|
||||||
|
+'50000151500001500000404",'#13#10'"03040000151515151515000707070015150000150'
|
||||||
|
+'0000404",'#13#10'"030400001515151515150008000800151500001500000404",'#13#10
|
||||||
|
+'"030400000815080015150015071500151500000800000404",'#13#10'"030415070000000'
|
||||||
|
+'815000000150000000000000007150404",'#13#10'"0304151515151515151515151515151'
|
||||||
|
+'51515151515150404",'#13#10'"03041515151515151515151515151515151515151515040'
|
||||||
|
+'4",'#13#10'"030415151515151515151515151515151515151515150404",'#13#10'"0304'
|
||||||
|
+'15151515151515151515151515151515151515150404",'#13#10'"03041515151515151515'
|
||||||
|
+'1515151515151515151515150404",'#13#10'"030415151515151515151515151515151515'
|
||||||
|
+'151515150404",'#13#10'"030415151515151515151515151515151515151515150404",'
|
||||||
|
+#13#10'"030415151515151515151515151515151515151515150404",'#13#10'"030404040'
|
||||||
|
+'404040404040404040404040404040404040404",'#13#10'"0303040404040404040404040'
|
||||||
|
+'40404040404040404040403"'#13#10'};'#13#10
|
||||||
|
]);
|
||||||
|
LazarusResources.Add('TIdSimpleServer','XPM',[
|
||||||
|
'/* XPM */'#13#10'static char *Pixmap[] = {'#13#10'"24 24 16 2",'#13#10'"00 c'
|
||||||
|
+' black",'#13#10'"01 c #800000",'#13#10'"02 c #008000",'#13#10'"03 c #808000'
|
||||||
|
+'",'#13#10'"04 c #000080",'#13#10'"05 c none",'#13#10'"06 c #008080",'#13#10
|
||||||
|
+'"07 c #C0C0C0",'#13#10'"08 c #808080",'#13#10'"09 c red",'#13#10'"10 c gree'
|
||||||
|
+'n",'#13#10'"11 c yellow",'#13#10'"12 c blue",'#13#10'"13 c magenta",'#13#10
|
||||||
|
+'"14 c cyan",'#13#10'"15 c Gray100",'#13#10'"0505000000000000000505050505050'
|
||||||
|
+'50505050505050505",'#13#10'"05050015151515150004040404040404040404040404040'
|
||||||
|
+'5",'#13#10'"050400151414141500151515151515151515151515150404",'#13#10'"0504'
|
||||||
|
+'00151414141500151515151515151515151515150404",'#13#10'"05040015080808080015'
|
||||||
|
+'1515151515151515151515150404",'#13#10'"050400000000000000151515151515151515'
|
||||||
|
+'151515150404",'#13#10'"000000151507070700000015151515151515151515150404",'
|
||||||
|
+#13#10'"001515070707070707080015151515151515151515150404",'#13#10'"001508080'
|
||||||
|
+'808080808080015151515151515151515150404",'#13#10'"0000000000000000000000151'
|
||||||
|
+'51515151515151515150404",'#13#10'"05041515151515151515151515151515151515151'
|
||||||
|
+'5150404",'#13#10'"050415151515151515151515151515151515151515150404",'#13#10
|
||||||
|
+'"050415151515151515151515151515151515151515150404",'#13#10'"050415000000000'
|
||||||
|
+'000150000000000150000000000150404",'#13#10'"0504151515000015151500001515151'
|
||||||
|
+'50000150000150404",'#13#10'"05041515150000151515000015151515000015000015040'
|
||||||
|
+'4",'#13#10'"050415151500001515150000151515150000000000150404",'#13#10'"0504'
|
||||||
|
+'15151500001515150000151515150000151515150404",'#13#10'"05041515150000151515'
|
||||||
|
+'0000151515150000151515150404",'#13#10'"050415151500001515150000000000150000'
|
||||||
|
+'151515150404",'#13#10'"050415151515151515151515151515151515151515150404",'
|
||||||
|
+#13#10'"050415151515151515151515151515151515151515150404",'#13#10'"050404040'
|
||||||
|
+'404040404040404040404040404040404040404",'#13#10'"0505040404040404040404040'
|
||||||
|
+'40404040404040404040405"'#13#10'};'#13#10
|
||||||
|
]);
|
||||||
|
LazarusResources.Add('TIdTCPServer','XPM',[
|
||||||
|
'/* XPM */'#13#10'static char *Pixmap[] = {'#13#10'"24 24 16 2",'#13#10'"00 c'
|
||||||
|
+' black",'#13#10'"01 c #800000",'#13#10'"02 c #008000",'#13#10'"03 c #808000'
|
||||||
|
+'",'#13#10'"04 c #000080",'#13#10'"05 c none",'#13#10'"06 c #008080",'#13#10
|
||||||
|
+'"07 c #C0C0C0",'#13#10'"08 c #808080",'#13#10'"09 c red",'#13#10'"10 c gree'
|
||||||
|
+'n",'#13#10'"11 c yellow",'#13#10'"12 c blue",'#13#10'"13 c magenta",'#13#10
|
||||||
|
+'"14 c cyan",'#13#10'"15 c Gray100",'#13#10'"0505000000000000000505050505050'
|
||||||
|
+'50505050505050505",'#13#10'"05050015151515150004040404040404040404040404040'
|
||||||
|
+'5",'#13#10'"050400151414141500151515151515151515151515150404",'#13#10'"0504'
|
||||||
|
+'00151414141500151515151515151515151515150404",'#13#10'"05040015080808080003'
|
||||||
|
+'0303030303030303030315150404",'#13#10'"050400000000000000111111111111111111'
|
||||||
|
+'110315150404",'#13#10'"000000151507070700000011111111111111031515150404",'
|
||||||
|
+#13#10'"001515070707070707080003030303111103030303030404",'#13#10'"001508080'
|
||||||
|
+'808080808080015150311111111111111110404",'#13#10'"0000000000000000000000150'
|
||||||
|
+'31111111111111111110404",'#13#10'"05041515151515151515151503030303030303030'
|
||||||
|
+'3030404",'#13#10'"050415151515151515151515151515151515151515150404",'#13#10
|
||||||
|
+'"050415151515151515151515151515151515151515150404",'#13#10'"050415000000000'
|
||||||
|
+'000150000000000150000000000150404",'#13#10'"0504151515000015151500001515151'
|
||||||
|
+'50000150000150404",'#13#10'"05041515150000151515000015151515000015000015040'
|
||||||
|
+'4",'#13#10'"050415151500001515150000151515150000000000150404",'#13#10'"0504'
|
||||||
|
+'15151500001515150000151515150000151515150404",'#13#10'"05041515150000151515'
|
||||||
|
+'0000151515150000151515150404",'#13#10'"050415151500001515150000000000150000'
|
||||||
|
+'151515150404",'#13#10'"050415151515151515151515151515151515151515150404",'
|
||||||
|
+#13#10'"050415151515151515151515151515151515151515150404",'#13#10'"050404040'
|
||||||
|
+'404040404040404040404040404040404040404",'#13#10'"0505040404040404040404040'
|
||||||
|
+'40404040404040404040405"'#13#10'};'#13#10
|
||||||
|
]);
|
||||||
|
LazarusResources.Add('TIdIPMCastServer','XPM',[
|
||||||
|
'/* XPM */'#13#10'static char *Pixmap[] = {'#13#10'"24 24 16 2",'#13#10'"00 c'
|
||||||
|
+' black",'#13#10'"01 c #800000",'#13#10'"02 c #008000",'#13#10'"03 c #808000'
|
||||||
|
+'",'#13#10'"04 c #000080",'#13#10'"05 c none",'#13#10'"06 c #008080",'#13#10
|
||||||
|
+'"07 c #C0C0C0",'#13#10'"08 c #808080",'#13#10'"09 c red",'#13#10'"10 c gree'
|
||||||
|
+'n",'#13#10'"11 c yellow",'#13#10'"12 c blue",'#13#10'"13 c magenta",'#13#10
|
||||||
|
+'"14 c cyan",'#13#10'"15 c Gray100",'#13#10'"0505000000000000000505050505050'
|
||||||
|
+'50505050505050505",'#13#10'"05050015151515150004040404040404040404040404040'
|
||||||
|
+'5",'#13#10'"050400151414141500080808080808151515151515150404",'#13#10'"0504'
|
||||||
|
+'00151414141500150708070707080715151515150404",'#13#10'"05040015080808080008'
|
||||||
|
+'0707070708070707151515150404",'#13#10'"050400000000000000070708080815080708'
|
||||||
|
+'151515150404",'#13#10'"000000151507070700000015070707150815081515150404",'
|
||||||
|
+#13#10'"001515070707070707080008080707080707081515150404",'#13#10'"001508080'
|
||||||
|
+'808080808080007070707080707081515150404",'#13#10'"0000000000000000000000080'
|
||||||
|
+'70815080708081515150404",'#13#10'"05041515150807070815070808150708070708151'
|
||||||
|
+'5150404",'#13#10'"050415151508150807081500001508150815081515150404",'#13#10
|
||||||
|
+'"050415151507070707150800000715070708071515150404",'#13#10'"050415151515080'
|
||||||
|
+'708070800000708081508151515150404",'#13#10'"0504151515151508071500000008150'
|
||||||
|
+'70815151515150404",'#13#10'"05041515151515151507000808001507151515151515040'
|
||||||
|
+'4",'#13#10'"050415151515151515080000000015151515151515150404",'#13#10'"0504'
|
||||||
|
+'15151515151515000008070007151515151515150404",'#13#10'"05041515151515150700'
|
||||||
|
+'0700080008151515151515150404",'#13#10'"050415151515151507000800080008151515'
|
||||||
|
+'151515150404",'#13#10'"050415151515151508000808150000071515151515150404",'
|
||||||
|
+#13#10'"050415151515151500080800080800071515151515150404",'#13#10'"050404040'
|
||||||
|
+'404040700070800001500080404040404040404",'#13#10'"0505040404040407000808080'
|
||||||
|
+'70008080404040404040405"'#13#10'};'#13#10
|
||||||
|
]);
|
||||||
|
LazarusResources.Add('TIdSocksInfo','XPM',[
|
||||||
|
'/* XPM */'#13#10'static char *Pixmap[] = {'#13#10'"24 24 16 2",'#13#10'"00 c'
|
||||||
|
+' black",'#13#10'"01 c #800000",'#13#10'"02 c #008000",'#13#10'"03 c #808000'
|
||||||
|
+'",'#13#10'"04 c #000080",'#13#10'"05 c #800080",'#13#10'"06 c #008080",'#13
|
||||||
|
+#10'"07 c #C0C0C0",'#13#10'"08 c #808080",'#13#10'"09 c none",'#13#10'"10 c '
|
||||||
|
+'green",'#13#10'"11 c yellow",'#13#10'"12 c blue",'#13#10'"13 c magenta",'#13
|
||||||
|
+#10'"14 c cyan",'#13#10'"15 c Gray100",'#13#10'"0909090907080000000003080807'
|
||||||
|
+'09090909090909090909",'#13#10'"09090407000311111111110303030004040404040404'
|
||||||
|
+'0409",'#13#10'"090415070011111111111111110300081515151515150404",'#13#10'"0'
|
||||||
|
+'90415150003111111111111110300071515151515150404",'#13#10'"09041515000311031'
|
||||||
|
+'1030311110300151515151515150404",'#13#10'"090415150000000204020802000808151'
|
||||||
|
+'515151515150404",'#13#10'"090415150700081008100614020115151515151515150404"'
|
||||||
|
+','#13#10'"090415150700061410071008020815151515151515150404",'#13#10'"090415'
|
||||||
|
+'150700100808101408020415151515151515150404",'#13#10'"0904151507000810140810'
|
||||||
|
+'06020815151515151515150404",'#13#10'"09041515070014081006081004031515151515'
|
||||||
|
+'1515150404",'#13#10'"090415150800100810071008020815151515151515150404",'#13
|
||||||
|
+#10'"090415150800061008101406020515151515151515150404",'#13#10'"090415150803'
|
||||||
|
+'030006081008100407151515151515150404",'#13#10'"0904151508001111000208100810'
|
||||||
|
+'08081515151515150404",'#13#10'"09041515000311110300061408061008020708151515'
|
||||||
|
+'0404",'#13#10'"090415150703111111000210081008060600000115150404",'#13#10'"0'
|
||||||
|
+'90415151500111103000806101408020303020007150404",'#13#10'"09041515151500110'
|
||||||
|
+'3000610070202031111030007150404",'#13#10'"090415151515070000020806100011111'
|
||||||
|
+'111110008150404",'#13#10'"090415151515150700061008060311111111030007150404"'
|
||||||
|
+','#13#10'"090415151515151515070800031111111111000815150404",'#13#10'"090404'
|
||||||
|
+'040404040404040407000303111101000704040404",'#13#10'"0909040404040404040404'
|
||||||
|
+'04040708000006040404040409"'#13#10'};'#13#10
|
||||||
|
]);
|
||||||
|
LazarusResources.Add('TIdAntiFreeze','XPM',[
|
||||||
|
'/* XPM */'#13#10'static char *Pixmap[] = {'#13#10'"24 24 16 2",'#13#10'"00 c'
|
||||||
|
+' black",'#13#10'"01 c #800000",'#13#10'"02 c #008000",'#13#10'"03 c #808000'
|
||||||
|
+'",'#13#10'"04 c #000080",'#13#10'"05 c #800080",'#13#10'"06 c #008080",'#13
|
||||||
|
+#10'"07 c #C0C0C0",'#13#10'"08 c #808080",'#13#10'"09 c none",'#13#10'"10 c '
|
||||||
|
+'green",'#13#10'"11 c yellow",'#13#10'"12 c blue",'#13#10'"13 c magenta",'#13
|
||||||
|
+#10'"14 c cyan",'#13#10'"15 c Gray100",'#13#10'"0909090909090909090909090909'
|
||||||
|
+'09090909090909090909",'#13#10'"09090404040404000000040404040404040404040404'
|
||||||
|
+'0409",'#13#10'"090415151515150000001511111111111115151515150404",'#13#10'"0'
|
||||||
|
+'90415151515151111111115151515151111151515150404",'#13#10'"09041515151511111'
|
||||||
|
+'1111515151515151111151515150404",'#13#10'"090415151515111111111515151511111'
|
||||||
|
+'111111515150404",'#13#10'"090415151515111111111111111111111111111515150404"'
|
||||||
|
+','#13#10'"090415151511111111111111111111111111111515150404",'#13#10'"090415'
|
||||||
|
+'151511080101010101010101030103111515150404",'#13#10'"0904151515110800000000'
|
||||||
|
+'00000000000001111515150404",'#13#10'"09041515151108000000000000000000000111'
|
||||||
|
+'1515150404",'#13#10'"090415151511080000000000000000000003111515150404",'#13
|
||||||
|
+#10'"090415151511080000000000000000000003111515150404",'#13#10'"090415151511'
|
||||||
|
+'080808080808080808080803111515150404",'#13#10'"0904151515110808080808080808'
|
||||||
|
+'08080003111515150404",'#13#10'"09041515151108080000000808080008000311151515'
|
||||||
|
+'0404",'#13#10'"090415151511080000000000000000000003111515150404",'#13#10'"0'
|
||||||
|
+'90415151511080000000000000000000003111515150404",'#13#10'"09041515151108000'
|
||||||
|
+'0000000000000000003111515150404",'#13#10'"090415151511080000000000000000000'
|
||||||
|
+'103111515150404",'#13#10'"090415151511110808080808080808070711111515150404"'
|
||||||
|
+','#13#10'"090415151511111111111111111111111111111515150404",'#13#10'"090404'
|
||||||
|
+'040404111111111111111111111111040404040404",'#13#10'"0909040404040404040404'
|
||||||
|
+'04040404040404040404040409"'#13#10'};'#13#10
|
||||||
|
]);
|
||||||
|
LazarusResources.Add('TIdSchedulerOfThreadDefault','XPM',[
|
||||||
|
'/* XPM */'#13#10'static char *Pixmap[] = {'#13#10'"24 24 16 2",'#13#10'"00 c'
|
||||||
|
+' black",'#13#10'"01 c #800000",'#13#10'"02 c #008000",'#13#10'"03 c none",'
|
||||||
|
+#13#10'"04 c #000080",'#13#10'"05 c #800080",'#13#10'"06 c #008080",'#13#10
|
||||||
|
+'"07 c #C0C0C0",'#13#10'"08 c #808080",'#13#10'"09 c red",'#13#10'"10 c gree'
|
||||||
|
+'n",'#13#10'"11 c yellow",'#13#10'"12 c blue",'#13#10'"13 c magenta",'#13#10
|
||||||
|
+'"14 c cyan",'#13#10'"15 c Gray100",'#13#10'"0303030303030303030303030303030'
|
||||||
|
+'30303030303030303",'#13#10'"03030404040404040404040404040404040404040404040'
|
||||||
|
+'3",'#13#10'"030409141409141414141414141414141414091414090404",'#13#10'"0304'
|
||||||
|
+'14091409141414141414141414141414091409140404",'#13#10'"03041414091409141414'
|
||||||
|
+'1414141414141409140914140404",'#13#10'"030409091409140914141414141414140914'
|
||||||
|
+'091409090404",'#13#10'"030414140914091409141414141414091409140914140404",'
|
||||||
|
+#13#10'"030414140009000909000000000000090900090014140404",'#13#10'"030414140'
|
||||||
|
+'007090909090707070709090909070014140404",'#13#10'"0304141400070707090909070'
|
||||||
|
+'70909090707070014140404",'#13#10'"03041414000707070709090707090907070707001'
|
||||||
|
+'4140404",'#13#10'"030414140007070707070709090707070707070014140404",'#13#10
|
||||||
|
+'"030414140007070707070709090707070707070014140404",'#13#10'"030414140007070'
|
||||||
|
+'707090907070909070707070014140404",'#13#10'"0304141400070707090909070709090'
|
||||||
|
+'90707070014140404",'#13#10'"03041414000709090909070707070909090907001414040'
|
||||||
|
+'4",'#13#10'"030414140009000909000000000000090900090014140404",'#13#10'"0304'
|
||||||
|
+'14140914091409141414141414091409140914140404",'#13#10'"03040909140914091414'
|
||||||
|
+'1414141414140914091409090404",'#13#10'"030414140914091414141414141414141409'
|
||||||
|
+'140914140404",'#13#10'"030414091409141414141414141414141414091409140404",'
|
||||||
|
+#13#10'"030409141409141414141414141414141414091414090404",'#13#10'"030404040'
|
||||||
|
+'404040404040404040404040404040404040404",'#13#10'"0303040404040404040404040'
|
||||||
|
+'40404040404040404040403"'#13#10'};'#13#10
|
||||||
|
]);
|
||||||
|
LazarusResources.Add('TIdSchedulerOfThreadPool','XPM',[
|
||||||
|
'/* XPM */'#13#10'static char *Pixmap[] = {'#13#10'"24 24 16 2",'#13#10'"00 c'
|
||||||
|
+' black",'#13#10'"01 c #800000",'#13#10'"02 c #008000",'#13#10'"03 c none",'
|
||||||
|
+#13#10'"04 c #000080",'#13#10'"05 c #800080",'#13#10'"06 c #008080",'#13#10
|
||||||
|
+'"07 c #C0C0C0",'#13#10'"08 c #808080",'#13#10'"09 c red",'#13#10'"10 c gree'
|
||||||
|
+'n",'#13#10'"11 c yellow",'#13#10'"12 c blue",'#13#10'"13 c magenta",'#13#10
|
||||||
|
+'"14 c cyan",'#13#10'"15 c Gray100",'#13#10'"0303030303030303030303030303030'
|
||||||
|
+'30303030303030303",'#13#10'"03030404040404040404040404040404040404040404040'
|
||||||
|
+'3",'#13#10'"030405050514141414141414141414141414140505050404",'#13#10'"0304'
|
||||||
|
+'14141405050505141414141414050505051414140404",'#13#10'"03041414141414141405'
|
||||||
|
+'0505050505141414141414140404",'#13#10'"030405050514141414141414141414141414'
|
||||||
|
+'140505050404",'#13#10'"030414141405050505141414141414050505051414140404",'
|
||||||
|
+#13#10'"030414140000000000050505050505000000000014140404",'#13#10'"030405050'
|
||||||
|
+'507070707070707070707070707070505050404",'#13#10'"0304141400050505050707070'
|
||||||
|
+'70707050505050014140404",'#13#10'"03041414000707070705050505050507070707001'
|
||||||
|
+'4140404",'#13#10'"030414140007070707070707070707070707070014140404",'#13#10
|
||||||
|
+'"030414140007070707070707070707070707070014140404",'#13#10'"030414140007070'
|
||||||
|
+'707050505050505070707070014140404",'#13#10'"0304141400050505050707070707070'
|
||||||
|
+'50505050014140404",'#13#10'"03040505050707070707070707070707070707050505040'
|
||||||
|
+'4",'#13#10'"030414140000000000050505050505000000000014140404",'#13#10'"0304'
|
||||||
|
+'14141405050505141414141414050505051414140404",'#13#10'"03040505051414141414'
|
||||||
|
+'1414141414141414140505050404",'#13#10'"030414141414141414050505050505141414'
|
||||||
|
+'141414140404",'#13#10'"030414141405050505141414141414050505051414140404",'
|
||||||
|
+#13#10'"030405050514141414141414141414141414140505050404",'#13#10'"030404040'
|
||||||
|
+'404040404040404040404040404040404040404",'#13#10'"0303040404040404040404040'
|
||||||
|
+'40404040404040404040403"'#13#10'};'#13#10
|
||||||
|
]);
|
||||||
|
LazarusResources.Add('TIdThreadComponent','XPM',[
|
||||||
|
'/* XPM */'#13#10'static char *Pixmap[] = {'#13#10'"24 24 16 2",'#13#10'"00 c'
|
||||||
|
+' black",'#13#10'"01 c #800000",'#13#10'"02 c #008000",'#13#10'"03 c #808000'
|
||||||
|
+'",'#13#10'"04 c #000080",'#13#10'"05 c none",'#13#10'"06 c #008080",'#13#10
|
||||||
|
+'"07 c #C0C0C0",'#13#10'"08 c #808080",'#13#10'"09 c red",'#13#10'"10 c gree'
|
||||||
|
+'n",'#13#10'"11 c yellow",'#13#10'"12 c blue",'#13#10'"13 c magenta",'#13#10
|
||||||
|
+'"14 c cyan",'#13#10'"15 c Gray100",'#13#10'"0505050505050505050505050505050'
|
||||||
|
+'50505050505050505",'#13#10'"05050404040404040404040404040404040404040404040'
|
||||||
|
+'5",'#13#10'"050415151515151515151515151515151515151515150404",'#13#10'"0504'
|
||||||
|
+'15151515151515151515151515151515151515150404",'#13#10'"05041515151515151515'
|
||||||
|
+'1515151515151515151515150404",'#13#10'"050415151515151515151515151515151515'
|
||||||
|
+'151515150404",'#13#10'"050415151515151515151515151515151515151515150404",'
|
||||||
|
+#13#10'"050415151515151515151515151515151515151515150404",'#13#10'"050415151'
|
||||||
|
+'515151515151515151515151515151515150404",'#13#10'"1313131313131313131313131'
|
||||||
|
+'31313131313131313131313",'#13#10'"13131313131313131313131313131313131313131'
|
||||||
|
+'3131313",'#13#10'"131313131313131313131313131313131313131313131313",'#13#10
|
||||||
|
+'"050415151515151515151515151515151515151515150404",'#13#10'"050415151515151'
|
||||||
|
+'515151515151515151515151515150404",'#13#10'"0504151515151515151515151515151'
|
||||||
|
+'51515151515150404",'#13#10'"05041515151515151515151515151515151515151515040'
|
||||||
|
+'4",'#13#10'"050415151515151515151515151515151515151515150404",'#13#10'"0504'
|
||||||
|
+'15151515151515151515151515151515151515150404",'#13#10'"05041515151515151515'
|
||||||
|
+'1515151515151515151515150404",'#13#10'"050415151515151515151515151515151515'
|
||||||
|
+'151515150404",'#13#10'"050415151515151515151515151515151515151515150404",'
|
||||||
|
+#13#10'"050415151515151515151515151515151515151515150404",'#13#10'"050404040'
|
||||||
|
+'404040404040404040404040404040404040404",'#13#10'"0505040404040404040404040'
|
||||||
|
+'40404040404040404040405"'#13#10'};'#13#10
|
||||||
|
]);
|
||||||
|
LazarusResources.Add('TIDICMPCLIENT','XPM',[
|
||||||
|
'/* XPM */'#13#10'static char *Pixmap[] = {'#13#10'"24 24 16 2",'#13#10'"00 c'
|
||||||
|
+' black",'#13#10'"01 c #800000",'#13#10'"02 c #008000",'#13#10'"03 c none",'
|
||||||
|
+#13#10'"04 c #000080",'#13#10'"05 c #800080",'#13#10'"06 c #008080",'#13#10
|
||||||
|
+'"07 c #C0C0C0",'#13#10'"08 c #808080",'#13#10'"09 c red",'#13#10'"10 c gree'
|
||||||
|
+'n",'#13#10'"11 c yellow",'#13#10'"12 c blue",'#13#10'"13 c magenta",'#13#10
|
||||||
|
+'"14 c cyan",'#13#10'"15 c Gray100",'#13#10'"0303030303030303030303030303030'
|
||||||
|
+'30303030303030303",'#13#10'"03030404040404040404040404040404040404040404040'
|
||||||
|
+'3",'#13#10'"030415151515151515151515151515151515151515150404",'#13#10'"0304'
|
||||||
|
+'05050505050505050505050505050515151515150404",'#13#10'"03041313131313131313'
|
||||||
|
+'1313131313130515151515150404",'#13#10'"030413131313131313131313131313051515'
|
||||||
|
+'151515150404",'#13#10'"030405050505050505050513131305151515151515150404",'
|
||||||
|
+#13#10'"030415151515151515051313130505050505050505050404",'#13#10'"030415151'
|
||||||
|
+'515151505131313131313131313131313130404",'#13#10'"0304151515151505131313131'
|
||||||
|
+'31313131313131313130404",'#13#10'"03041515151515050505050505050505050505050'
|
||||||
|
+'5050404",'#13#10'"030415151515151515151515151515151515151515150404",'#13#10
|
||||||
|
+'"030415151515151515151515151515151515151515150404",'#13#10'"030415000015000'
|
||||||
|
+'000001500001500001500000000150404",'#13#10'"0304150000150000151515000000000'
|
||||||
|
+'01500001500150404",'#13#10'"03041500001500001515150015001500150000150015040'
|
||||||
|
+'4",'#13#10'"030415000015000015151500150015001500000000150404",'#13#10'"0304'
|
||||||
|
+'15000015000015151500150015001500001515150404",'#13#10'"03041500001500001515'
|
||||||
|
+'1500150015001500001515150404",'#13#10'"030415000015000000001500150015001500'
|
||||||
|
+'001515150404",'#13#10'"030415151515151515151515151515151515151515150404",'
|
||||||
|
+#13#10'"030415151515151515151515151515151515151515150404",'#13#10'"030404040'
|
||||||
|
+'404040404040404040404040404040404040404",'#13#10'"0303040404040404040404040'
|
||||||
|
+'40404040404040404040403"'#13#10'};'#13#10
|
||||||
|
]);
|
|
@ -0,0 +1,668 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.1 2/8/2004 1:35:40 PM JPMugaas
|
||||||
|
IdSocks is now in DotNET.
|
||||||
|
|
||||||
|
Rev 1.0 2/3/2004 12:28:06 PM JPMugaas
|
||||||
|
Kudzu wanted this renamed.
|
||||||
|
|
||||||
|
Rev 1.27 2004.01.01 2:40:02 PM czhower
|
||||||
|
Removed test ifdef
|
||||||
|
|
||||||
|
Rev 1.26 1/1/2004 3:32:30 PM BGooijen
|
||||||
|
Added icons for .Net
|
||||||
|
|
||||||
|
Rev 1.25 2003.12.31 11:02:50 PM czhower
|
||||||
|
New components now registered for .net.
|
||||||
|
|
||||||
|
Rev 1.24 2003.12.25 6:55:20 PM czhower
|
||||||
|
TCPServer
|
||||||
|
|
||||||
|
Rev 1.23 11/22/2003 11:49:52 PM BGooijen
|
||||||
|
Icons for DotNet
|
||||||
|
|
||||||
|
Rev 1.22 17/11/2003 16:00:22 ANeillans
|
||||||
|
Fix Delphi compile errors.
|
||||||
|
|
||||||
|
Rev 1.21 11/8/2003 8:09:24 PM BGooijen
|
||||||
|
fix, i mixed up some stuff
|
||||||
|
|
||||||
|
Rev 1.20 11/8/2003 7:27:10 PM BGooijen
|
||||||
|
DotNet
|
||||||
|
|
||||||
|
Rev 1.19 2003.10.19 1:35:32 PM czhower
|
||||||
|
Moved Borland define to .inc
|
||||||
|
|
||||||
|
Rev 1.18 2003.10.18 11:32:42 PM czhower
|
||||||
|
Changed throttler to intercept
|
||||||
|
|
||||||
|
Rev 1.17 2003.10.17 6:18:50 PM czhower
|
||||||
|
TIdInterceptSimLog
|
||||||
|
|
||||||
|
Rev 1.16 2003.10.14 1:26:42 PM czhower
|
||||||
|
Uupdates + Intercept support
|
||||||
|
|
||||||
|
Rev 1.15 9/21/2003 01:10:40 AM JPMugaas
|
||||||
|
Added IdThreadCOmponent to the registration in Core.
|
||||||
|
|
||||||
|
Rev 1.14 2003.08.19 11:06:34 PM czhower
|
||||||
|
Fixed names of scheduler units.
|
||||||
|
|
||||||
|
Rev 1.13 8/19/2003 01:25:08 AM JPMugaas
|
||||||
|
Unnecessary junk removed.
|
||||||
|
|
||||||
|
Rev 1.12 8/15/2003 12:02:48 AM JPMugaas
|
||||||
|
Incremented version number.
|
||||||
|
Moved some units to new IndySuperCore package in D7.
|
||||||
|
Made sure package titles are uniform in the IDE and in the .RES files.
|
||||||
|
|
||||||
|
Rev 1.11 7/24/2003 03:22:00 AM JPMugaas
|
||||||
|
Removed some old files.
|
||||||
|
|
||||||
|
Rev 1.10 7/18/2003 4:33:12 PM SPerry
|
||||||
|
Added TIdCmdTCPClient
|
||||||
|
|
||||||
|
Rev 1.7 4/17/2003 05:02:26 PM JPMugaas
|
||||||
|
|
||||||
|
Rev 1.6 4/11/2003 01:09:50 PM JPMugaas
|
||||||
|
|
||||||
|
Rev 1.5 3/25/2003 11:12:54 PM BGooijen
|
||||||
|
TIdChainEngineStack added.
|
||||||
|
|
||||||
|
Rev 1.4 3/25/2003 05:02:00 PM JPMugaas
|
||||||
|
TCmdTCPServer added.
|
||||||
|
|
||||||
|
Rev 1.3 3/22/2003 10:14:54 PM BGooijen
|
||||||
|
Added TIdServerIOHandlerChain to the palette
|
||||||
|
|
||||||
|
Rev 1.2 3/22/2003 02:20:48 PM JPMugaas
|
||||||
|
Updated registration.
|
||||||
|
|
||||||
|
Rev 1.1 1/17/2003 04:18:44 PM JPMugaas
|
||||||
|
Now compiles with new packages.
|
||||||
|
|
||||||
|
Rev 1.0 11/13/2002 08:41:42 AM JPMugaas
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdRegisterCore;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes;
|
||||||
|
|
||||||
|
// Procedures
|
||||||
|
|
||||||
|
procedure Register;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
{$I IdCompilerDefines.inc}
|
||||||
|
|
||||||
|
uses
|
||||||
|
{$IFDEF FMX}
|
||||||
|
Controls,
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF FPC}
|
||||||
|
LResources,
|
||||||
|
{$ENDIF}
|
||||||
|
IdSocks,
|
||||||
|
{$IFDEF HAS_TSelectionEditor}
|
||||||
|
{$IFDEF FPC}
|
||||||
|
PropEdits,
|
||||||
|
ComponentEditors,
|
||||||
|
{$ELSE}
|
||||||
|
DesignIntf,
|
||||||
|
DesignEditors,
|
||||||
|
{$ENDIF}
|
||||||
|
TypInfo,
|
||||||
|
{$IFDEF VCL_2010_OR_ABOVE}
|
||||||
|
Rtti,
|
||||||
|
{$ENDIF}
|
||||||
|
SysUtils,
|
||||||
|
IdGlobal,
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
IdBaseComponent,
|
||||||
|
IdComponent,
|
||||||
|
IdDsnCoreResourceStrings,
|
||||||
|
IdAntiFreeze,
|
||||||
|
IdCmdTCPClient,
|
||||||
|
IdCmdTCPServer,
|
||||||
|
IdIOHandlerStream,
|
||||||
|
{$IFNDEF DOTNET}
|
||||||
|
IdIcmpClient,
|
||||||
|
{$ENDIF}
|
||||||
|
IdInterceptSimLog,
|
||||||
|
IdInterceptThrottler,
|
||||||
|
IdIPMCastClient,
|
||||||
|
IdIPMCastServer,
|
||||||
|
IdLogDebug,
|
||||||
|
IdLogEvent,
|
||||||
|
IdLogFile,
|
||||||
|
IdLogStream,
|
||||||
|
IdSchedulerOfThread,
|
||||||
|
IdSchedulerOfThreadDefault,
|
||||||
|
IdSchedulerOfThreadPool,
|
||||||
|
IdServerIOHandlerSocket,
|
||||||
|
IdServerIOHandlerStack,
|
||||||
|
IdSimpleServer,
|
||||||
|
IdThreadComponent,
|
||||||
|
{$IFNDEF DOTNET}
|
||||||
|
IdTraceRoute,
|
||||||
|
{$ENDIF}
|
||||||
|
IdUDPClient,
|
||||||
|
IdUDPServer,
|
||||||
|
IdIOHandlerSocket,
|
||||||
|
IdIOHandlerStack,
|
||||||
|
IdIntercept,
|
||||||
|
IdTCPServer,
|
||||||
|
IdTCPClient;
|
||||||
|
|
||||||
|
{$IFDEF DOTNET}
|
||||||
|
{$R IconsDotNet\TIdAntiFreeze.bmp}
|
||||||
|
{$R IconsDotNet\TIdCmdTCPClient.bmp}
|
||||||
|
{$R IconsDotNet\TIdCmdTCPServer.bmp}
|
||||||
|
{$R IconsDotNet\TIdConnectionIntercept.bmp}
|
||||||
|
{$R IconsDotNet\TIdICMPClient.bmp}
|
||||||
|
{$R IconsDotNet\TIdInterceptSimLog.bmp}
|
||||||
|
{$R IconsDotNet\TIdInterceptThrottler.bmp}
|
||||||
|
{$R IconsDotNet\TIdIOHandlerStack.bmp}
|
||||||
|
{$R IconsDotNet\TIdIOHandlerStream.bmp}
|
||||||
|
{$R IconsDotNet\TIdLogDebug.bmp}
|
||||||
|
{$R IconsDotNet\TIdLogEvent.bmp}
|
||||||
|
{$R IconsDotNet\TIdLogFile.bmp}
|
||||||
|
{$R IconsDotNet\TIdLogStream.bmp}
|
||||||
|
{$R IconsDotNet\TIdSchedulerOfThreadDefault.bmp}
|
||||||
|
{$R IconsDotNet\TIdSchedulerOfThreadPool.bmp}
|
||||||
|
{$R IconsDotNet\TIdServerIOHandlerStack.bmp}
|
||||||
|
{$R IconsDotNet\TIdSimpleServer.bmp}
|
||||||
|
{$R IconsDotNet\TIdTCPClient.bmp}
|
||||||
|
{$R IconsDotNet\TIdTCPServer.bmp}
|
||||||
|
{$R IconsDotNet\TIdThreadComponent.bmp}
|
||||||
|
{$R IconsDotNet\TIdUDPClient.bmp}
|
||||||
|
{$R IconsDotNet\TIdUDPServer.bmp}
|
||||||
|
{$R IconsDotNet\TIdIPMCastClient.bmp}
|
||||||
|
{$R IconsDotNet\TIdIPMCastServer.bmp}
|
||||||
|
{$R IconsDotNet\TIdSocksInfo.bmp}
|
||||||
|
{$ELSE}
|
||||||
|
{$IFNDEF FPC}
|
||||||
|
{$IFDEF BORLAND}
|
||||||
|
{$R IdCoreRegister.dcr}
|
||||||
|
{$ELSE}
|
||||||
|
{$R IdCoreRegisterCool.dcr}
|
||||||
|
{$ENDIF}
|
||||||
|
{$ENDIF}
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
{$IFDEF HAS_TSelectionEditor}
|
||||||
|
|
||||||
|
// TIdComponentSelectionEditor is called at design-time when saving/compiling a
|
||||||
|
// project. It enumerates the data types of all parameters and return values of
|
||||||
|
// every event handler assigned to any Indy component, extracting the unit names
|
||||||
|
// of those data types and passing them to the IDE so it can insert them into
|
||||||
|
// 'uses' clauses as needed.
|
||||||
|
|
||||||
|
procedure SendUnitNameToProc(const AUnitName: String; Proc: TGetStrProc);
|
||||||
|
begin
|
||||||
|
// Do not return the 'System' unit, otherwise it will
|
||||||
|
// cause an "Identifier redeclared" compiler error!
|
||||||
|
if (AUnitName <> '') and (not TextIsSame(AUnitName, 'System')) then begin {do not localize}
|
||||||
|
Proc(AUnitName);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{$IFDEF VCL_XE2_OR_ABOVE}
|
||||||
|
|
||||||
|
// in Delphi XE2 and later, TRttiInvokableType is used to enumerate parameters
|
||||||
|
// and return values, and TRttiType reports fully qualified type names, so
|
||||||
|
// finding a given type's unit name is very easy...
|
||||||
|
|
||||||
|
function GetUnitNameForType(const AType: TRttiType): String;
|
||||||
|
begin
|
||||||
|
// TRttiType.UnitName returns the unit that declares TRttiType itself
|
||||||
|
// (System.Rtti), so parse the TRttiType.QualifiedName value instead...
|
||||||
|
if AType <> nil then begin
|
||||||
|
Result := AType.QualifiedName;
|
||||||
|
SetLength(Result, Length(Result) - Length(AType.Name) - 1);
|
||||||
|
end else begin
|
||||||
|
Result := '';
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{$ELSE}
|
||||||
|
|
||||||
|
// in Delphi prior to XE2, as well as in FreePascal, TRttiInvokableType is not
|
||||||
|
// available, so we have to use TypInfo RTTI to enumerating parameters and
|
||||||
|
// return values, but only certain versions implement rich enough RTTI to allow
|
||||||
|
// that. Let's try to pull out what we can...
|
||||||
|
|
||||||
|
{$IFDEF FPC_2_6_0_OR_ABOVE}
|
||||||
|
{$DEFINE HAS_tkEnumeration_UnitName}
|
||||||
|
{$DEFINE HAS_tkMethod_ParamTypeInfo}
|
||||||
|
{$ELSE}
|
||||||
|
{$IFDEF VCL_6_OR_ABOVE}
|
||||||
|
{$DEFINE HAS_tkEnumeration_UnitName}
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF VCL_2010_OR_ABOVE}
|
||||||
|
{$DEFINE HAS_tkMethod_ParamTypeInfo}
|
||||||
|
{$ENDIF}
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
procedure SkipShortString(var P: PByte);
|
||||||
|
begin
|
||||||
|
Inc(P, 1 + Integer(P^));
|
||||||
|
end;
|
||||||
|
|
||||||
|
function ReadShortString(var P: PByte): String;
|
||||||
|
begin
|
||||||
|
{$IFDEF VCL_2009_OR_ABOVE}
|
||||||
|
Result := UTF8ToString(PShortString(P)^);
|
||||||
|
{$ELSE}
|
||||||
|
Result := PShortString(P)^;
|
||||||
|
{$ENDIF}
|
||||||
|
SkipShortString(P);
|
||||||
|
end;
|
||||||
|
|
||||||
|
{$IFDEF FPC_2_6_0_OR_ABOVE}
|
||||||
|
function NextShortString(PS: PShortString): PShortString;
|
||||||
|
begin
|
||||||
|
Result := PShortString(Pointer(PS)+PByte(PS)^+1);
|
||||||
|
end;
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
function GetUnitNameFromTypeName(const ATypeName: String): String;
|
||||||
|
var
|
||||||
|
K: Integer;
|
||||||
|
begin
|
||||||
|
// check if the type is qualified
|
||||||
|
K := LastDelimiter('.', ATypeName);
|
||||||
|
if K <> 0 then begin
|
||||||
|
Result := Copy(ATypeName, 1, K-1);
|
||||||
|
end else begin
|
||||||
|
// TODO: enumerate package units and find the typename...
|
||||||
|
Result := '';
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetUnitNameFromTypeInfo(const ATypeInfo: PPTypeInfo): String;
|
||||||
|
var
|
||||||
|
LTypeData: PTypeData;
|
||||||
|
{$IFDEF HAS_tkEnumeration_UnitName}
|
||||||
|
{$IFDEF FPC}
|
||||||
|
PS, PSLast: PShortString;
|
||||||
|
{$ELSE}
|
||||||
|
LBaseTypeData: PTypeData;
|
||||||
|
Value: Integer;
|
||||||
|
P: PByte;
|
||||||
|
{$ENDIF}
|
||||||
|
{$ENDIF}
|
||||||
|
begin
|
||||||
|
Result := '';
|
||||||
|
if ATypeInfo = nil then begin
|
||||||
|
Exit;
|
||||||
|
end;
|
||||||
|
if ATypeInfo^ = nil then begin
|
||||||
|
Exit;
|
||||||
|
end;
|
||||||
|
LTypeData := GetTypeData(ATypeInfo^);
|
||||||
|
case ATypeInfo^.Kind of
|
||||||
|
{$IFDEF HAS_tkEnumeration_UnitName}
|
||||||
|
tkEnumeration: begin
|
||||||
|
{$IFDEF FPC}
|
||||||
|
// the unit name iss the last string in the name list
|
||||||
|
PS := @(LTypeData^.NameList);
|
||||||
|
PSLast := nil;
|
||||||
|
while PByte(PS)^ <> 0 do begin
|
||||||
|
PSLast := PS;
|
||||||
|
PS := NextShortString(PS);
|
||||||
|
end;
|
||||||
|
if PSLast <> nil then begin
|
||||||
|
Result := PSLast^;
|
||||||
|
end;
|
||||||
|
{$ELSE}
|
||||||
|
// the unit name follows after the name list
|
||||||
|
LBaseTypeData := GetTypeData(LTypeData^.BaseType^);
|
||||||
|
P := PByte(@(LBaseTypeData^.NameList));
|
||||||
|
// LongBool/WordBool/ByteBool have MinValue < 0 and arbitrary
|
||||||
|
// content in Value; Boolean has Value in [0, 1] }
|
||||||
|
if (ATypeInfo^ = System.TypeInfo(Boolean)) or (LBaseTypeData^.MinValue < 0) then
|
||||||
|
begin
|
||||||
|
for Value := 0 to 1 do begin
|
||||||
|
SkipShortString(P);
|
||||||
|
end;
|
||||||
|
end else
|
||||||
|
begin
|
||||||
|
for Value := LBaseTypeData^.MinValue to LBaseTypeData^.MaxValue do begin
|
||||||
|
SkipShortString(P);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
Result := ReadShortString(P);
|
||||||
|
{$ENDIF}
|
||||||
|
end;
|
||||||
|
{$ENDIF}
|
||||||
|
tkSet: begin
|
||||||
|
Result := GetUnitNameFromTypeInfo(LTypeData^.CompType);
|
||||||
|
end;
|
||||||
|
{$IFDEF VCL_5_OR_ABOVE}
|
||||||
|
tkClass: begin
|
||||||
|
{$IFDEF VCL_2009_OR_ABOVE}
|
||||||
|
Result := UTF8ToString(LTypeData^.UnitName);
|
||||||
|
{$ELSE}
|
||||||
|
Result := LTypeData^.UnitName;
|
||||||
|
{$ENDIF}
|
||||||
|
end;
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF FPC_2_6_0_OR_ABOVE}
|
||||||
|
tkHelper: begin
|
||||||
|
Result := LTypeData^.HelperUnit;
|
||||||
|
end;
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF VCL_5_OR_ABOVE}
|
||||||
|
tkInterface: begin
|
||||||
|
{$IFDEF VCL_2009_OR_ABOVE}
|
||||||
|
Result := UTF8ToString(LTypeData^.IntfUnit);
|
||||||
|
{$ELSE}
|
||||||
|
Result := LTypeData^.IntfUnit;
|
||||||
|
{$ENDIF}
|
||||||
|
end;
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF FPC_2_2_2_OR_ABOVE} // TODO: when was tkInterfaceRaw added?
|
||||||
|
tkInterfaceRaw: begin
|
||||||
|
Result := LTypeData^.RawIntfUnit;
|
||||||
|
end;
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF VCL_6_OR_ABOVE}
|
||||||
|
tkDynArray: begin
|
||||||
|
{$IFDEF VCL_2009_OR_ABOVE}
|
||||||
|
Result := UTF8ToString(LTypeData^.DynUnitName);
|
||||||
|
{$ELSE}
|
||||||
|
Result := LTypeData^.DynUnitName;
|
||||||
|
{$ENDIF}
|
||||||
|
if Result = '' then begin
|
||||||
|
Result := GetUnitNameFromTypeInfo(LTypeData^.elType2);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
{$ENDIF}
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure GetUnitNamesForMethodType(const ATypeInfo: PTypeInfo; Proc: TGetStrProc);
|
||||||
|
type
|
||||||
|
PPPTypeInfo = ^PPTypeInfo;
|
||||||
|
var
|
||||||
|
LTypeData: PTypeData;
|
||||||
|
LTypeDataPtr: PByte;
|
||||||
|
K: Integer;
|
||||||
|
UnitName: string;
|
||||||
|
begin
|
||||||
|
if ATypeInfo = nil then begin
|
||||||
|
Exit;
|
||||||
|
end;
|
||||||
|
LTypeData := GetTypeData(ATypeInfo);
|
||||||
|
LTypeDataPtr := PByte(@(LTypeData^.ParamList));
|
||||||
|
|
||||||
|
if LTypeData^.ParamCount > 0 then
|
||||||
|
begin
|
||||||
|
for K := 0 to LTypeData^.ParamCount-1 do
|
||||||
|
begin
|
||||||
|
Inc(LTypeDataPtr, SizeOf(TParamFlags));
|
||||||
|
SkipShortString(LTypeDataPtr);
|
||||||
|
{$IFDEF HAS_tkMethod_ParamTypeInfo}
|
||||||
|
// handled further below...
|
||||||
|
SkipShortString(LTypeDataPtr);
|
||||||
|
{$ELSE}
|
||||||
|
UnitName := GetUnitNameFromTypeName(ReadShortString(LTypeDataPtr));
|
||||||
|
SendUnitNameToProc(UnitName, Proc);
|
||||||
|
{$ENDIF}
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
if LTypeData^.MethodKind = mkFunction then
|
||||||
|
begin
|
||||||
|
{$IFDEF HAS_tkMethod_ParamTypeInfo}
|
||||||
|
SkipShortString(LTypeDataPtr);
|
||||||
|
UnitName := GetUnitNameFromTypeInfo(PPPTypeInfo(LTypeDataPtr)^);
|
||||||
|
Inc(LTypeDataPtr, SizeOf(PPTypeInfo));
|
||||||
|
{$ELSE}
|
||||||
|
UnitName := GetUnitNameFromTypeName(ReadShortString(LTypeDataPtr));
|
||||||
|
{$ENDIF}
|
||||||
|
SendUnitNameToProc(UnitName, Proc);
|
||||||
|
end;
|
||||||
|
|
||||||
|
{$IFDEF HAS_tkMethod_ParamTypeInfo}
|
||||||
|
if LTypeData^.ParamCount > 0 then
|
||||||
|
begin
|
||||||
|
Inc(LTypeDataPtr, SizeOf(TCallConv));
|
||||||
|
for K := 0 to LTypeData^.ParamCount-1 do
|
||||||
|
begin
|
||||||
|
UnitName := GetUnitNameFromTypeInfo(PPPTypeInfo(LTypeDataPtr)^);
|
||||||
|
SendUnitNameToProc(UnitName, Proc);
|
||||||
|
Inc(LTypeDataPtr, SizeOf(PPTypeInfo));
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
{$ENDIF}
|
||||||
|
end;
|
||||||
|
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
type
|
||||||
|
TIdBaseComponentSelectionEditor = class(TSelectionEditor)
|
||||||
|
public
|
||||||
|
procedure RequiresUnits(Proc: TGetStrProc); override;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdBaseComponentSelectionEditor.RequiresUnits(Proc: TGetStrProc);
|
||||||
|
var
|
||||||
|
Comp: TIdBaseComponent;
|
||||||
|
I: Integer;
|
||||||
|
{$IFDEF VCL_2010_OR_ABOVE}
|
||||||
|
Ctx: TRttiContext;
|
||||||
|
PropInfo: TRttiProperty;
|
||||||
|
PropValue: TValue;
|
||||||
|
{$IFDEF VCL_XE2_OR_ABOVE}
|
||||||
|
PropType: TRttiMethodType;
|
||||||
|
Param: TRttiParameter;
|
||||||
|
{$ENDIF}
|
||||||
|
{$ELSE}
|
||||||
|
PropList: PPropList;
|
||||||
|
PropCount: Integer;
|
||||||
|
PropInfo: PPropInfo;
|
||||||
|
J: Integer;
|
||||||
|
{$ENDIF}
|
||||||
|
begin
|
||||||
|
inherited RequiresUnits(Proc);
|
||||||
|
if (Designer = nil) or (Designer.Root = nil) then Exit;
|
||||||
|
|
||||||
|
for I := 0 to Designer.Root.ComponentCount - 1 do
|
||||||
|
begin
|
||||||
|
if Designer.Root.Components[i] is TIdBaseComponent then
|
||||||
|
begin
|
||||||
|
Comp := TIdBaseComponent(Designer.Root.Components[i]);
|
||||||
|
|
||||||
|
{$IFDEF VCL_2010_OR_ABOVE}
|
||||||
|
|
||||||
|
Ctx := TRttiContext.Create;
|
||||||
|
for PropInfo in Ctx.GetType(Comp.ClassType).GetProperties do
|
||||||
|
begin
|
||||||
|
// only interested in *assigned* event handlers
|
||||||
|
|
||||||
|
// NOTE: Delphi 2010 has a problem with checking the TValue.IsEmpty
|
||||||
|
// property inlined like below. It causes a "F2084 Internal Error C13394"
|
||||||
|
// compiler error. So splitting up the comparison to use a local TValue
|
||||||
|
// variable to work around that...
|
||||||
|
{
|
||||||
|
if (PropInfo.PropertyType.TypeKind = tkMethod) and
|
||||||
|
(not PropInfo.GetValue(Comp).IsEmpty) then
|
||||||
|
}
|
||||||
|
if PropInfo.PropertyType.TypeKind = tkMethod then
|
||||||
|
begin
|
||||||
|
PropValue := PropInfo.GetValue(Comp);
|
||||||
|
if not PropValue.IsEmpty then
|
||||||
|
begin
|
||||||
|
// although the System.Rtti unit was introduced in Delphi 2010,
|
||||||
|
// the TRttiInvokableType class was not added to it until XE2
|
||||||
|
{$IFDEF VCL_XE2_OR_ABOVE}
|
||||||
|
PropType := PropInfo.PropertyType as TRttiMethodType;
|
||||||
|
for Param in PropType.GetParameters do begin
|
||||||
|
SendUnitNameToProc(GetUnitNameForType(Param.ParamType), Proc);
|
||||||
|
end;
|
||||||
|
SendUnitNameToProc(GetUnitNameForType(PropType.ReturnType), Proc);
|
||||||
|
{$ELSE}
|
||||||
|
// use the System.TypInfo unit to access the parameters and return type
|
||||||
|
GetUnitNamesForMethodType(PropInfo.PropertyType.Handle, Proc);
|
||||||
|
{$ENDIF}
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{$ELSE}
|
||||||
|
|
||||||
|
PropCount := GetPropList(Comp, PropList);
|
||||||
|
if PropCount > 0 then
|
||||||
|
begin
|
||||||
|
try
|
||||||
|
for J := 0 to PropCount-1 do
|
||||||
|
begin
|
||||||
|
PropInfo := PropList^[J];
|
||||||
|
// only interested in *assigned* event handlers
|
||||||
|
if (PropInfo^.PropType^.Kind = tkMethod) and
|
||||||
|
(GetMethodProp(Comp, PropInfo).Code <> nil) then
|
||||||
|
begin
|
||||||
|
GetUnitNamesForMethodType(PropInfo^.PropType^, Proc);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
FreeMem(PropList);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{$ENDIF}
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
procedure Register;
|
||||||
|
begin
|
||||||
|
{$IFNDEF FPC}
|
||||||
|
RegisterComponents(RSRegIndyClients, [
|
||||||
|
TIdTCPClient
|
||||||
|
,TIdUDPClient
|
||||||
|
,TIdCmdTCPClient
|
||||||
|
,TIdIPMCastClient
|
||||||
|
{$IFNDEF DOTNET}
|
||||||
|
,TIdIcmpClient
|
||||||
|
,TIdTraceRoute
|
||||||
|
{$ENDIF}
|
||||||
|
]);
|
||||||
|
RegisterComponents(RSRegIndyServers, [
|
||||||
|
TIdUDPServer,
|
||||||
|
TIdCmdTCPServer,
|
||||||
|
TIdSimpleServer,
|
||||||
|
TIdTCPServer,
|
||||||
|
TIdIPMCastServer
|
||||||
|
]);
|
||||||
|
RegisterComponents(RSRegIndyIOHandlers,[
|
||||||
|
TIdIOHandlerStack
|
||||||
|
,TIdIOHandlerStream
|
||||||
|
,TIdServerIOHandlerStack
|
||||||
|
]);
|
||||||
|
RegisterComponents(RSRegIndyIntercepts, [
|
||||||
|
TIdConnectionIntercept
|
||||||
|
,TIdInterceptSimLog
|
||||||
|
,TIdInterceptThrottler
|
||||||
|
,TIdLogDebug
|
||||||
|
,TIdLogEvent
|
||||||
|
,TIdLogFile
|
||||||
|
,TIdLogStream
|
||||||
|
]);
|
||||||
|
|
||||||
|
{$IFDEF FMX}
|
||||||
|
// RLebeau 8/1/2011 - FireMonkey has problems resolving references to
|
||||||
|
// TIdAntiFreeze correctly because it is implemented in a design-time
|
||||||
|
// package and not a run-time package. Until we can fix that properly,
|
||||||
|
// we'll group TIdAntiFreeze with TControl so the IDE can filter out
|
||||||
|
// TIdAntiFreeze from appearing at design-time in FireMoney projects.
|
||||||
|
// Users will have to instantiate TIdAntiFreeze in code. This does not
|
||||||
|
// affect VCL projects.
|
||||||
|
GroupDescendentsWith(TIdAntiFreeze, TControl);
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
RegisterComponents(RSRegIndyMisc, [
|
||||||
|
TIdSocksInfo,
|
||||||
|
TIdAntiFreeze,
|
||||||
|
TIdSchedulerOfThreadDefault,
|
||||||
|
TIdSchedulerOfThreadPool,
|
||||||
|
TIdThreadComponent
|
||||||
|
]);
|
||||||
|
{$ELSE}
|
||||||
|
//This is a tempoary workaround for components not fitting on the palette
|
||||||
|
//in Lazarus. Unlike Delphi, Lazarus still does not have the ability to
|
||||||
|
//scroll through a palette page.
|
||||||
|
RegisterComponents(RSRegIndyClients+CoreSuffix, [
|
||||||
|
TIdTCPClient
|
||||||
|
,TIdUDPClient
|
||||||
|
,TIdCmdTCPClient
|
||||||
|
,TIdIPMCastClient
|
||||||
|
{$IFNDEF DOTNET}
|
||||||
|
,TIdIcmpClient
|
||||||
|
,TIdTraceRoute
|
||||||
|
{$ENDIF}
|
||||||
|
]);
|
||||||
|
RegisterComponents(RSRegIndyServers+CoreSuffix, [
|
||||||
|
TIdUDPServer,
|
||||||
|
TIdCmdTCPServer,
|
||||||
|
TIdSimpleServer,
|
||||||
|
TIdTCPServer,
|
||||||
|
TIdIPMCastServer
|
||||||
|
]);
|
||||||
|
RegisterComponents(RSRegIndyIOHandlers+CoreSuffix,[
|
||||||
|
TIdIOHandlerStack
|
||||||
|
,TIdIOHandlerStream
|
||||||
|
,TIdServerIOHandlerStack
|
||||||
|
]);
|
||||||
|
RegisterComponents(RSRegIndyIntercepts+CoreSuffix, [
|
||||||
|
TIdConnectionIntercept
|
||||||
|
,TIdInterceptSimLog
|
||||||
|
,TIdInterceptThrottler
|
||||||
|
,TIdLogDebug
|
||||||
|
,TIdLogEvent
|
||||||
|
,TIdLogFile
|
||||||
|
,TIdLogStream
|
||||||
|
]);
|
||||||
|
RegisterComponents(RSRegIndyMisc+CoreSuffix, [
|
||||||
|
TIdSocksInfo,
|
||||||
|
TIdAntiFreeze,
|
||||||
|
TIdSchedulerOfThreadDefault,
|
||||||
|
TIdSchedulerOfThreadPool,
|
||||||
|
TIdThreadComponent
|
||||||
|
]);
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
{$IFDEF HAS_TSelectionEditor}
|
||||||
|
RegisterSelectionEditor(TIdBaseComponent, TIdBaseComponentSelectionEditor);
|
||||||
|
{$ENDIF}
|
||||||
|
end;
|
||||||
|
|
||||||
|
{$IFDEF FPC}
|
||||||
|
initialization
|
||||||
|
{$i IdRegisterCore.lrs}
|
||||||
|
{$ENDIF}
|
||||||
|
end.
|
|
@ -0,0 +1,409 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.27 2/3/05 12:16:46 AM RLebeau
|
||||||
|
Bug fix for UpdateText()
|
||||||
|
|
||||||
|
Rev 1.25 1/15/2005 6:02:02 PM JPMugaas
|
||||||
|
These should compile again.
|
||||||
|
|
||||||
|
Rev 1.24 1/15/05 2:03:20 PM RLebeau
|
||||||
|
Added AIgnore parameter to TIdReplies.Find()
|
||||||
|
|
||||||
|
Updated TIdReply.SetNumericCode() to call SetCode() rather than assigning the
|
||||||
|
FCode member directly.
|
||||||
|
|
||||||
|
Updated TIdReply.SetCode() to call Clear() before assigning the FCode member.
|
||||||
|
|
||||||
|
Updated TIdReplies.UpdateText() to ignore the TIdReply that was passed in
|
||||||
|
when looking for a TIdReply to extract Text from.
|
||||||
|
|
||||||
|
Rev 1.23 12/29/04 1:36:44 PM RLebeau
|
||||||
|
Bug fix for when descendant constructors are called twice during creation
|
||||||
|
|
||||||
|
Rev 1.22 10/26/2004 8:43:00 PM JPMugaas
|
||||||
|
Should be more portable with new references to TIdStrings and TIdStringList.
|
||||||
|
|
||||||
|
Rev 1.21 6/11/2004 8:48:24 AM DSiders
|
||||||
|
Added "Do not Localize" comments.
|
||||||
|
|
||||||
|
Rev 1.20 2004.03.01 7:10:34 PM czhower
|
||||||
|
Change for .net compat
|
||||||
|
|
||||||
|
Rev 1.19 2004.03.01 5:12:34 PM czhower
|
||||||
|
-Bug fix for shutdown of servers when connections still existed (AV)
|
||||||
|
-Implicit HELP support in CMDserver
|
||||||
|
-Several command handler bugs
|
||||||
|
-Additional command handler functionality.
|
||||||
|
|
||||||
|
Rev 1.18 2004.02.29 8:16:54 PM czhower
|
||||||
|
Bug fix to fix AV at design time when adding reply texts to CmdTCPServer.
|
||||||
|
|
||||||
|
Rev 1.17 2004.02.03 4:17:10 PM czhower
|
||||||
|
For unit name changes.
|
||||||
|
|
||||||
|
Rev 1.16 2004.01.29 12:02:32 AM czhower
|
||||||
|
.Net constructor problem fix.
|
||||||
|
|
||||||
|
Rev 1.15 1/3/2004 8:06:20 PM JPMugaas
|
||||||
|
Bug fix: Sometimes, replies will appear twice due to the way functionality
|
||||||
|
was enherited.
|
||||||
|
|
||||||
|
Rev 1.14 1/1/2004 9:33:24 PM BGooijen
|
||||||
|
the abstract class TIdReply was created sometimes, fixed that
|
||||||
|
|
||||||
|
Rev 1.13 2003.10.18 9:33:28 PM czhower
|
||||||
|
Boatload of bug fixes to command handlers.
|
||||||
|
|
||||||
|
Rev 1.12 10/15/2003 7:49:38 PM DSiders
|
||||||
|
Added IdResourceStringsCore to implementation uses clause.
|
||||||
|
|
||||||
|
Rev 1.11 10/15/2003 7:46:42 PM DSiders
|
||||||
|
Added formatted resource string for the exception raised in
|
||||||
|
TIdReply.SetCode.
|
||||||
|
|
||||||
|
Rev 1.10 2003.09.06 1:30:30 PM czhower
|
||||||
|
Removed abstract modifier from a class method so that C++ Builder can compile
|
||||||
|
again.
|
||||||
|
|
||||||
|
Rev 1.9 2003.06.05 10:08:50 AM czhower
|
||||||
|
Extended reply mechanisms to the exception handling. Only base and RFC
|
||||||
|
completed, handing off to J Peter.
|
||||||
|
|
||||||
|
Rev 1.8 2003.05.30 10:25:56 PM czhower
|
||||||
|
Implemented IsEndMarker
|
||||||
|
|
||||||
|
Rev 1.7 2003.05.30 10:06:08 PM czhower
|
||||||
|
Changed code property mechanisms.
|
||||||
|
|
||||||
|
Rev 1.6 5/26/2003 04:29:56 PM JPMugaas
|
||||||
|
Removed GenerateReply and ParseReply. Those are now obsolete duplicate
|
||||||
|
functions in the new design.
|
||||||
|
|
||||||
|
Rev 1.5 5/26/2003 12:19:54 PM JPMugaas
|
||||||
|
|
||||||
|
Rev 1.4 2003.05.26 11:38:18 AM czhower
|
||||||
|
|
||||||
|
Rev 1.3 2003.05.25 10:23:44 AM czhower
|
||||||
|
|
||||||
|
Rev 1.2 5/20/2003 12:43:46 AM BGooijen
|
||||||
|
changeable reply types
|
||||||
|
|
||||||
|
Rev 1.1 5/19/2003 05:54:58 PM JPMugaas
|
||||||
|
|
||||||
|
Rev 1.0 5/19/2003 12:26:16 PM JPMugaas
|
||||||
|
Base class for reply format objects.
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdReply;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
{$I IdCompilerDefines.inc}
|
||||||
|
//we need to put this in Delphi mode to work
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes,
|
||||||
|
IdException;
|
||||||
|
|
||||||
|
type
|
||||||
|
TIdReplies = class;
|
||||||
|
//TODO: a streamed write only property will be registered to convert old DFMs
|
||||||
|
// into the new one for old TextCode and to ignore NumericCode which has been
|
||||||
|
// removed
|
||||||
|
TIdReply = class(TCollectionItem)
|
||||||
|
protected
|
||||||
|
FCode: string;
|
||||||
|
FFormattedReply: TStrings;
|
||||||
|
FReplyTexts: TIdReplies;
|
||||||
|
FText: TStrings;
|
||||||
|
//
|
||||||
|
procedure AssignTo(ADest: TPersistent); override;
|
||||||
|
procedure CommonInit;
|
||||||
|
function GetFormattedReplyStrings: TStrings; virtual;
|
||||||
|
function CheckIfCodeIsValid(const ACode: string): Boolean; virtual;
|
||||||
|
function GetDisplayName: string; override;
|
||||||
|
function GetFormattedReply: TStrings; virtual;
|
||||||
|
function GetNumericCode: Integer;
|
||||||
|
procedure SetCode(const AValue: string);
|
||||||
|
procedure SetFormattedReply(const AValue: TStrings); virtual; abstract;
|
||||||
|
procedure SetText(const AValue: TStrings);
|
||||||
|
procedure SetNumericCode(const AValue: Integer);
|
||||||
|
public
|
||||||
|
procedure Clear; virtual;
|
||||||
|
//Temp workaround for compiler bug
|
||||||
|
constructor Create(ACollection: TCollection); override;
|
||||||
|
constructor CreateWithReplyTexts(ACollection: TCollection; AReplyTexts: TIdReplies); virtual;
|
||||||
|
// Both creates are necessary. This base one is called by the collection editor at design time
|
||||||
|
// constructor Create(ACollection: TCollection); overload; override;
|
||||||
|
// constructor Create(ACollection: TCollection; AReplyTexts: TIdReplies); reintroduce; overload; virtual;
|
||||||
|
destructor Destroy; override;
|
||||||
|
// Is not abstract because C++ cannot compile abstract class methods
|
||||||
|
class function IsEndMarker(const ALine: string): Boolean; virtual;
|
||||||
|
procedure RaiseReplyError; virtual; abstract;
|
||||||
|
function ReplyExists: Boolean; virtual;
|
||||||
|
procedure SetReply(const ACode: Integer; const AText: string); overload; virtual;
|
||||||
|
procedure SetReply(const ACode: string; const AText: string); overload; virtual;
|
||||||
|
procedure UpdateText;
|
||||||
|
//
|
||||||
|
property FormattedReply: TStrings read GetFormattedReply write SetFormattedReply;
|
||||||
|
property NumericCode: Integer read GetNumericCode write SetNumericCode;
|
||||||
|
published
|
||||||
|
//warning: setting Code has a side-effect of calling Clear;
|
||||||
|
property Code: string read FCode write SetCode;
|
||||||
|
property Text: TStrings read FText write SetText;
|
||||||
|
end;
|
||||||
|
|
||||||
|
TIdReplyClass = class of TIdReply;
|
||||||
|
|
||||||
|
TIdReplies = class(TOwnedCollection)
|
||||||
|
protected
|
||||||
|
function GetItem(Index: Integer): TIdReply;
|
||||||
|
procedure SetItem(Index: Integer; const Value: TIdReply);
|
||||||
|
public
|
||||||
|
function Add: TIdReply; overload;
|
||||||
|
function Add(const ACode: Integer; const AText: string): TIdReply; overload;
|
||||||
|
function Add(const ACode, AText: string): TIdReply; overload;
|
||||||
|
constructor Create(AOwner: TPersistent; const AReplyClass: TIdReplyClass); reintroduce; virtual;
|
||||||
|
function Find(const ACode: string; AIgnore: TIdReply = nil): TIdReply; virtual;
|
||||||
|
procedure UpdateText(AReply: TIdReply); virtual;
|
||||||
|
//
|
||||||
|
property Items[Index: Integer]: TIdReply read GetItem write SetItem; default;
|
||||||
|
end;
|
||||||
|
|
||||||
|
TIdRepliesClass = class of TIdReplies;
|
||||||
|
EIdReplyError = class(EIdException);
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
IdGlobal, IdResourceStringsCore, SysUtils;
|
||||||
|
|
||||||
|
{ TIdReply }
|
||||||
|
|
||||||
|
procedure TIdReply.AssignTo(ADest: TPersistent);
|
||||||
|
var
|
||||||
|
LR : TIdReply;
|
||||||
|
begin
|
||||||
|
if ADest is TIdReply then begin
|
||||||
|
LR := TIdReply(ADest);
|
||||||
|
//set code first as it possibly clears the reply
|
||||||
|
LR.Code := Code;
|
||||||
|
LR.Text.Assign(Text);
|
||||||
|
end else begin
|
||||||
|
inherited AssignTo(ADest);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdReply.Clear;
|
||||||
|
begin
|
||||||
|
FText.Clear;
|
||||||
|
FCode := '';
|
||||||
|
end;
|
||||||
|
|
||||||
|
constructor TIdReply.CreateWithReplyTexts(ACollection: TCollection; AReplyTexts: TIdReplies);
|
||||||
|
begin
|
||||||
|
inherited Create(ACollection);
|
||||||
|
FReplyTexts := AReplyTexts;
|
||||||
|
CommonInit;
|
||||||
|
end;
|
||||||
|
|
||||||
|
constructor TIdReply.Create(ACollection: TCollection);
|
||||||
|
begin
|
||||||
|
inherited Create(ACollection);
|
||||||
|
CommonInit;
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TIdReply.Destroy;
|
||||||
|
begin
|
||||||
|
FreeAndNil(FText);
|
||||||
|
FreeAndNil(FFormattedReply);
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdReply.CommonInit;
|
||||||
|
begin
|
||||||
|
FFormattedReply := TStringList.Create;
|
||||||
|
FText := TStringList.Create;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdReply.GetDisplayName: string;
|
||||||
|
begin
|
||||||
|
if Text.Count > 0 then begin
|
||||||
|
Result := Code + ' ' + Text[0];
|
||||||
|
end else begin
|
||||||
|
Result := Code;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdReply.ReplyExists: Boolean;
|
||||||
|
begin
|
||||||
|
Result := Code <> '';
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdReply.SetNumericCode(const AValue: Integer);
|
||||||
|
begin
|
||||||
|
Code := IntToStr(AValue);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdReply.SetText(const AValue: TStrings);
|
||||||
|
begin
|
||||||
|
FText.Assign(AValue);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdReply.SetReply(const ACode: Integer; const AText: string);
|
||||||
|
begin
|
||||||
|
SetReply(IntToStr(ACode), AText);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdReply.GetNumericCode: Integer;
|
||||||
|
begin
|
||||||
|
Result := IndyStrToInt(Code, 0);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdReply.SetCode(const AValue: string);
|
||||||
|
var
|
||||||
|
LMatchedReply: TIdReply;
|
||||||
|
begin
|
||||||
|
if FCode <> AValue then begin
|
||||||
|
if not CheckIfCodeIsValid(AValue) then begin
|
||||||
|
raise EIdException.CreateFmt(RSReplyInvalidCode, [AValue]);
|
||||||
|
end;
|
||||||
|
// Only check for duplicates if we are in a collection. NormalReply etc are not in collections
|
||||||
|
// Also dont check FReplyTexts, as non members can be duplicates of members
|
||||||
|
if Collection <> nil then begin
|
||||||
|
LMatchedReply := TIdReplies(Collection).Find(AValue);
|
||||||
|
if Assigned(LMatchedReply) then begin
|
||||||
|
raise EIdException.CreateFmt(RSReplyCodeAlreadyExists, [AValue]);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
Clear;
|
||||||
|
FCode := AValue;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdReply.SetReply(const ACode, AText: string);
|
||||||
|
begin
|
||||||
|
Code := ACode;
|
||||||
|
FText.Text := AText;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdReply.CheckIfCodeIsValid(const ACode: string): Boolean;
|
||||||
|
begin
|
||||||
|
Result := True;
|
||||||
|
end;
|
||||||
|
|
||||||
|
class function TIdReply.IsEndMarker(const ALine: string): Boolean;
|
||||||
|
begin
|
||||||
|
Result := False;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdReply.GetFormattedReply: TStrings;
|
||||||
|
begin
|
||||||
|
// Overrides must call GetFormattedReplyStrings instead. This is just a base implementation
|
||||||
|
// This is done this way because otherwise double generations can occur if more than one
|
||||||
|
// ancestor overrides. Example: Reply--> RFC --> FTP. Calling inherited would cause both
|
||||||
|
// FTP and RFC to generate.
|
||||||
|
Result := GetFormattedReplyStrings;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdReply.GetFormattedReplyStrings: TStrings;
|
||||||
|
begin
|
||||||
|
FFormattedReply.Clear;
|
||||||
|
Result := FFormattedReply;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdReply.UpdateText;
|
||||||
|
begin
|
||||||
|
if FReplyTexts <> nil then begin
|
||||||
|
FReplyTexts.UpdateText(Self);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TIdReplies }
|
||||||
|
|
||||||
|
function TIdReplies.Add: TIdReply;
|
||||||
|
begin
|
||||||
|
Result := TIdReply(inherited Add);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdReplies.Add(const ACode: Integer; const AText: string): TIdReply;
|
||||||
|
begin
|
||||||
|
Result := Add(IntToStr(ACode), AText);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdReplies.Add(const ACode, AText: string): TIdReply;
|
||||||
|
begin
|
||||||
|
Result := Add;
|
||||||
|
try
|
||||||
|
Result.SetReply(ACode, AText);
|
||||||
|
except
|
||||||
|
FreeAndNil(Result);
|
||||||
|
raise;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
constructor TIdReplies.Create(AOwner: TPersistent; const AReplyClass: TIdReplyClass);
|
||||||
|
begin
|
||||||
|
inherited Create(AOwner, AReplyClass);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdReplies.Find(const ACode: string; AIgnore: TIdReply = nil): TIdReply;
|
||||||
|
var
|
||||||
|
i: Integer;
|
||||||
|
begin
|
||||||
|
Result := nil;
|
||||||
|
// Never return match on ''
|
||||||
|
if ACode <> '' then begin
|
||||||
|
for i := 0 to Count - 1 do begin
|
||||||
|
if Items[i].Code = ACode then begin
|
||||||
|
if not (Items[i] = AIgnore) then begin
|
||||||
|
Result := Items[i];
|
||||||
|
Exit;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdReplies.GetItem(Index: Integer): TIdReply;
|
||||||
|
begin
|
||||||
|
Result := TIdReply(inherited Items[Index]);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdReplies.SetItem(Index: Integer; const Value: TIdReply);
|
||||||
|
begin
|
||||||
|
inherited SetItem(Index, Value);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdReplies.UpdateText(AReply: TIdReply);
|
||||||
|
var
|
||||||
|
LReply: TIdReply;
|
||||||
|
begin
|
||||||
|
// If text is blank, get it from the ReplyTexts
|
||||||
|
if AReply.Text.Count = 0 then begin
|
||||||
|
// RLebeau - ignore AReply, it doesn't have any text
|
||||||
|
// to assign, or else the code wouldn't be this far
|
||||||
|
LReply := Find(AReply.Code, AReply);
|
||||||
|
if LReply <> nil then begin
|
||||||
|
AReply.Text.Assign(LReply.Text);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
|
@ -0,0 +1,312 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.29 1/15/05 2:28:28 PM RLebeau
|
||||||
|
Added local variables to TIdReplyRFC.GetFormattedReply() to reduce the number
|
||||||
|
of repeated string operations that were being performed.
|
||||||
|
|
||||||
|
Updated TIdRepliesRFC.UpdateText() to ignore the TIdReply that was passed in
|
||||||
|
when looking for a TIdReply to extract Text from.
|
||||||
|
|
||||||
|
Rev 1.28 10/26/2004 8:43:00 PM JPMugaas
|
||||||
|
Should be more portable with new references to TIdStrings and TIdStringList.
|
||||||
|
|
||||||
|
Rev 1.27 6/11/2004 8:48:28 AM DSiders
|
||||||
|
Added "Do not Localize" comments.
|
||||||
|
|
||||||
|
Rev 1.26 18/05/2004 23:17:18 CCostelloe
|
||||||
|
Bug fix
|
||||||
|
|
||||||
|
Rev 1.25 5/18/04 2:39:02 PM RLebeau
|
||||||
|
Added second constructor to TIdRepliesRFC
|
||||||
|
|
||||||
|
Rev 1.24 5/17/04 9:50:08 AM RLebeau
|
||||||
|
Changed TIdRepliesRFC constructor to use 'reintroduce' instead
|
||||||
|
|
||||||
|
Rev 1.23 5/16/04 5:12:04 PM RLebeau
|
||||||
|
Added construvtor to TIdRepliesRFC class
|
||||||
|
|
||||||
|
Rev 1.22 2004.03.01 5:12:36 PM czhower
|
||||||
|
-Bug fix for shutdown of servers when connections still existed (AV)
|
||||||
|
-Implicit HELP support in CMDserver
|
||||||
|
-Several command handler bugs
|
||||||
|
-Additional command handler functionality.
|
||||||
|
|
||||||
|
Rev 1.21 2004.02.29 8:17:20 PM czhower
|
||||||
|
Minor cosmetic changes to code.
|
||||||
|
|
||||||
|
Rev 1.20 2004.02.03 4:16:50 PM czhower
|
||||||
|
For unit name changes.
|
||||||
|
|
||||||
|
Rev 1.19 1/3/2004 8:06:18 PM JPMugaas
|
||||||
|
Bug fix: Sometimes, replies will appear twice due to the way functionality
|
||||||
|
was enherited.
|
||||||
|
|
||||||
|
Rev 1.18 2003.10.18 9:33:28 PM czhower
|
||||||
|
Boatload of bug fixes to command handlers.
|
||||||
|
|
||||||
|
Rev 1.17 9/20/2003 10:01:04 AM JPMugaas
|
||||||
|
Minor change. WIll now accept all 3 digit numbers (not just ones below 600).
|
||||||
|
The reason is that developers may want something in 600-999 range. RFC 2228
|
||||||
|
defines a 6xx reply range for protected replies.
|
||||||
|
|
||||||
|
Rev 1.16 2003.09.20 10:33:14 AM czhower
|
||||||
|
Bug fix to allow clearing code field (Return to default value)
|
||||||
|
|
||||||
|
Rev 1.15 2003.06.05 10:08:52 AM czhower
|
||||||
|
Extended reply mechanisms to the exception handling. Only base and RFC
|
||||||
|
completed, handing off to J Peter.
|
||||||
|
|
||||||
|
Rev 1.14 6/3/2003 04:09:30 PM JPMugaas
|
||||||
|
class function TIdReplyRFC.IsEndMarker(const ALine: string): Boolean had the
|
||||||
|
wrong parameters causing FTP to freeze. It probably effected other stuff.
|
||||||
|
|
||||||
|
Rev 1.13 5/30/2003 8:37:42 PM BGooijen
|
||||||
|
Changed virtual to override
|
||||||
|
|
||||||
|
Rev 1.12 2003.05.30 10:25:58 PM czhower
|
||||||
|
Implemented IsEndMarker
|
||||||
|
|
||||||
|
Rev 1.11 2003.05.30 10:06:08 PM czhower
|
||||||
|
Changed code property mechanisms.
|
||||||
|
|
||||||
|
Rev 1.10 2003.05.26 10:48:12 PM czhower
|
||||||
|
1) Removed deprecated code.
|
||||||
|
2) Removed POP3 bastardizations as they are now in IdReplyPOP3.
|
||||||
|
|
||||||
|
Rev 1.9 5/26/2003 12:19:52 PM JPMugaas
|
||||||
|
|
||||||
|
Rev 1.8 2003.05.26 11:38:20 AM czhower
|
||||||
|
|
||||||
|
Rev 1.7 5/25/2003 03:16:54 AM JPMugaas
|
||||||
|
|
||||||
|
Rev 1.6 2003.05.25 10:23:46 AM czhower
|
||||||
|
|
||||||
|
Rev 1.5 5/21/2003 08:43:38 PM JPMugaas
|
||||||
|
Overridable hook for the SMTP Reply object.
|
||||||
|
|
||||||
|
Rev 1.4 5/20/2003 12:43:48 AM BGooijen
|
||||||
|
changeable reply types
|
||||||
|
|
||||||
|
Rev 1.3 5/19/2003 12:26:50 PM JPMugaas
|
||||||
|
Now uses base class.
|
||||||
|
|
||||||
|
Rev 1.2 11/05/2003 23:29:04 CCostelloe
|
||||||
|
IMAP-specific code moved up to TIdIMAP4.pas
|
||||||
|
|
||||||
|
Rev 1.1 11/14/2002 02:51:54 PM JPMugaas
|
||||||
|
Added FormatType property. If it is rfIndentMidLines, it will accept
|
||||||
|
properly parse reply lines that begin with a space. Setting this to
|
||||||
|
rfIndentMidLines will also cause the reply object to generate lines that
|
||||||
|
start with a space if the Text.Line starts with a space. This should
|
||||||
|
accommodate the FTP MLSD and FEAT commands on both the client and server.
|
||||||
|
|
||||||
|
Rev 1.0 11/13/2002 08:45:50 AM JPMugaas
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdReplyRFC;
|
||||||
|
|
||||||
|
interface
|
||||||
|
{$I IdCompilerDefines.inc}
|
||||||
|
uses
|
||||||
|
Classes,
|
||||||
|
IdReply;
|
||||||
|
|
||||||
|
type
|
||||||
|
TIdReplyRFC = class(TIdReply)
|
||||||
|
protected
|
||||||
|
procedure AssignTo(ADest: TPersistent); override;
|
||||||
|
function CheckIfCodeIsValid(const ACode: string): Boolean; override;
|
||||||
|
function GetFormattedReply: TStrings; override;
|
||||||
|
procedure SetFormattedReply(const AValue: TStrings); override;
|
||||||
|
public
|
||||||
|
class function IsEndMarker(const ALine: string): Boolean; override;
|
||||||
|
procedure RaiseReplyError; override;
|
||||||
|
function ReplyExists: Boolean; override;
|
||||||
|
end;
|
||||||
|
|
||||||
|
TIdRepliesRFC = class(TIdReplies)
|
||||||
|
public
|
||||||
|
constructor Create(AOwner: TPersistent); reintroduce; overload; virtual;
|
||||||
|
constructor Create(AOwner: TPersistent; const AReplyClass: TIdReplyClass); overload; override;
|
||||||
|
procedure UpdateText(AReply: TIdReply); override;
|
||||||
|
end;
|
||||||
|
|
||||||
|
// This exception is for protocol errors such as 404 HTTP error and also
|
||||||
|
// SendCmd / GetResponse
|
||||||
|
EIdReplyRFCError = class(EIdReplyError)
|
||||||
|
protected
|
||||||
|
FErrorCode: Integer;
|
||||||
|
public
|
||||||
|
// Params must be in this order to avoid conflict with CreateHelp
|
||||||
|
// constructor in CBuilder as CB does not differentiate constructors
|
||||||
|
// by name as Delphi does
|
||||||
|
constructor CreateError(const AErrorCode: Integer;
|
||||||
|
const AReplyMessage: string); reintroduce; virtual;
|
||||||
|
//
|
||||||
|
property ErrorCode: Integer read FErrorCode;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
IdGlobal,
|
||||||
|
SysUtils;
|
||||||
|
|
||||||
|
{ TIdReplyRFC }
|
||||||
|
|
||||||
|
procedure TIdReplyRFC.AssignTo(ADest: TPersistent);
|
||||||
|
var
|
||||||
|
LR: TIdReplyRFC;
|
||||||
|
begin
|
||||||
|
if ADest is TIdReplyRFC then begin
|
||||||
|
LR := TIdReplyRFC(ADest);
|
||||||
|
//set code first as it possibly clears the reply
|
||||||
|
LR.NumericCode := NumericCode;
|
||||||
|
LR.Text.Assign(Text);
|
||||||
|
end else begin
|
||||||
|
inherited AssignTo(ADest);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdReplyRFC.CheckIfCodeIsValid(const ACode: string): Boolean;
|
||||||
|
var
|
||||||
|
LCode: Integer;
|
||||||
|
begin
|
||||||
|
LCode := IndyStrToInt(ACode, 0);
|
||||||
|
{Replaced 600 with 999 because some developers may want 6xx, 7xx, and 8xx reply
|
||||||
|
codes for their protocols. It also turns out that RFC 2228 defines 6xx reply codes.
|
||||||
|
|
||||||
|
From RFC 2228
|
||||||
|
|
||||||
|
A new class of reply types (6yz) is also introduced for protected
|
||||||
|
replies.
|
||||||
|
}
|
||||||
|
Result := ((LCode >= 100) and (LCode < 1000)) or (Trim(ACode) = '');
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdReplyRFC.GetFormattedReply: TStrings;
|
||||||
|
var
|
||||||
|
I, LCode: Integer;
|
||||||
|
LCodeStr: String;
|
||||||
|
begin
|
||||||
|
Result := GetFormattedReplyStrings;
|
||||||
|
LCode := NumericCode;
|
||||||
|
if LCode > 0 then begin
|
||||||
|
LCodeStr := IntToStr(LCode);
|
||||||
|
if Text.Count > 0 then begin
|
||||||
|
for I := 0 to Text.Count - 1 do begin
|
||||||
|
if I < Text.Count - 1 then begin
|
||||||
|
Result.Add(LCodeStr + '-' + Text[I]);
|
||||||
|
end else begin
|
||||||
|
Result.Add(LCodeStr + ' ' + Text[I]);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end else begin
|
||||||
|
Result.Add(LCodeStr);
|
||||||
|
end;
|
||||||
|
end else if FText.Count > 0 then begin
|
||||||
|
Result.AddStrings(FText);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
class function TIdReplyRFC.IsEndMarker(const ALine: string): Boolean;
|
||||||
|
begin
|
||||||
|
if Length(ALine) >= 4 then begin
|
||||||
|
Result := ALine[4] = ' ';
|
||||||
|
end else begin
|
||||||
|
Result := True;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdReplyRFC.RaiseReplyError;
|
||||||
|
begin
|
||||||
|
raise EIdReplyRFCError.CreateError(NumericCode, Text.Text);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TIdReplyRFC.ReplyExists: Boolean;
|
||||||
|
begin
|
||||||
|
Result := (NumericCode > 0) or (FText.Count > 0);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdReplyRFC.SetFormattedReply(const AValue: TStrings);
|
||||||
|
// Just parse and put in items, no need to store after parse
|
||||||
|
var
|
||||||
|
i: Integer;
|
||||||
|
s: string;
|
||||||
|
begin
|
||||||
|
Clear;
|
||||||
|
if AValue.Count > 0 then begin
|
||||||
|
s := Trim(Copy(AValue[0], 1, 3));
|
||||||
|
Code := s;
|
||||||
|
for i := 0 to AValue.Count - 1 do begin
|
||||||
|
Text.Add(Copy(AValue[i], 5, MaxInt));
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ EIdReplyRFCError }
|
||||||
|
|
||||||
|
constructor EIdReplyRFCError.CreateError(const AErrorCode: Integer;
|
||||||
|
const AReplyMessage: string);
|
||||||
|
begin
|
||||||
|
inherited Create(AReplyMessage);
|
||||||
|
FErrorCode := AErrorCode;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TIdReplies }
|
||||||
|
|
||||||
|
constructor TIdRepliesRFC.Create(AOwner: TPersistent);
|
||||||
|
begin
|
||||||
|
inherited Create(AOwner, TIdReplyRFC);
|
||||||
|
end;
|
||||||
|
|
||||||
|
constructor TIdRepliesRFC.Create(AOwner: TPersistent; const AReplyClass: TIdReplyClass);
|
||||||
|
begin
|
||||||
|
inherited Create(AOwner, AReplyClass);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdRepliesRFC.UpdateText(AReply: TIdReply);
|
||||||
|
var
|
||||||
|
LGenericNumCode: Integer;
|
||||||
|
LReply: TIdReply;
|
||||||
|
begin
|
||||||
|
inherited UpdateText(AReply);
|
||||||
|
// If text is still blank after inherited see if we can find a generic version
|
||||||
|
if AReply.Text.Count = 0 then begin
|
||||||
|
LGenericNumCode := (AReply.NumericCode div 100) * 100;
|
||||||
|
// RLebeau - in cases where the AReply.Code is the same as the
|
||||||
|
// generic code, ignore the AReply as it doesn't have any text
|
||||||
|
// to assign, or else the code wouldn't be this far
|
||||||
|
LReply := Find(IntToStr(LGenericNumCode), AReply);
|
||||||
|
if LReply = nil then begin
|
||||||
|
// If no generic was found, then use defaults.
|
||||||
|
case LGenericNumCode of
|
||||||
|
100: AReply.Text.Text := 'Information'; {do not localize}
|
||||||
|
200: AReply.Text.Text := 'Ok'; {do not localize}
|
||||||
|
300: AReply.Text.Text := 'Temporary Error'; {do not localize}
|
||||||
|
400: AReply.Text.Text := 'Permanent Error'; {do not localize}
|
||||||
|
500: AReply.Text.Text := 'Unknown Internal Error'; {do not localize}
|
||||||
|
end;
|
||||||
|
end else begin
|
||||||
|
AReply.Text.Assign(LReply.Text);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
|
@ -0,0 +1,288 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.5 12/2/2004 9:26:44 PM JPMugaas
|
||||||
|
Bug fix.
|
||||||
|
|
||||||
|
Rev 1.4 11/11/2004 10:25:24 PM JPMugaas
|
||||||
|
Added OpenProxy and CloseProxy so you can do RecvFrom and SendTo functions
|
||||||
|
from the UDP client with SOCKS. You must call OpenProxy before using
|
||||||
|
RecvFrom or SendTo. When you are finished, you must use CloseProxy to close
|
||||||
|
any connection to the Proxy. Connect and disconnect also call OpenProxy and
|
||||||
|
CloseProxy.
|
||||||
|
|
||||||
|
Rev 1.3 11/11/2004 3:42:52 AM JPMugaas
|
||||||
|
Moved strings into RS. Socks will now raise an exception if you attempt to
|
||||||
|
use SOCKS4 and SOCKS4A with UDP. Those protocol versions do not support UDP
|
||||||
|
at all.
|
||||||
|
|
||||||
|
Rev 1.2 2004.05.20 11:39:12 AM czhower
|
||||||
|
IdStreamVCL
|
||||||
|
|
||||||
|
Rev 1.1 6/4/2004 5:13:26 PM SGrobety
|
||||||
|
EIdMaxCaptureLineExceeded message string
|
||||||
|
|
||||||
|
Rev 1.0 2004.02.03 4:19:50 PM czhower
|
||||||
|
Rename
|
||||||
|
|
||||||
|
Rev 1.15 10/24/2003 4:21:56 PM DSiders
|
||||||
|
Addes resource string for stream read exception.
|
||||||
|
|
||||||
|
Rev 1.14 2003.10.16 11:25:22 AM czhower
|
||||||
|
Added missing ;
|
||||||
|
|
||||||
|
Rev 1.13 10/15/2003 11:11:06 PM DSiders
|
||||||
|
Added resource srting for exception raised in TIdTCPServer.SetScheduler.
|
||||||
|
|
||||||
|
Rev 1.12 10/15/2003 11:03:00 PM DSiders
|
||||||
|
Added resource string for circular links from transparent proxy.
|
||||||
|
Corrected spelling errors.
|
||||||
|
|
||||||
|
Rev 1.11 10/15/2003 10:41:34 PM DSiders
|
||||||
|
Added resource strings for TIdStream and TIdStreamProxy exceptions.
|
||||||
|
|
||||||
|
Rev 1.10 10/15/2003 8:48:56 PM DSiders
|
||||||
|
Added resource strings for exceptions raised when setting thread component
|
||||||
|
properties.
|
||||||
|
|
||||||
|
Rev 1.9 10/15/2003 8:35:28 PM DSiders
|
||||||
|
Added resource string for exception raised in TIdSchedulerOfThread.NewYarn.
|
||||||
|
|
||||||
|
Rev 1.8 10/15/2003 8:04:26 PM DSiders
|
||||||
|
Added resource strings for exceptions raised in TIdLogFile, TIdReply, and
|
||||||
|
TIdIOHandler.
|
||||||
|
|
||||||
|
Rev 1.7 10/15/2003 1:03:42 PM DSiders
|
||||||
|
Created resource strings for TIdBuffer.Find exceptions.
|
||||||
|
|
||||||
|
Rev 1.6 2003.10.14 1:26:44 PM czhower
|
||||||
|
Uupdates + Intercept support
|
||||||
|
|
||||||
|
Rev 1.5 10/1/2003 10:49:02 PM GGrieve
|
||||||
|
Rework buffer for Octane Compability
|
||||||
|
|
||||||
|
Rev 1.4 7/1/2003 8:32:32 PM BGooijen
|
||||||
|
Added RSFibersNotSupported
|
||||||
|
|
||||||
|
Rev 1.3 7/1/2003 02:31:34 PM JPMugaas
|
||||||
|
Message for invalid IP address.
|
||||||
|
|
||||||
|
Rev 1.2 5/14/2003 6:40:22 PM BGooijen
|
||||||
|
RS for transparent proxy
|
||||||
|
|
||||||
|
Rev 1.1 1/17/2003 05:06:04 PM JPMugaas
|
||||||
|
Exceptions for scheduler string.
|
||||||
|
|
||||||
|
Rev 1.0 11/13/2002 08:42:02 AM JPMugaas
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdResourceStringsCore;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
{$i IdCompilerDefines.inc}
|
||||||
|
|
||||||
|
resourcestring
|
||||||
|
RSNoBindingsSpecified = 'No bindings specified.';
|
||||||
|
RSCannotAllocateSocket = 'Cannot allocate socket.';
|
||||||
|
RSSocksUDPNotSupported = 'UDP is not support in this SOCKS version.';
|
||||||
|
RSSocksRequestFailed = 'Request rejected or failed.';
|
||||||
|
RSSocksRequestServerFailed = 'Request rejected because SOCKS server cannot connect.';
|
||||||
|
RSSocksRequestIdentFailed = 'Request rejected because the client program and identd report different user-ids.';
|
||||||
|
RSSocksUnknownError = 'Unknown socks error.';
|
||||||
|
RSSocksServerRespondError = 'Socks server did not respond.';
|
||||||
|
RSSocksAuthMethodError = 'Invalid socks authentication method.';
|
||||||
|
RSSocksAuthError = 'Authentication error to socks server.';
|
||||||
|
RSSocksServerGeneralError = 'General SOCKS server failure.';
|
||||||
|
RSSocksServerPermissionError = 'Connection not allowed by ruleset.';
|
||||||
|
RSSocksServerNetUnreachableError = 'Network unreachable.';
|
||||||
|
RSSocksServerHostUnreachableError = 'Host unreachable.';
|
||||||
|
RSSocksServerConnectionRefusedError = 'Connection refused.';
|
||||||
|
RSSocksServerTTLExpiredError = 'TTL expired.';
|
||||||
|
RSSocksServerCommandError = 'Command not supported.';
|
||||||
|
RSSocksServerAddressError = 'Address type not supported.';
|
||||||
|
RSInvalidIPAddress = 'Invalid IP Address';
|
||||||
|
RSInterceptCircularLink = '%s: Circular links are not allowed';
|
||||||
|
|
||||||
|
RSNotEnoughDataInBuffer = 'Not enough data in buffer. (%d/%d)';
|
||||||
|
RSTooMuchDataInBuffer = 'Too much data in buffer.';
|
||||||
|
RSCapacityTooSmall = 'Capacity cannot be smaller than Size.';
|
||||||
|
RSBufferIsEmpty = 'No bytes in buffer.';
|
||||||
|
RSBufferRangeError = 'Index out of bounds.';
|
||||||
|
|
||||||
|
RSFileNotFound = 'File "%s" not found';
|
||||||
|
RSNotConnected = 'Not Connected';
|
||||||
|
RSObjectTypeNotSupported = 'Object type not supported.';
|
||||||
|
RSIdNoDataToRead = 'No data to read.';
|
||||||
|
RSReadTimeout = 'Read timed out.';
|
||||||
|
RSReadLnWaitMaxAttemptsExceeded = 'Max line read attempts exceeded.';
|
||||||
|
RSAcceptTimeout = 'Accept timed out.';
|
||||||
|
RSReadLnMaxLineLengthExceeded = 'Max line length exceeded.';
|
||||||
|
RSRequiresLargeStream = 'Set LargeStream to True to send streams greater than 2GB';
|
||||||
|
RSDataTooLarge = 'Data is too large for stream';
|
||||||
|
RSConnectTimeout = 'Connect timed out.';
|
||||||
|
RSICMPNotEnoughtBytes = 'Not enough bytes received';
|
||||||
|
RSICMPNonEchoResponse = 'Non-echo type response received';
|
||||||
|
RSThreadTerminateAndWaitFor = 'Cannot call TerminateAndWaitFor on FreeAndTerminate threads';
|
||||||
|
RSAlreadyConnected = 'Already connected.';
|
||||||
|
RSTerminateThreadTimeout = 'Terminate Thread Timeout';
|
||||||
|
RSNoExecuteSpecified = 'No execute handler found.';
|
||||||
|
RSNoCommandHandlerFound = 'No command handler found.';
|
||||||
|
RSCannotPerformTaskWhileServerIsActive = 'Cannot perform task while server is active.';
|
||||||
|
RSThreadClassNotSpecified = 'Thread Class Not Specified.';
|
||||||
|
RSMaximumNumberOfCaptureLineExceeded = 'Maximum number of line allowed exceeded'; // S.G. 6/4/2004: IdIOHandler.DoCapture
|
||||||
|
RSNoCreateListeningThread = 'Cannot create listening thread.';
|
||||||
|
RSInterceptIsDifferent = 'The IOHandler already has a different Intercept assigned';
|
||||||
|
|
||||||
|
//scheduler
|
||||||
|
RSchedMaxThreadEx = 'The maximum number of threads for this scheduler is exceeded.';
|
||||||
|
//transparent proxy
|
||||||
|
RSTransparentProxyCannotBind = 'Transparent proxy cannot bind.';
|
||||||
|
RSTransparentProxyCanNotSupportUDP = 'UDP Not supported by this proxy.';
|
||||||
|
//Fibers
|
||||||
|
RSFibersNotSupported = 'Fibers are not supported on this system.';
|
||||||
|
// TIdICMPCast
|
||||||
|
RSIPMCastInvalidMulticastAddress = 'The supplied IP address is not a valid multicast address [224.0.0.0 to 239.255.255.255].';
|
||||||
|
RSIPMCastNotSupportedOnWin32 = 'This function is not supported on Win32.';
|
||||||
|
RSIPMCastReceiveError0 = 'IP Broadcast Receive Error = 0.';
|
||||||
|
|
||||||
|
// Log strings
|
||||||
|
RSLogConnected = 'Connected.';
|
||||||
|
RSLogDisconnected = 'Disconnected.';
|
||||||
|
RSLogEOL = '<EOL>'; // End of Line
|
||||||
|
RSLogCR = '<CR>'; // Carriage Return
|
||||||
|
RSLogLF = '<LF>'; // Line feed
|
||||||
|
RSLogRecv = 'Recv '; // Receive
|
||||||
|
RSLogSent = 'Sent '; // Send
|
||||||
|
RSLogStat = 'Stat '; // Status
|
||||||
|
|
||||||
|
RSLogFileAlreadyOpen = 'Unable to set Filename while log file is open.';
|
||||||
|
|
||||||
|
RSBufferMissingTerminator = 'Buffer terminator must be specified.';
|
||||||
|
RSBufferInvalidStartPos = 'Buffer start position is invalid.';
|
||||||
|
|
||||||
|
RSIOHandlerCannotChange = 'Cannot change a connected IOHandler.';
|
||||||
|
RSIOHandlerTypeNotInstalled = 'No IOHandler of type %s is installed.';
|
||||||
|
|
||||||
|
RSReplyInvalidCode = 'Reply Code is not valid: %s';
|
||||||
|
RSReplyCodeAlreadyExists = 'Reply Code already exists: %s';
|
||||||
|
|
||||||
|
RSThreadSchedulerThreadRequired = 'Thread must be specified for the scheduler.';
|
||||||
|
RSNoOnExecute = 'You must have an OnExecute event.';
|
||||||
|
RSThreadComponentLoopAlreadyRunning = 'Cannot set Loop property when the Thread is already running.';
|
||||||
|
RSThreadComponentThreadNameAlreadyRunning = 'Cannot set ThreadName when the Thread is already running.';
|
||||||
|
|
||||||
|
RSStreamProxyNoStack = 'A Stack has not been created for converting the data type.';
|
||||||
|
|
||||||
|
RSTransparentProxyCyclic = 'Transparent Proxy Cyclic error.';
|
||||||
|
|
||||||
|
RSTCPServerSchedulerAlreadyActive = 'Cannot change the scheduler while the server is Active.';
|
||||||
|
RSUDPMustUseProxyOpen = 'You must use proxyOpen';
|
||||||
|
|
||||||
|
//ICMP stuff
|
||||||
|
RSICMPTimeout = 'Timeout';
|
||||||
|
//Destination Address -3
|
||||||
|
RSICMPNetUnreachable = 'net unreachable;';
|
||||||
|
RSICMPHostUnreachable = 'host unreachable;';
|
||||||
|
RSICMPProtUnreachable = 'protocol unreachable;';
|
||||||
|
RSICMPPortUnreachable = 'Port Unreachable';
|
||||||
|
RSICMPFragmentNeeded = 'Fragmentation Needed and Don''t Fragment was Set';
|
||||||
|
RSICMPSourceRouteFailed = 'Source Route Failed';
|
||||||
|
RSICMPDestNetUnknown = 'Destination Network Unknown';
|
||||||
|
RSICMPDestHostUnknown = 'Destination Host Unknown';
|
||||||
|
RSICMPSourceIsolated = 'Source Host Isolated';
|
||||||
|
RSICMPDestNetProhibitted = 'Communication with Destination Network is Administratively Prohibited';
|
||||||
|
RSICMPDestHostProhibitted = 'Communication with Destination Host is Administratively Prohibited';
|
||||||
|
RSICMPTOSNetUnreach = 'Destination Network Unreachable for Type of Service';
|
||||||
|
RSICMPTOSHostUnreach = 'Destination Host Unreachable for Type of Service';
|
||||||
|
RSICMPAdminProhibitted = 'Communication Administratively Prohibited';
|
||||||
|
RSICMPHostPrecViolation = 'Host Precedence Violation';
|
||||||
|
RSICMPPrecedenceCutoffInEffect = 'Precedence cutoff in effect';
|
||||||
|
//for IPv6
|
||||||
|
RSICMPNoRouteToDest = 'no route to destination';
|
||||||
|
RSICMPAAdminDestProhibitted = 'communication with destination administratively prohibited';
|
||||||
|
RSICMPSourceFilterFailed = 'source address failed ingress/egress policy';
|
||||||
|
RSICMPRejectRoutToDest = 'reject route to destination';
|
||||||
|
// Destination Address - 11
|
||||||
|
RSICMPTTLExceeded = 'time to live exceeded in transit';
|
||||||
|
RSICMPHopLimitExceeded = 'hop limit exceeded in transit';
|
||||||
|
RSICMPFragAsmExceeded = 'fragment reassembly time exceeded.';
|
||||||
|
//Parameter Problem - 12
|
||||||
|
RSICMPParamError = 'Parameter Problem (offset %d)';
|
||||||
|
//IPv6
|
||||||
|
RSICMPParamHeader = 'erroneous header field encountered (offset %d)';
|
||||||
|
RSICMPParamNextHeader = 'unrecognized Next Header type encountered (offset %d)';
|
||||||
|
RSICMPUnrecognizedOpt = 'unrecognized IPv6 option encountered (offset %d)';
|
||||||
|
//Source Quench Message -4
|
||||||
|
RSICMPSourceQuenchMsg = 'Source Quench Message';
|
||||||
|
//Redirect Message
|
||||||
|
RSICMPRedirNet = 'Redirect datagrams for the Network.';
|
||||||
|
RSICMPRedirHost = 'Redirect datagrams for the Host.';
|
||||||
|
RSICMPRedirTOSNet = 'Redirect datagrams for the Type of Service and Network.';
|
||||||
|
RSICMPRedirTOSHost = 'Redirect datagrams for the Type of Service and Host.';
|
||||||
|
//echo
|
||||||
|
RSICMPEcho = 'Echo';
|
||||||
|
//timestamp
|
||||||
|
RSICMPTimeStamp = 'Timestamp';
|
||||||
|
//information request
|
||||||
|
RSICMPInfoRequest = 'Information Request';
|
||||||
|
//mask request
|
||||||
|
RSICMPMaskRequest = 'Address Mask Request';
|
||||||
|
// Traceroute
|
||||||
|
RSICMPTracePacketForwarded = 'Outbound Packet successfully forwarded';
|
||||||
|
RSICMPTraceNoRoute = 'No route for Outbound Packet; packet discarded';
|
||||||
|
//conversion errors
|
||||||
|
RSICMPConvUnknownUnspecError = 'Unknown/unspecified error';
|
||||||
|
RSICMPConvDontConvOptPresent = 'Don''t Convert option present';
|
||||||
|
RSICMPConvUnknownMandOptPresent = 'Unknown mandatory option present';
|
||||||
|
RSICMPConvKnownUnsupportedOptionPresent = 'Known unsupported option present';
|
||||||
|
RSICMPConvUnsupportedTransportProtocol = 'Unsupported transport protocol';
|
||||||
|
RSICMPConvOverallLengthExceeded = 'Overall length exceeded';
|
||||||
|
RSICMPConvIPHeaderLengthExceeded = 'IP header length exceeded';
|
||||||
|
RSICMPConvTransportProtocol_255 = 'Transport protocol > 255';
|
||||||
|
RSICMPConvPortConversionOutOfRange = 'Port conversion out of range';
|
||||||
|
RSICMPConvTransportHeaderLengthExceeded = 'Transport header length exceeded';
|
||||||
|
RSICMPConv32BitRolloverMissingAndACKSet = '32 Bit Rollover missing and ACK set';
|
||||||
|
RSICMPConvUnknownMandatoryTransportOptionPresent = 'Unknown mandatory transport option present';
|
||||||
|
//mobile host redirect
|
||||||
|
RSICMPMobileHostRedirect = 'Mobile Host Redirect';
|
||||||
|
//IPv6 - Where are you
|
||||||
|
RSICMPIPv6WhereAreYou = 'IPv6 Where-Are-You';
|
||||||
|
//IPv6 - I am here
|
||||||
|
RSICMPIPv6IAmHere = 'IPv6 I-Am-Here';
|
||||||
|
// Mobile Regestration request
|
||||||
|
RSICMPMobReg = 'Mobile Registration Request';
|
||||||
|
//Skip
|
||||||
|
RSICMPSKIP = 'SKIP';
|
||||||
|
//Security
|
||||||
|
RSICMPSecBadSPI = 'Bad SPI';
|
||||||
|
RSICMPSecAuthenticationFailed = 'Authentication Failed';
|
||||||
|
RSICMPSecDecompressionFailed = 'Decompression Failed';
|
||||||
|
RSICMPSecDecryptionFailed = 'Decryption Failed';
|
||||||
|
RSICMPSecNeedAuthentication = 'Need Authentication';
|
||||||
|
RSICMPSecNeedAuthorization = 'Need Authorization';
|
||||||
|
//IPv6 Packet Too Big
|
||||||
|
RSICMPPacketTooBig = 'Packet Too Big (MTU = %d)';
|
||||||
|
{ TIdCustomIcmpClient }
|
||||||
|
|
||||||
|
// TIdSimpleServer
|
||||||
|
RSCannotUseNonSocketIOHandler = 'Cannot use a non-socket IOHandler';
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
end.
|
|
@ -0,0 +1,195 @@
|
||||||
|
{
|
||||||
|
$Project$
|
||||||
|
$Workfile$
|
||||||
|
$Revision$
|
||||||
|
$DateUTC$
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
This file is part of the Indy (Internet Direct) project, and is offered
|
||||||
|
under the dual-licensing agreement described on the Indy website.
|
||||||
|
(http://www.indyproject.org/)
|
||||||
|
|
||||||
|
Copyright:
|
||||||
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||||||
|
}
|
||||||
|
{
|
||||||
|
$Log$
|
||||||
|
}
|
||||||
|
{
|
||||||
|
Rev 1.14 4/8/2004 11:55:30 AM BGooijen
|
||||||
|
Fix for D5
|
||||||
|
|
||||||
|
Rev 1.13 2004.03.01 5:12:38 PM czhower
|
||||||
|
-Bug fix for shutdown of servers when connections still existed (AV)
|
||||||
|
-Implicit HELP support in CMDserver
|
||||||
|
-Several command handler bugs
|
||||||
|
-Additional command handler functionality.
|
||||||
|
|
||||||
|
Rev 1.12 2004.01.20 10:03:30 PM czhower
|
||||||
|
InitComponent
|
||||||
|
|
||||||
|
Rev 1.11 2003.10.21 12:18:58 AM czhower
|
||||||
|
TIdTask support and fiber bug fixes.
|
||||||
|
|
||||||
|
Rev 1.10 2003.10.14 11:18:08 PM czhower
|
||||||
|
Fix for AV on shutdown and other bugs
|
||||||
|
|
||||||
|
Rev 1.9 2003.10.11 5:49:24 PM czhower
|
||||||
|
-VCL fixes for servers
|
||||||
|
-Chain suport for servers (Super core)
|
||||||
|
-Scheduler upgrades
|
||||||
|
-Full yarn support
|
||||||
|
|
||||||
|
Rev 1.8 2003.09.19 10:11:16 PM czhower
|
||||||
|
Next stage of fiber support in servers.
|
||||||
|
|
||||||
|
Rev 1.7 2003.09.19 11:54:30 AM czhower
|
||||||
|
-Completed more features necessary for servers
|
||||||
|
-Fixed some bugs
|
||||||
|
|
||||||
|
Rev 1.6 2003.09.18 4:10:24 PM czhower
|
||||||
|
Preliminary changes for Yarn support.
|
||||||
|
|
||||||
|
Rev 1.5 3/27/2003 5:15:36 PM BGooijen
|
||||||
|
Moved some code from subclasses here, made MaxThreads published
|
||||||
|
|
||||||
|
Rev 1.4 3/13/2003 10:18:36 AM BGooijen
|
||||||
|
Server side fibers, bug fixes
|
||||||
|
|
||||||
|
Rev 1.1 1/23/2003 11:06:04 AM BGooijen
|
||||||
|
|
||||||
|
Rev 1.0 1/17/2003 03:41:48 PM JPMugaas
|
||||||
|
Scheduler base class.
|
||||||
|
}
|
||||||
|
|
||||||
|
unit IdScheduler;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
{$i IdCompilerDefines.inc}
|
||||||
|
|
||||||
|
uses
|
||||||
|
{$IFDEF HAS_UNIT_Generics_Collections}
|
||||||
|
System.Generics.Collections,
|
||||||
|
{$ELSE}
|
||||||
|
{$IFDEF VCL_XE3_OR_ABOVE}
|
||||||
|
System.Classes,
|
||||||
|
{$ELSE}
|
||||||
|
Classes,
|
||||||
|
{$ENDIF}
|
||||||
|
{$ENDIF}
|
||||||
|
IdBaseComponent, IdThread, IdTask, IdYarn, IdThreadSafe;
|
||||||
|
|
||||||
|
type
|
||||||
|
{$IFDEF HAS_GENERICS_TThreadList}
|
||||||
|
TIdYarnThreadList = TIdThreadSafeObjectList<TIdYarn>;
|
||||||
|
TIdYarnList = TList<TIdYarn>;
|
||||||
|
{$ELSE}
|
||||||
|
// TODO: flesh out to match TIdThreadSafeObjectList<TIdYarn> and TList<TIdYarn> for non-Generics compilers
|
||||||
|
TIdYarnThreadList = TIdThreadSafeObjectList;
|
||||||
|
TIdYarnList = TList;
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
TIdScheduler = class(TIdBaseComponent)
|
||||||
|
protected
|
||||||
|
FActiveYarns: TIdYarnThreadList;
|
||||||
|
//
|
||||||
|
procedure InitComponent; override;
|
||||||
|
public
|
||||||
|
destructor Destroy; override;
|
||||||
|
function AcquireYarn: TIdYarn; virtual; abstract;
|
||||||
|
procedure Init; virtual;
|
||||||
|
// ReleaseYarn is to remove a yarn from the list that has already been
|
||||||
|
// terminated (usually self termination);
|
||||||
|
procedure ReleaseYarn(AYarn: TIdYarn); virtual;
|
||||||
|
procedure StartYarn(AYarn: TIdYarn; ATask: TIdTask); virtual; abstract;
|
||||||
|
// TerminateYarn is to terminate a yarn explicitly and remove it also
|
||||||
|
procedure TerminateYarn(AYarn: TIdYarn); virtual; abstract;
|
||||||
|
procedure TerminateAllYarns; virtual;
|
||||||
|
//
|
||||||
|
property ActiveYarns: TIdYarnThreadList read FActiveYarns;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
//facilitate inlining only.
|
||||||
|
{$IFDEF DOTNET}
|
||||||
|
{$IFDEF USE_INLINE}
|
||||||
|
System.Threading,
|
||||||
|
{$ENDIF}
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF VCL_2010_OR_ABOVE}
|
||||||
|
{$IFDEF WINDOWS}
|
||||||
|
Windows,
|
||||||
|
{$ENDIF}
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF USE_VCL_POSIX}
|
||||||
|
Posix.SysSelect,
|
||||||
|
Posix.SysTime,
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF HAS_UNIT_Generics_Collections}
|
||||||
|
{$IFDEF VCL_XE3_OR_ABOVE}
|
||||||
|
System.Classes,
|
||||||
|
System.Types,
|
||||||
|
{$ELSE}
|
||||||
|
Classes,
|
||||||
|
{$ENDIF}
|
||||||
|
{$ELSE}
|
||||||
|
{$IFDEF VCL_XE3_OR_ABOVE}
|
||||||
|
System.Types, //here to facilitate inlining
|
||||||
|
{$ENDIF}
|
||||||
|
{$ENDIF}
|
||||||
|
IdGlobal, SysUtils;
|
||||||
|
|
||||||
|
{ TIdScheduler }
|
||||||
|
|
||||||
|
destructor TIdScheduler.Destroy;
|
||||||
|
begin
|
||||||
|
FreeAndNil(FActiveYarns);
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdScheduler.Init;
|
||||||
|
begin
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdScheduler.InitComponent;
|
||||||
|
begin
|
||||||
|
inherited InitComponent;
|
||||||
|
FActiveYarns := TIdYarnThreadList.Create;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdScheduler.ReleaseYarn(AYarn: TIdYarn);
|
||||||
|
begin
|
||||||
|
ActiveYarns.Remove(AYarn);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TIdScheduler.TerminateAllYarns;
|
||||||
|
var
|
||||||
|
i: Integer;
|
||||||
|
LList: TIdYarnList;
|
||||||
|
begin
|
||||||
|
Assert(FActiveYarns<>nil);
|
||||||
|
|
||||||
|
while True do begin
|
||||||
|
// Must unlock each time to allow yarns that are terminating to remove themselves from the list
|
||||||
|
LList := FActiveYarns.LockList;
|
||||||
|
try
|
||||||
|
if LList.Count = 0 then begin
|
||||||
|
Break;
|
||||||
|
end;
|
||||||
|
for i := LList.Count - 1 downto 0 do begin
|
||||||
|
TerminateYarn(
|
||||||
|
{$IFDEF HAS_GENERICS_TList}LList.Items[i]{$ELSE}TIdYarn(LList.Items[i]){$ENDIF}
|
||||||
|
);
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
FActiveYarns.UnlockList;
|
||||||
|
end;
|
||||||
|
//TODO: Put terminate timeout check back
|
||||||
|
IndySleep(500); // Wait a bit before looping to prevent thrashing
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|