* 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.
|
||||
The Content-Type header is set automatically too.
|
||||
|
||||
`Compress[ed]`
|
||||
: Adds support for gzip,deflate compression to the connection.
|
||||
|
||||
`Call <URL>`
|
||||
: This prepares the actual call by providing the URL to be called.
|
||||
Variables in the form of `@<variablename>` are replaced accordingly.
|
||||
|
|
|
@ -24,11 +24,25 @@ interface
|
|||
|
||||
uses
|
||||
Classes, SysUtils, CustApp,
|
||||
IniFiles, fphttpclient, jsonparser, JTemplate,
|
||||
UFilter;
|
||||
IniFiles, jsonparser, JTemplate,
|
||||
UFilter, IdHTTP, IdMultipartFormData;
|
||||
|
||||
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 = class(TCustomApplication)
|
||||
|
@ -38,9 +52,10 @@ type
|
|||
FSessionIni: TIniFile;
|
||||
FTemplateName: String;
|
||||
FParser: TJTemplateParser;
|
||||
FHttp: TFPHTTPClient;
|
||||
FHttp: TRestHTTP;
|
||||
FRequest: TRestRequest;
|
||||
FContent: TStringList;
|
||||
FFormFields: TStringList;
|
||||
FFormFields: TIdMultiPartFormDataStream;
|
||||
FFilters: TFilterList;
|
||||
FBeautify: Boolean;
|
||||
FURL: String;
|
||||
|
@ -67,7 +82,8 @@ type
|
|||
implementation
|
||||
|
||||
uses
|
||||
strutils, crt, UCRTHelper, fpjson, DOM, XMLRead, XMLWrite, vinfo;
|
||||
strutils, crt, UCRTHelper, fpjson, DOM, XMLRead, XMLWrite, vinfo,
|
||||
IdCompressorZLib;
|
||||
|
||||
type
|
||||
TContentType = (ctOther, ctJSON, ctXML);
|
||||
|
@ -84,6 +100,22 @@ begin
|
|||
Result := (ContentType <> ctOther);
|
||||
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 }
|
||||
|
||||
procedure TRestemplateApplication.DoRun;
|
||||
|
@ -199,6 +231,11 @@ begin
|
|||
Result := True;
|
||||
CmdFormField(Copy(ALine, 11, Length(ALine)));
|
||||
end else
|
||||
if AnsiStartsStr('Compress', ALine) then
|
||||
begin
|
||||
Result := True;
|
||||
FHttp.Compressor := TIdCompressorZLib.Create(FHttp);
|
||||
end else
|
||||
if AnsiStartsStr('Call ', ALine) then
|
||||
begin
|
||||
Result := True;
|
||||
|
@ -255,7 +292,11 @@ begin
|
|||
varName := Trim(Copy(AHeader, 1, i - 1));
|
||||
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;
|
||||
|
||||
procedure TRestemplateApplication.CmdBasicAuth(AData: String);
|
||||
|
@ -268,8 +309,9 @@ begin
|
|||
while (i < Length(AData)) and (AData[i] <> separator) do
|
||||
Inc(i);
|
||||
|
||||
FHttp.UserName := Copy(AData, 2, i - 2);
|
||||
FHttp.Password := Copy(AData, i + 1, Length(AData));
|
||||
FRequest.Username := Copy(AData, 2, i - 2);
|
||||
FRequest.Password := Copy(AData, i + 1, Length(AData));
|
||||
FRequest.BasicAuthentication := True;
|
||||
end;
|
||||
|
||||
procedure TRestemplateApplication.CmdHighlight(AData: String);
|
||||
|
@ -278,10 +320,18 @@ begin
|
|||
end;
|
||||
|
||||
procedure TRestemplateApplication.CmdFormField(AData: String);
|
||||
var
|
||||
i: Integer;
|
||||
begin
|
||||
i := 1;
|
||||
FParser.Content := AData;
|
||||
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;
|
||||
|
||||
procedure TRestemplateApplication.ProcessCall(AURL: String);
|
||||
|
@ -304,23 +354,24 @@ begin
|
|||
if FContent.Count > 0 then
|
||||
begin
|
||||
request := TMemoryStream.Create;
|
||||
|
||||
// Variable replacement
|
||||
FParser.Content := FContent.Text;
|
||||
FParser.Replace;
|
||||
FContent.Text := FParser.Content;
|
||||
|
||||
FContent.SaveToStream(request);
|
||||
request.Position := 0;
|
||||
FHttp.RequestBody := request;
|
||||
end;
|
||||
|
||||
try
|
||||
//Special handling for formdata
|
||||
if SameText('POST', FMethod) and (FFormFields.Count > 0) then
|
||||
FHttp.FormPost(AURL, FFormFields, response)
|
||||
else
|
||||
FHttp.HTTPMethod(FMethod, AURL, response, []);
|
||||
FRequest.Prepare;
|
||||
FHttp.Request := FRequest;
|
||||
FHttp.HTTPOptions := FHttp.HTTPOptions + [hoNoProtocolErrorException];
|
||||
if FFormFields.Size > 0 then
|
||||
begin
|
||||
FHttp.Request.ContentType := FFormFields.RequestContentType;
|
||||
FHttp.Perform(FMethod, AURL, FFormFields, response);
|
||||
end else
|
||||
FHttp.Perform(FMethod, AURL, request, response);
|
||||
except
|
||||
on E: Exception do
|
||||
begin
|
||||
|
@ -331,16 +382,16 @@ begin
|
|||
end;
|
||||
|
||||
writeln;
|
||||
writeln('Status: ', FHttp.ResponseStatusCode, ' (', FHttp.ResponseStatusText, ')');
|
||||
writeln('Status: ', FHttp.ResponseCode, ' (', FHttp.ResponseText, ')');
|
||||
writeln;
|
||||
writeln('Headers:');
|
||||
for s in FHttp.ResponseHeaders do
|
||||
for s in FHttp.Response.RawHeaders do
|
||||
writeln(' ', s);
|
||||
writeln;
|
||||
|
||||
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
|
||||
case contentType of
|
||||
ctJSON:
|
||||
|
@ -474,8 +525,10 @@ begin
|
|||
|
||||
FSessionIni := TIniFile.Create(FConfigDir + 'session.ini');
|
||||
FContent := TStringList.Create;
|
||||
FFormFields := TStringList.Create;
|
||||
FHttp := TFPHTTPClient.Create(Self);
|
||||
FFormFields := TIdMultiPartFormDataStream.Create;
|
||||
FHttp := TRestHTTP.Create(nil);
|
||||
FRequest := TRestRequest.Create(FHttp);
|
||||
FRequest.RawHeaders.AddValue('User-Agent', 'Mozilla/4.0 (compatible; restemplate ' + VersionInfo.GetProductVersionString + ')');
|
||||
FFilters := TFilterList.Create;
|
||||
FParser := TJTemplateParser.Create;
|
||||
end;
|
||||
|
@ -486,6 +539,7 @@ begin
|
|||
FContent.Free;
|
||||
FFormFields.Free;
|
||||
FHttp.Free;
|
||||
//TODO Owned? FRequest.Free;
|
||||
FFilters.Free;
|
||||
FParser.Free;
|
||||
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.
|