* Replaced fphttpclient with indy10.

* Added compression support
This commit is contained in:
Andreas Schneider 2015-10-04 14:14:55 +02:00
parent 610c1e4108
commit b1e455022b
1330 changed files with 338589 additions and 27 deletions

View File

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

View File

@ -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;

Binary file not shown.

After

Width:  |  Height:  |  Size: 546 KiB

Binary file not shown.

BIN
indy/Core/AboutProg.res Normal file

Binary file not shown.

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.1 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.1 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.1 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.1 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.1 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.1 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.1 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.1 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.1 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.1 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.1 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.1 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.1 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.1 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.1 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.1 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.1 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.1 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.1 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.1 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 822 B

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.1 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.1 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 822 B

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.1 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.1 KiB

Binary file not shown.

Binary file not shown.

37
indy/Core/IdAbout.pas Normal file
View File

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

BIN
indy/Core/IdAbout.resources Normal file

Binary file not shown.

184
indy/Core/IdAbout.resx Normal file
View File

@ -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>

Binary file not shown.

332
indy/Core/IdAboutDotNET.pas Normal file
View File

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

Binary file not shown.

View File

@ -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>

Binary file not shown.

BIN
indy/Core/IdAboutVCL.RES Normal file

Binary file not shown.

5438
indy/Core/IdAboutVCL.lrs Normal file

File diff suppressed because it is too large Load Diff

420
indy/Core/IdAboutVCL.pas Normal file
View File

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

1
indy/Core/IdAboutVCL.rc Normal file
View File

@ -0,0 +1 @@
INDY_ABOUT_BACKGROUND BITMAP AboutBackground.bmp

1469
indy/Core/IdAboutVCL.xpm Normal file

File diff suppressed because it is too large Load Diff

161
indy/Core/IdAntiFreeze.pas Normal file
View File

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

File diff suppressed because it is too large Load Diff

1030
indy/Core/IdBuffer.pas Normal file

File diff suppressed because it is too large Load Diff

View File

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

View File

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

View File

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

File diff suppressed because it is too large Load Diff

220
indy/Core/IdContext.pas Normal file
View File

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

View File

@ -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('')]

View File

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

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

File diff suppressed because it is too large Load Diff

View File

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

View File

@ -0,0 +1,4 @@
{$IFDEF DEPRECATED_IMPL_BUG}
{$WARN SYMBOL_DEPRECATED OFF}
{$ENDIF}

View File

@ -0,0 +1,8 @@
{$IFDEF DEPRECATED_IMPL_BUG}
{$IFDEF HAS_DIRECTIVE_WARN_DEFAULT}
{$WARN SYMBOL_DEPRECATED DEFAULT}
{$ELSE}
{$WARN SYMBOL_DEPRECATED ON}
{$ENDIF}
{$ENDIF}

View File

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

View File

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

View File

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

View File

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

View File

@ -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>

View File

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

View File

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

View File

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

2695
indy/Core/IdIOHandler.pas Normal file

File diff suppressed because it is too large Load Diff

View File

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

View File

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

View File

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

293
indy/Core/IdIPAddress.pas Normal file
View File

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

257
indy/Core/IdIPMCastBase.pas Normal file
View File

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

View File

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

View File

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

824
indy/Core/IdIcmpClient.pas Normal file
View File

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

256
indy/Core/IdIntercept.pas Normal file
View File

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

View File

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

View File

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

198
indy/Core/IdLogBase.pas Normal file
View File

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

72
indy/Core/IdLogDebug.pas Normal file
View File

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

83
indy/Core/IdLogEvent.pas Normal file
View File

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

171
indy/Core/IdLogFile.pas Normal file
View File

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

118
indy/Core/IdLogStream.pas Normal file
View File

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

306
indy/Core/IdRawBase.pas Normal file
View File

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

47
indy/Core/IdRawClient.pas Normal file
View File

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

View File

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

1746
indy/Core/IdRawHeaders.pas Normal file

File diff suppressed because it is too large Load Diff

View File

@ -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
]);

View File

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

409
indy/Core/IdReply.pas Normal file
View File

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

312
indy/Core/IdReplyRFC.pas Normal file
View File

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

View File

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

195
indy/Core/IdScheduler.pas Normal file
View File

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

Some files were not shown because too many files have changed in this diff Show More