有高手在嗎，看能不能優化有關代理程式的delphi代碼
總是有卡頓現象，請幫優化
代碼太多，3貼竟然貼不完！
坐等有人回復再貼了
uj5u.com熱心網友回復：
unit main;interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs,SyncObjs,ExtCtrls,StdCtrls, ComCtrls, ActnList, ToolWin, ImgList, Menus,
IdException,IdBaseComponent, IdComponent, IdTCPServer,IdTCPClient,
IdURI, IdIOHandlerSocket,IdStack,IdGlobal, IdIntercept,
IdThreadMgr, IdThreadMgrPool, IdAntiFreezeBase,
IdAntiFreeze, IdLogBase, IdUserAccounts,IdCoderMIME,
IdAuthentication,IdIOHandler,IdIOHandlerThrottle, IdSocks,
IdTCPConnection,IdCustomHTTPServer, IdSocketHandle,IdResourceStrings,
CheckLst, Buttons, Grids, ValEdit;
type
TMyServerInterceptLogBase = class;
TIdOnLogString=procedure (ASender: TMyServerInterceptLogBase;Remote:string;ConnectTime:string;Options:String;AData: string) of object;
TMyServerInterceptLogBase = class(TIdServerIntercept)
protected
FOnLogString:TIdOnLogString;
FLock: TCriticalSection;
FLogTime: Boolean;
FReplaceCRLF: Boolean;
FActive:boolean;
public
procedure Init; override;
function Accept(AConnection: TComponent): TIdConnectionIntercept; override;
destructor Destroy;override;
procedure DoLogWriteString(Remote:string;ConnectTime:string;Options:String;AData: string);virtual;
procedure LogWriteString(Remote:string;ConnectTime:string;Options:String;AData: string);virtual;
public
constructor Create(AOwner: TComponent); override;
published
property Active: Boolean read FActive write FActive default False;
property LogTime: Boolean read FLogTime write FLogTime default True;
property ReplaceCRLF: Boolean read FReplaceCRLF write FReplaceCRLF default true;
end;
TMyServerInterceptLogConnection = class(TIdLogBase) //BGO: i just love long class names <g>
protected
FServerInterceptLog:TMyServerInterceptLogBase;
procedure LogReceivedData(const AText: string; const AData: string);override;
procedure LogSentData(const AText: string; const AData: string); override;
procedure LogStatus(const AText: string); override;
function GetConnectionID:string;virtual;
end;
TMain_form = class(TForm)
ProxyServer: TIdTCPServer;
AntiFreeze: TIdAntiFreeze;
ThreadPool: TIdThreadMgrPool;
ImageList: TImageList;
ActionList: TActionList;
ToolBar: TToolBar;
ToolButton1: TToolButton;
ToolButton2: TToolButton;
ToolButton4: TToolButton;
Action_Start: TAction;
Action_Stop: TAction;
Action_Quit: TAction;
StatusBar: TStatusBar;
UserManager: TIdUserManager;
ToolButton5: TToolButton;
ToolButton6: TToolButton;
Action_LoadServerInfo: TAction;
Action_LoadAccount: TAction;
PopupMenu: TPopupMenu;
N1: TMenuItem;
N2: TMenuItem;
ToolButton7: TToolButton;
N3: TMenuItem;
N4: TMenuItem;
N5: TMenuItem;
N6: TMenuItem;
N7: TMenuItem;
ToolButton8: TToolButton;
Action_Intercept: TAction;
ToolButton9: TToolButton;
ToolButton10: TToolButton;
ToolButton11: TToolButton;
ToolButton3: TToolButton;
ToolButton12: TToolButton;
ToolButton13: TToolButton;
Action_About: TAction;
ToolButton14: TToolButton;
Action_Change: TAction;
PageControl: TPageControl;
TabSheet1: TTabSheet;
ClientQuery: TMemo;
TabSheet4: TTabSheet;
ChangeList: TValueListEditor;
ConnectList: TCheckListBox;
Splitter1: TSplitter;
Panel1: TPanel;
SpeedButton1: TSpeedButton;
ToolButton15: TToolButton;
procedure ProxyServerGETCommand(ASender: TIdCommand);
procedure ProxyServerCONNECTCommand(ASender: TIdCommand);
procedure Action_StartExecute(Sender: TObject);
procedure Action_StopExecute(Sender: TObject);
procedure Action_QuitExecute(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure Action_LoadServerInfoExecute(Sender: TObject);
procedure Action_LoadAccountExecute(Sender: TObject);
procedure Action_StartUpdate(Sender: TObject);
procedure Action_StopUpdate(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure ProxyServerNoCommandHandler(ASender: TIdTCPServer;
const AData: String; AThread: TIdPeerThread);
procedure Action_InterceptUpdate(Sender: TObject);
procedure Action_InterceptExecute(Sender: TObject);
procedure ProxyServerException(AThread: TIdPeerThread;
AException: Exception);
procedure Action_AboutExecute(Sender: TObject);
procedure Action_ChangeExecute(Sender: TObject);
procedure SpeedButton1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
function LoadServerInfo(filename:string):boolean;
procedure SaveServerInfo(filename:string);
function LoadUserInfo(filename:string):boolean;
procedure SaveUserInfo(filename:string);
function LoadChangeList(filename:string):boolean;
procedure SaveChangeList(filename:string);
procedure LogString(ASender: TMyServerInterceptLogBase;Remote:string;ConnectTime:string;Options:String;AData: string);
end;
procedure SendResponse(AThread:TIdPeerThread;RespNo:integer;Rawstr:string;Content:string;disconnect:boolean);
procedure ReadHeaders(LConnection:TIdTCPConnection;Headers:TStringList);
function Auther(Command:TIdCommand;Headers:TStringList;UserManager:TIdUserManager;var LoginUser:TIdUserAccount):boolean;
procedure ConnectionSet(LPeer:TIdTCPConnection;var Account:TIdUserAccount);
procedure CreateConnect(Command:TIdCommand;Headers:TStringList;var LClient:TIdTCPConnection);
procedure SendHeaders(LConnection:TIdTCPConnection;Headers:TStringList;Change:boolean);
procedure SendData(AThread:TIdPeerThread;LFrom:TIdTCPConnection;LTo:TIdTCPConnection;LSize:integer;Change:boolean);
procedure TransData(AThread:TIdPeerThread;LFrom:TIdTCPConnection;LTo:TIdTCPConnection;Change:boolean);
function ChangeData(S:string):string;
var
Main_form: TMain_form;
ServerInfo,ChangeInfo:TStringList;
implementation
{$R *.dfm}
uj5u.com熱心網友回復：
{}function TMyServerInterceptLogBase.Accept( AConnection: TComponent): TIdConnectionIntercept;
begin
Result:=TMyServerInterceptLogConnection.Create(AConnection);
TMyServerInterceptLogConnection(Result).FServerInterceptLog:=self;
TMyServerInterceptLogConnection(Result).LogTime:=FLogTime;
TMyServerInterceptLogConnection(Result).ReplaceCRLF:=FReplaceCRLF;
TMyServerInterceptLogConnection(Result).Active:=true;
TMyServerInterceptLogConnection(Result).FConnection:=AConnection;
TMyServerInterceptLogConnection(Result).Connect(AConnection);
end;
{}
constructor TMyServerInterceptLogBase.Create(Aowner:TComponent);
begin
Inherited;
FReplaceCRLF:=true;
FLogTime:=true;
FLock := TCriticalSection.Create;
end;
{}
destructor TMyServerInterceptLogBase.Destroy;
begin
FreeAndNil(FLock);
inherited;
end;
{}
procedure TMyServerInterceptLogBase.Init;
begin
end;
{}
procedure TMyServerInterceptLogBase.LogWriteString(Remote:string;ConnectTime:string;Options:String;AData: string);
begin
// if (Length(AData) > 0) then begin
FLock.Enter;
try
DoLogWriteString(Remote,ConnectTime,Options,AData);
finally
FLock.Leave;
end;
// end;
end;
{}
procedure TMyServerInterceptLogBase.DoLogWriteString(Remote:string;ConnectTime:string;Options:String;AData: string);
begin
if Assigned(FOnLogString) and FActive then begin
FOnLogString(Self,Remote,ConnectTime,Options,AData);
end;
end;
{ TMyServerInterceptLogConnection }
{}
procedure TMyServerInterceptLogConnection.LogReceivedData(const AText:string;const AData: string);
begin
FServerInterceptLog.LogWriteString(GetConnectionID,AText,'R',AData); {Do not translate}
end;
{}
procedure TMyServerInterceptLogConnection.LogSentData(const AText: string; const AData: string);
begin
FServerInterceptLog.LogWriteString(GetConnectionID,AText,'S',AData); {Do not translate}
end;
{}
procedure TMyServerInterceptLogConnection.LogStatus(const AText: string);
var
Options:String;
begin
if AnsiSameText(Atext,RSLogConnected) then begin
Options:='C';
end else begin
if AnsiSameText(AText,RSLogDisconnected) then begin
Options:='D';
end else begin
Options:=AText;
end;
end;
FServerInterceptLog.LogWriteString(GetConnectionID,DateTimeToStr(Now),Options,''); {Do not translate}
end;
{}
function TMyServerInterceptLogConnection.GetConnectionID:string;
var
LSocket: TIdIOHandlerSocket;
begin
if (FConnection is TIdTCPConnection) then begin
LSocket := TIdTCPConnection(FConnection).Socket;
if (LSocket <> nil) then begin
if (LSocket.Binding <> nil) then begin
with LSocket.Binding do begin
Result := PeerIP + ':' + IntToStr(PeerPort);
end;
Exit;
end;
end;
end;
Result := '0.0.0.0:0';
end;
{認證}
function Auther(Command:TIdCommand; Headers:TStringList;UserManager:TIdUserManager;var LoginUser:TIdUserAccount):boolean;
var
AuthString,AuthUser,AuthPassword:string;
LConnection:TIdTCPServerConnection;
LPeerThread:TIdPeerThread;
begin
Result:=strtointdef(ServerInfo.Values['UserManager'],0)<=0;
LPeerThread:=Command.Thread;
LConnection:=Command.Thread.Connection;
if Assigned(LPeerThread) and Assigned(LConnection) then begin//如果需要代理身份認證
if LConnection.Connected and (not Result) then begin
AuthString:=Headers.Values['Proxy-Authorization'];
Fetch(AuthString,'Basic',true);
AuthString := TIdDecoderMIME.DecodeString(trim(AuthString));//解碼用戶名和密碼
if length(trim(AuthString))>0 then begin
Headers.Delete(Headers.IndexOfName('Proxy-Authorization'));
end;
AuthUser:=Fetch(AuthString, ':');
AuthPassword:=AuthString;
if UserManager.AuthenticateUser(AuthUser,AuthPassword) then begin
LoginUser:=UserManager.Accounts[AuthUser];
result:=Assigned(LoginUser);
end; //if Authentcateuser
end;
end;//if usermanager.tag>0
end;
{}
function ChangeData(S:string):string;
var
temp:integer;
begin
result:=s;
try
for temp:=0 to ChangeInfo.Count-1 do begin
result:=StringReplace(result,ChangeInfo.Names[temp],ChangeInfo.ValueFromIndex[temp],[rfReplaceAll]);
end;
except
end;
end;
uj5u.com熱心網友回復：
{-------------------------}procedure ConnectionSet(LPeer:TIdTCPConnection;var Account:TIdUserAccount);
var
LIOHandler:TIdIOHandlerThrottle;
N:integer;
begin
if Assigned(Account) and Assigned(LPeer) then begin
if LPeer.Connected and (LPeer.IOHandler is TIdIOHandlerThrottle) then begin
N:=strtointdef(Account.Attributes.Values['Speed'],0);//設定該用戶每連接的流量
if N<=0 then begin
N:=strtointdef(ServerInfo.Values['SpeedWithPeer'],0);//設定該用戶每連接的流量
end;
if N>0 then begin
LIOHandler:=TIdIOHandlerThrottle(LPeer.IOHandler);//建立用于控制每連接流量的物件
LIOHandler.BytesPerSec:=N;
end;
end;
end;
end;
{}
procedure CreateConnect(Command:TIdCommand;Headers:TStringList;var LClient:TIdTCPConnection);
var
LURI: TIdURI;
LDocument: string;
ProxyString,ProxyAuth:String;
LAuth:TIdBasicAuthentication;
LPeer:TIdTCPConnection;
LThread:TIdPeerThread;
LHost:string;
LVersion:string;
LSocksInfo:TIdSocksInfo;
LIOHandler:TIdIOHandlerThrottle;
begin
LThread:=Command.Thread;
LPeer:=Command.Thread.Connection;
if (not Assigned(Command)) or (not Assigned(LThread))
or (not Assigned(LPeer)) or (not Assigned(Headers)) then begin
exit;
end else begin
if not (Command.Params.Count=2) then begin
exit;
end;
end;
if LPeer.Connected and (not LThread.Stopped) then begin
LClient:=TIdTCPClient.Create(nil);
LIOHandler:=TIdIOHandlerThrottle.Create(LClient);
LClient.IOHandler:=TIdIOHandlerSocket.Create(LIOHandler);
LIOHandler.ChainedHandler:=LClient.IOHandler;
LClient.IOHandler:=LIOHandler;
LClient.ReadTimeout:=strtointdef(ServerInfo.Values['ReadTimeOut'],0);
LClient.ReadTimeout:=iif(LClient.ReadTimeout=-1,0,LClient.ReadTimeout);
LURI := TIdURI.Create(Command.Params.Strings[0]); //建立一個分析URL的物件
LVersion:=Command.Params.Strings[1];
if AnsiSameText(Command.CommandHandler.Command,'CONNECT')
and (LURI.Protocol='') then begin//如果是connect命令，并且url中沒有http協議字符，則添加后進行分析
LURI.URI:='HTTP://'+Command.Params.Strings[0];
end;
if not AnsiSameText(Command.CommandHandler.Command,'OPTIONS') then begin
if LURI.Host='' then begin
exit;//如果不是options命令，不能從url中分析出目標主機則認為此請求是無效的http代理請求
end;
end else begin //如果是options命令，則通過host欄位來分析目標主機
LHost:=Headers.Values['Host'];
LURI.Host:=Fetch(LHost,':',true);
LURI.Port:=LHost;
end;
try
TIdTCPClient(LClient).Port := StrToIntDef(LURI.Port, 80);//獲取請求url中的埠資訊
TIdTCPClient(LClient).Host := LURI.Host;
LDocument := LURI.Path + LURI.Document + LURI.Params;//重建資源路徑（使用相對路徑的表示方式）
if LURI.Bookmark<>'' then begin
LDocument:=LDocument+'#'+LURI.Bookmark;
end;
LURI.URI:='';
ProxyString:=Serverinfo.Values[TIdTCPClient(LClient).Host+':'+
IntToStr(TIdTCPClient(LClient).Port)];//根據系統配置，設定二級代理
if Length(Trim(ProxyString))>0 then begin
LURI.URI:=ProxyString;
if AnsiSameText(LURI.Protocol,'HTTP') then begin//如果使用http二級代理
if not LClient.Connected then begin
TIdTCPClient(LClient).Port:=StrToIntDef(LURI.Port, 8080);
TIdTCPClient(LClient).Host := LURI.Host;
end;
if LURI.Username<>'' then begin //如果二級需要驗證身份，則重新修改代理認證欄位
LAuth := TIdBasicAuthentication.Create;
try
with LAuth do begin
Params.Values['Username'] := LURI.Username;
Params.Values['Password'] := LURI.Password;
ProxyAuth:= Authentication;
end;
if Length(ProxyAuth)>0 then begin
Headers.Values['Proxy-Authorization']:= ProxyAuth;
end;
finally
LAuth.Free;
end;
end;
end else begin //如果使用socks代理
LSocksInfo:=LClient.Socket.SocksInfo;
with LSocksInfo do begin
IoHandler:=LClient.IOHandler;
Username:=LURI.Username;
Password:=LURI.Password;
if not LClient.Connected then begin
Host:=LURI.Host;
Port:=strtointdef(LURI.Port,1080);
end;//設定二級代理的型別 0=無socks代理 1=SOCKS4 2=SOCKS4A 3=SOCKS5
Version:=TSocksVersion(
iif(AnsiSameText(LURI.Protocol,'SOCKS4'),1,
iif(AnsiSameText(LURI.Protocol,'SOCKS4A'),2,
iif(AnsiSameText(LURI.Protocol,'SOCKS5'),3,0))));
//根據二級socks代理是否需要身份驗證，//只有socks5支持身份認證
Authentication:=TSocksAuthentication(
iif(trim(UserName)<>'',1,0));
end;
end;
end else begin //如果沒有定義該目標主機的二級代理，則修改請求命令列
Headers.Strings[0]:=Command.CommandHandler.Command+' '+
LDocument+' '+LVersion;
end; //length(ProxyString)>0
if Headers.Values['Proxy-Connection']<>'' then begin
Headers.Delete(Headers.IndexOfName('Proxy-Connection'));//洗掉請求包中的代理標志
end;
finally
FreeAndNil(LURI);
end;
try
TIdTCPClient(LClient).Connect(strtointdef(ServerInfo.Values['ConnectTimeOut'],10000));
except
on E:EIdConnectTimeout do begin
SendResponse(LThread,504,'','連接目標主機超時',true);
end;
end;
end;
end;
{}
procedure ReadHeaders(LConnection:TIdTCPConnection;Headers:TStringList);
begin
if Assigned(LConnection) and Assigned(Headers) then begin
if LConnection.Connected then begin
LConnection.Capture(Headers,'');
end;
end;
end;
procedure SendData(Athread:TIdPeerThread;LFrom:TIdTCPConnection;
LTo:TIdTCPConnection;LSize:integer;Change:boolean);
var
LContentSize:integer;
Temp:integer;
TempStr:string;
begin
if not Assigned(AThread) or not Assigned(LFrom) or not Assigned(LTo) then begin
exit;
end;
LContentSize:=LSize;
case Lsize of
-1:begin
exit;
end;
0:begin
while (LFrom.Connected) and (LTO.Connected) do begin
try
LFrom.ReadFromStack(false,LFrom.ReadTimeout,false);
except
end;
if LFrom.InputBuffer.Size>0 then begin
LFrom.InputBuffer.Seek(0,soFromBeginning);
try
LTo.WriteBuffer(LFrom.InputBuffer.memory^,LFrom.InputBuffer.Size);
finally
LFrom.InputBuffer.Remove(LFrom.InputBuffer.Size);
end;
end;
LFrom.CheckForGracefulDisconnect(false);
LTo.CheckForGracefulDisconnect(false);
end;
end;
else begin
while (LContentSize>0) and (LFrom.Connected) and (LTo.Connected) do begin
try
LFrom.ReadFromStack(false,LFrom.ReadTimeout,false);
except
end;
Temp:=LFrom.InputBuffer.Size;
if Temp>0 then begin
try
if Change then begin
TempStr:=ChangeData(LFrom.InputBuffer.Extract(Temp));
LTo.Write(TempStr);
end else begin
LTo.WriteBuffer(LFrom.InputBuffer.memory^,Temp);
LFrom.InputBuffer.Remove(Temp);
end;
finally
Dec(LContentSize,Temp);
end;
end;
LFrom.CheckForGracefulDisconnect(false);
LTo.CheckForGracefulDisconnect(false);
end;
end;
end;
end;
uj5u.com熱心網友回復：
樓主先查清楚是收資料卡還是發資料卡。你代碼中都用到執行緒池了，你把卡的那部分代碼放到執行緒中跑不就行了，反正收發資料這塊影響不到界面。轉載請註明出處，本文鏈接：https://www.uj5u.com/houduan/108853.html
標籤：網絡通信/分布式開發