13 Years of Service
24%
Coder: trip
Code:
>unit unMain;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
Vcl.ComCtrls, Vcl.ToolWin, Vcl.ImgList, Vcl.Menus, csDictionary, GeoIP;
const
TH_MESSAGE = Succ(WM_USER);
type
TfrmMain = class(TForm)
StatusBar: TStatusBar;
lvProxies: TListView;
ToolBar: TToolBar;
tbtnCheck: TToolButton;
tbtnImport: TToolButton;
ilToolBar: TImageList;
tbtnExport: TToolButton;
ToolButton4: TToolButton;
tbtnRemove: TToolButton;
ToolButton6: TToolButton;
tbtnSettings: TToolButton;
ToolButton8: TToolButton;
tbtnAbout: TToolButton;
pmCheck: TPopupMenu;
miCheckAll: TMenuItem;
miCheckSelected: TMenuItem;
pmImport: TPopupMenu;
miAdd: TMenuItem;
miPaste: TMenuItem;
miLoad: TMenuItem;
ilMenu: TImageList;
pmExport: TPopupMenu;
miCopy: TMenuItem;
miSave: TMenuItem;
miCopyAll: TMenuItem;
miCopySelected: TMenuItem;
miSaveAll: TMenuItem;
miSaveSelected: TMenuItem;
pmRemove: TPopupMenu;
miRemoveAll: TMenuItem;
miRemoveSelected: TMenuItem;
ilListView: TImageList;
ProgressBar: TProgressBar;
pmProxies: TPopupMenu;
miSelect: TMenuItem;
N1: TMenuItem;
miImport: TMenuItem;
miExport: TMenuItem;
N2: TMenuItem;
miRemove: TMenuItem;
N3: TMenuItem;
miAutoscroll: TMenuItem;
miAdd1: TMenuItem;
miPaste1: TMenuItem;
miLoad1: TMenuItem;
miCopy1: TMenuItem;
miSave1: TMenuItem;
miCopyAll1: TMenuItem;
miCopySelected1: TMenuItem;
miSaveAll1: TMenuItem;
miSaveSelected1: TMenuItem;
miRemoveAll1: TMenuItem;
miRemoveSelected1: TMenuItem;
miSelectAll: TMenuItem;
N4: TMenuItem;
miSelectHTTP: TMenuItem;
miSelectSocks4: TMenuItem;
miSelectSocks5: TMenuItem;
miSelectConnect: TMenuItem;
ToolButton1: TToolButton;
OpenDialog: TOpenDialog;
SaveDialog: TSaveDialog;
procedure tbtnCheckClick(Sender: TObject);
procedure tbtnImportClick(Sender: TObject);
procedure tbtnExportClick(Sender: TObject);
procedure tbtnRemoveClick(Sender: TObject);
procedure miPasteClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure miCheckAllClick(Sender: TObject);
procedure pmCheckPopup(Sender: TObject);
procedure FormResize(Sender: TObject);
procedure lvProxiesCustomDrawItem(Sender: TCustomListView; Item: TListItem;
State: TCustomDrawState; var DefaultDraw: Boolean);
procedure lvProxiesCustomDrawSubItem(Sender: TCustomListView;
Item: TListItem; SubItem: Integer; State: TCustomDrawState;
var DefaultDraw: Boolean);
procedure tbtnSettingsClick(Sender: TObject);
procedure miRemoveAllClick(Sender: TObject);
procedure miRemoveSelectedClick(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure pmRemovePopup(Sender: TObject);
procedure pmImportPopup(Sender: TObject);
procedure miAddClick(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure pmProxiesPopup(Sender: TObject);
procedure miSelectAllClick(Sender: TObject);
procedure miLoadClick(Sender: TObject);
procedure miCopyAllClick(Sender: TObject);
procedure miSaveAllClick(Sender: TObject);
procedure pmExportPopup(Sender: TObject);
procedure miSelectHTTPClick(Sender: TObject);
procedure tbtnAboutClick(Sender: TObject);
private
FProxies: TStringDictionary;
FGeoIP: TGeoIP;
procedure ExtractProxies(const S: string);
procedure AddProxy(const AProxy: string);
procedure UpdateProxyCount;
procedure UpdateThreadCount;
procedure ThreadMessage(var AMessage: TMessage); message TH_MESSAGE;
function GetCountry(const AIP: string; out ACountryName, ACountryCode:
string): Boolean;
function ProxiesToStr(ASelected: Boolean): string;
public
function GetMyIP(out AMyIP: string; out AErrorCode: Integer; out AIsTimeout:
Boolean): Boolean;
end;
var
frmMain: TfrmMain;
implementation
{$R *.dfm}
uses
RegularExpressions, ClipBrd, Generics.Collections, Winapi.Winsock, CommCtrl,
unPing, unSettings, System.UITypes, IniFiles;
type
TUpdateItem = record
ItemIndex, SubItemIndex, ImgIndex, SubItemImageIndex: Integer;
Text : string;
end;
PUpdateItem = ^TUpdateItem;
const
TH_THREAD_START = 1;
TH_START = 2;
TH_STATUS = 3;
TH_UPDATE_ITEM = 4;
TH_THREAD_END = 5;
var
ilItemIndexes: TList;
CriticalSection: TRTLCriticalSection;
iThreadCount: Integer;
bAbort: Boolean;
function GetErrorCode(ASocket: TSocket; out AErrorCode: Integer): Boolean;
var
iSize: Integer;
begin
iSize := SizeOf(AErrorCode);
Result := getsockopt(ASocket, SOL_SOCKET, SO_ERROR, PAnsiChar(@AErrorCode),
iSize) SOCKET_ERROR;
end;
function WSConnect(const AIP: string; APort: Word; ATimeout: Integer; out
ASocket: TSocket; out AErrorCode: Integer; out AIsTimeout: Boolean): Boolean;
var
iBlock : Integer;
SAI : TSockAddrIn;
FDW, FDE: TFDSet;
TV : TTimeVal;
begin
Result := False;
AIsTimeout := False;
ASocket := socket(AF_INET, SOCK_STREAM, IPPROTO_TCP);
if ASocket INVALID_SOCKET then
begin
with SAI do
begin
sin_family := AF_INET;
sin_port := htons(APort);
sin_addr.S_addr := inet_addr(PAnsiChar(AnsiString(AIP)));
end;
iBlock := 1;
if ioctlsocket(ASocket, FIONBIO, iBlock) SOCKET_ERROR then
begin
if connect(ASocket, SAI, SizeOf(SAI)) = SOCKET_ERROR then
begin
if WSAGetLastError = WSAEWOULDBLOCK then
begin
with TV do
begin
tv_sec := 0;
tv_usec := ATimeout * 1000;
end;
FD_ZERO(FDW);
FD_ZERO(FDE);
FD_SET(ASocket, FDW);
FD_SET(ASocket, FDE);
if select(0, nil, @FDW, @FDE, @TV) SOCKET_ERROR then
begin
if FD_ISSET(ASocket, FDW) then
Result := True
else if FD_ISSET(ASocket, FDE) then
begin
if not GetErrorCode(ASocket, AErrorCode) then
AErrorCode := WSAGetLastError;
end
else
AIsTimeout := True;
end
else
AErrorCode := WSAGetLastError;
end
else
AErrorCode := WSAGetLastError;
end
else
AErrorCode := WSAGetLastError;
end
else
AErrorCode := WSAGetLastError;
end
else
AErrorCode := WSAGetLastError;
end;
function SendBuffer(ASocket: TSocket; const ABuffer; L, ATimeout: Integer; out
AErrorCode: Integer; out AIsTimeout: Boolean): Boolean;
const
BUFFER_SIZE = 1024;
var
I, J, K : Integer;
FDW, FDE: TFDSet;
TV : TTimeVal;
begin
Result := False;
AIsTimeout := False;
I := 0;
repeat
FD_ZERO(FDW);
FD_ZERO(FDE);
FD_SET(ASocket, FDW);
FD_SET(ASocket, FDE);
with TV do
begin
tv_sec := 0;
tv_usec := ATimeout * 1000;
end;
if select(0, nil, @FDW, @FDE, @TV) SOCKET_ERROR then
begin
if FD_ISSET(ASocket, FDW) then
begin
if L >= BUFFER_SIZE then J := BUFFER_SIZE else J := L;
K := send(ASocket, PByte(@ABuffer)[i], J, 0);
Result := K SOCKET_ERROR;
if Result then
begin
Inc(I, K);
Dec(L, K);
end
else
AErrorCode := WSAGetLastError;
end
else if FD_ISSET(ASocket, FDE) then
begin
if not GetErrorCode(ASocket, AErrorCode) then
AErrorCode := WSAGetLastError;
end
else
AIsTimeout := True;
end
else
AErrorCode := WSAGetLastError;
until not Result or (L = 0);
end;
function ReceiveBuffer(ASocket: TSocket; out ABuffer; L, ATimeout: Integer;
out AErrorCode: Integer; out AIsTimeout: Boolean): Boolean;
const
BUFFER_SIZE = 512;
var
I, J, K, iErrorCode: Integer;
FDR, FDE: TFDSet;
TV: TTimeVal;
bError: Boolean;
begin
AIsTimeout := False;
I := 0;
with TV do
begin
tv_sec := 0;
tv_usec := ATimeout * 1000;
end;
repeat
bError := True;
FD_ZERO(FDR);
FD_ZERO(FDE);
FD_SET(ASocket, FDR);
FD_SET(ASocket, FDE);
if select(0, @FDR, nil, @FDE, @TV) SOCKET_ERROR then
begin
if FD_ISSET(ASocket, FDR) then
begin
if L >= BUFFER_SIZE then J := BUFFER_SIZE else J := L;
K := recv(ASocket, PByte(@ABuffer)[i], J, 0);
if K > 0 then
begin
Inc(I, K);
Dec(L, K);
bError := False;
end
else
AErrorCode := WSAGetLastError;
end
else if FD_ISSET(ASocket, FDE) then
begin
if GetErrorCode(ASocket, iErrorCode) then
AErrorCode := iErrorCode
else
AErrorCode := WSAGetLastError;
end
else
AIsTimeout := True;
end
else
AErrorCode := WSAGetLastError;
until bError or (L = 0);
Result := L = 0;
end;
function SendStr(ASocket: TSocket; const S: string; ATimeout: Integer; out
AErrorCode: Integer; out AIsTimeout: Boolean): Boolean;
begin
Result := SendBuffer(ASocket, Pointer(AnsiString(S))^, Length(S), ATimeout,
AErrorCode, AIsTimeout);
end;
function ReceiveData(ASocket: TSocket; ATimeout: Integer; out AHeader,
AData: string; out AErrorCode: Integer; out AIsTimeout: Boolean): Boolean;
const
BUFFER_SIZE = 1024;
var
iRecv, iErrorCode, iPos: Integer;
sBuffer: AnsiString;
bError, bHeaderReceived: Boolean;
FDR, FDE: TFDSet;
TV: TTimeVal;
begin
Result := False;
AHeader := '';
AData := '';
bHeaderReceived := False;
AIsTimeout := False;
with TV do
begin
tv_sec := 0;
tv_usec := ATimeout * 1000;
end;
repeat
bError := True;
FD_ZERO(FDR);
FD_ZERO(FDE);
FD_SET(ASocket, FDR);
FD_SET(ASocket, FDE);
if select(0, @FDR, nil, @FDE, @TV) SOCKET_ERROR then
begin
if FD_ISSET(ASocket, FDR) then
begin
SetLength(sBuffer, BUFFER_SIZE);
iRecv := recv(ASocket, Pointer(sBuffer)^, BUFFER_SIZE, 0);
if iRecv > 0 then
begin
bError := False;
SetLength(sBuffer, iRecv);
AData := AData + string(sBuffer);
if not bHeaderReceived then
begin
iPos := Pos(sLineBreak + sLineBreak, AData);
bHeaderReceived := iPos > 0;
if bHeaderReceived then
begin
AHeader := Copy(AData, 1, Pred(iPos));
AData := Copy(AData, iPos + 4);
end;
end;
end
else if iRecv = 0 then
Result := True
else
AErrorCode := WSAGetLastError;
end
else if FD_ISSET(ASocket, FDE) then
begin
if GetErrorCode(ASocket, iErrorCode) then
AErrorCode := iErrorCode
else
AErrorCode := WSAGetLastError;
end
else
AIsTimeout := True;
end
else
AErrorCode := WSAGetLastError;
until Result or bError;
end;
function GetHTTP(const AIP, ARequest: string; APort: Word; AConnectTimeout,
AReceiveTimeout, ASendTimeout: Integer; out AHeader, AData: string; out
AErrorCode: Integer; out AIsTimeout: Boolean): Boolean;
var
Socket: TSocket;
begin
Socket := INVALID_SOCKET;
Result := WSConnect(AIP, APort, AConnectTimeout, Socket, AErrorCode,
AIsTimeout) and SendStr(Socket, ARequest, ASendTimeout, AErrorCode,
AIsTimeout) and ReceiveData(Socket, AReceiveTimeout, AHeader, AData,
AErrorCode, AIsTimeout);
if Socket INVALID_SOCKET then closesocket(Socket);
end;
function ExtractIP(const S: string; out AIP: string): Boolean;
const
PATTERN = '(?:(?:25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\.){3}(?:25[0-5]|' +
'2[0-4][0-9]|[01]?[0-9][0-9]?)';
var
Match: TMatch;
begin
Match := TRegex.Match(S, PATTERN);
Result := Match.Success;
if Result then AIP := Match.Value;
end;
procedure ThreadProc;
function GetHostByIP(const AIP: string; out AHost: string): Boolean;
var
iIP : Integer;
HostEnt: PHostEnt;
begin
iIP := inet_addr(PAnsiChar(AnsiString(AIP)));
HostEnt := gethostbyaddr(@iIP, SizeOf(Integer), AF_INET);
Result := Assigned(HostEnt);
if Result then AHost := string(HostEnt^.h_name);
end;
procedure UpdateItem(AItemIndex, ASubItemIndex, AImageIndex, ASubItemImageIndex:
Integer; const AText: string);
var
UpdateItem: PUpdateItem;
begin
New(UpdateItem);
with UpdateItem^ do
begin
ItemIndex := AItemIndex;
SubItemIndex := ASubItemIndex;
ImgIndex := AImageIndex;
SubItemImageIndex := ASubItemImageIndex;
Text := AText;
end;
PostMessage(frmMain.Handle, TH_MESSAGE, TH_UPDATE_ITEM, Integer(UpdateItem));
end;
function GetVia(AHeader: string; out AVia: string): Boolean;
var
iPos, iPosStart: Integer;
begin
iPos := Pos('VIA:', UpperCase(AHeader));
Result := iPos > 0;
if Result then
begin
iPosStart := iPos + 4;
AHeader := Copy(AHeader, iPosStart);
iPos := Pos(#13, AHeader);
if iPos = 0 then iPos := Pos(#10, AHeader);
if iPos > 0 then
AVia := Trim(Copy(AHeader, 1, iPos))
else
AVia := Trim(AHeader);
end;
end;
type
TProxyType = (ptTransparent, ptAnonymous, ptHighAnonymous, ptCoDeeN, ptOther);
function GetProxyType(AData: string; const AMyIP, AGood: string): TProxyType;
begin
AData := UpperCase(AData);
if Pos(UpperCase(AGood), AData) > 0 then
begin
if Pos(AMyIP, AData) > 0 then
Result := ptTransparent
else if Pos('CODEEN', AData) > 0 then
Result := ptCoDeeN
else if (Pos('HTTP_X_FORWARDED_FOR', AData) > 0) or
(Pos('HTTP_VIA', AData) > 0) or
(Pos('HTTP_PROXY_CONNECTION', AData) > 0) then
Result := ptAnonymous
else
Result := ptHighAnonymous;
end
else
Result := ptOther;
end;
function GetHTTPCode(AHeader: string): Integer;
var
iPos: Integer;
begin
Result := 0;
iPos := Pos(' ', AHeader);
if iPos > 0 then
begin
AHeader := Copy(AHeader, Succ(iPos));
iPos := Pos(' ', AHeader);
if iPos > 0 then
Result := StrToIntDef(Copy(AHeader, 1, Pred(iPos)), 0)
else
Result := StrToIntDef(Copy(AHeader, 1), 0);
end;
end;
function GetHostByURL(AURL: string): string;
var
iPos: Integer;
begin
iPos := Pos('://', AURL);
if iPos > 0 then AURL := Copy(AURL, iPos + 3);
iPos := Pos('/', AURL);
if iPos > 0 then
Result := Copy(AURL, 1, Pred(iPos))
else
Result := AURL;
end;
function CheckHTTP(AItemIndex: Integer; const AIP, AMyIP: string; APort: Word):
Boolean;
var
Socket: TSocket;
iErrorCode, iHTTPCode: Integer;
bIsTimeout: Boolean;
sHeader, sData, sVia, sIP: string;
begin
Result := False;
Socket := INVALID_SOCKET;
UpdateItem(AItemIndex, 4, -1, 1, 'connecting');
if WSConnect(AIP, APort, Settings.Timeout.Connect, Socket, iErrorCode,
bIsTimeout) then
begin
UpdateItem(AItemIndex, 4, -1, -1, 'sending request');
if SendStr(Socket, 'GET ' + Settings.Check.Proxyjudge + ' HTTP/1.1' +
sLineBreak + 'Host: ' + GetHostByURL(Settings.Check.Proxyjudge) +
sLineBreak + 'Connection: close' + sLineBreak + sLineBreak,
Settings.Timeout.Send, iErrorCode, bIsTimeout) then
begin
UpdateItem(AItemIndex, 4, -1, 6, 'receiving data');
if ReceiveData(Socket, Settings.Timeout.Receive, sHeader, sData,
iErrorCode, bIsTimeout) then
begin
Result := True;
if not GetVia(sHeader, sVia) then sVia := 'No';
UpdateItem(AItemIndex, 8, -1, -1, sVia);
if Trim(sData) = '' then
UpdateItem(AItemIndex, 4, -1, 4, 'empty response')
else
begin
iHTTPCode := GetHTTPCode(sHeader);
if iHTTPCode = 200 then
begin
case GetProxyType(sData, AMyIP, 'REMOTE_ADDR=') of
ptTransparent : UpdateItem(AItemIndex, 4, -1, 3, 'transparent');
ptAnonymous : UpdateItem(AItemIndex, 4, -1, 2, 'anonymous');
ptHighAnonymous: UpdateItem(AItemIndex, 4, -1, 2, 'high anonymous');
ptCoDeeN : UpdateItem(AItemIndex, 4, -1, 3, 'CoDeeN');
ptOther : UpdateItem(AItemIndex, 4, -1, 3, 'other/fake');
end;
end
else
UpdateItem(AItemIndex, 4, -1, 3, 'Code: ' + IntToStr(iHTTPCode));
end;
if not ExtractIP(sData, sIP) and (AIP sIP) then sIP := 'No';
UpdateItem(AItemIndex, 9, -1, -1, sIP);
end
else if bIsTimeout then
UpdateItem(AItemIndex, 4, -1, 5, 'recv timeout')
else
UpdateItem(AItemIndex, 4, -1, 4, 'recv error');
end
else if bIsTimeout then
UpdateItem(AItemIndex, 4, -1, 5, 'send timeout')
else
UpdateItem(AItemIndex, 4, -1, 4, 'send error');
end
else if bIsTimeout then
UpdateItem(AItemIndex, 4, -1, 5, 'connect timeout')
else
UpdateItem(AItemIndex, 4, -1, 4, 'connect error');
if Socket INVALID_SOCKET then closesocket(Socket);
end;
function CheckSocks4(AItemIndex: Integer; const AIP: string; APort: Word):
Boolean;
type
TSocks4Request = packed record
ver : Byte;
cmd : Byte;
port: Word;
ip : Integer;
user: byte;
end;
TSocks4Response = packed record
ver : Byte;
cmd : Byte;
port: Word;
ip : Integer;
end;
const
SOCKS4_REQUEST_GRANTED = 90;
SOCKS4_REQUEST_REJECTED = 91;
SOCKS4_REQUEST_IDENT_FAILED = 92;
SOCKS4_REQUEST_IDENT_CONFLICT = 93;
var
Socket : TSocket;
iErrorCode : Integer;
bIsTimeout : Boolean;
Socks4Request : TSocks4Request;
Socks4Response: TSocks4Response;
begin
Result := False;
Socket := INVALID_SOCKET;
UpdateItem(AItemIndex, 5, -1, 1, 'connecting');
if WSConnect(AIP, APort, Settings.Timeout.Connect, Socket, iErrorCode, bIsTimeout) then
begin
UpdateItem(AItemIndex, 5, -1, -1, 'sending request');
with Socks4Request do
begin
ver := 4;
cmd := 1;
port := htons(StrToIntDef(Copy(Settings.Check.SocksHost, Succ(Pos(':', Settings.Check.SocksHost))), 80));
ip := inet_addr(PAnsiChar(AnsiString(Copy(Settings.Check.SocksHost, 1, Pred(Pos(':', Settings.Check.SocksHost))))));
end;
if SendBuffer(Socket, Socks4Request, SizeOf(Socks4Request), Settings.Timeout.Send, iErrorCode, bIsTimeout) then
begin
UpdateItem(AItemIndex, 5, -1, 6, 'receiving data');
if ReceiveBuffer(Socket, Socks4Response, SizeOf(Socks4Response), Settings.Timeout.Receive, iErrorCode, bIsTimeout) then
begin
Result := True;
case Socks4Response.cmd of
SOCKS4_REQUEST_GRANTED: UpdateItem(AItemIndex, 5, -1, 2, 'OK');
SOCKS4_REQUEST_REJECTED: UpdateItem(AItemIndex, 5, -1, 4, 'rejected/failed');
SOCKS4_REQUEST_IDENT_FAILED: UpdateItem(AItemIndex, 5, -1, 4, 'ident failed');
SOCKS4_REQUEST_IDENT_CONFLICT: UpdateItem(AItemIndex, 5, -1, 4, 'ident conflict');
else UpdateItem(AItemIndex, 5, -1, 3, 'unknown response: ' + IntToStr(Socks4Response.cmd));
end;
end
else if bIsTimeout then
UpdateItem(AItemIndex, 5, -1, 5, 'recv timeout')
else
UpdateItem(AItemIndex, 5, -1, 4, 'recv error');
end
else if bIsTimeout then
UpdateItem(AItemIndex, 5, -1, 5, 'send timeout')
else
UpdateItem(AItemIndex, 5, -1, 4, 'send error');
end
else if bIsTimeout then
UpdateItem(AItemIndex, 5, -1, 5, 'connect timeout')
else
UpdateItem(AItemIndex, 5, -1, 4, 'connect error');
if Socket INVALID_SOCKET then closesocket(Socket);
end;
function CheckSocks5(AItemIndex: Integer; const AIP: string; APort: Word):
Boolean;
type
TSocks5ConnectRequest = packed record
ver : Byte;
nmethods: Byte;
methods : Byte;
end;
TSocks5ConnectResponse = packed record
ver : Byte;
method: Byte;
end;
TSocks5Request = packed record
ver : Byte;
cmd : Byte;
rsv : Byte;
atyp: Byte;
ip : Integer;
port: Word;
end;
TSocks5Response = packed record
ver : Byte;
rep : Byte;
rsv : Byte;
atyp: Byte;
ip : Integer;
port: Word;
end;
var
Socket: TSocket;
iErrorCode: Integer;
bIsTimeout: Boolean;
Socks5ConnectRequest: TSocks5ConnectRequest;
Socks5ConnectResponse: TSocks5ConnectResponse;
Socks5Request: TSocks5Request;
Socks5Response: TSocks5Response;
begin
Result := False;
Socket := INVALID_SOCKET;
UpdateItem(AItemIndex, 6, -1, 1, 'connecting');
if WSConnect(AIP, APort, Settings.Timeout.Connect, Socket, iErrorCode, bIsTimeout) then
begin
UpdateItem(AItemIndex, 6, -1, -1, 'sending request (1)');
with Socks5ConnectRequest do
begin
ver := 5;
nmethods := 1;
methods := 0;
end;
if SendBuffer(Socket, Socks5ConnectRequest, SizeOf(Socks5ConnectRequest),
Settings.Timeout.Send, iErrorCode, bIsTimeout) then
begin
UpdateItem(AItemIndex, 6, -1, 6, 'receiving data (1)');
if ReceiveBuffer(Socket, Socks5ConnectResponse,
SizeOf(Socks5ConnectResponse), Settings.Timeout.Receive, iErrorCode,
bIsTimeout) then
begin
if Socks5ConnectResponse.method = 0 then
begin
UpdateItem(AItemIndex, 6, -1, 1, 'sending request (2)');
with Socks5Request do
begin
ver := 5;
cmd := 1;
rsv := 0;
atyp := 1;
ip := inet_addr(PAnsiChar(AnsiString(Copy(Settings.Check.SocksHost, 1, Pred(Pos(':', Settings.Check.SocksHost))))));
port := htons(StrToIntDef(Copy(Settings.Check.SocksHost, Succ(Pos(':', Settings.Check.SocksHost))), 80));
end;
if SendBuffer(Socket, Socks5Request, SizeOf(Socks5Request),
Settings.Timeout.Send, iErrorCode, bIsTimeout) then
begin
UpdateItem(AItemIndex, 6, -1, 6, 'receiving data (2)');
if ReceiveBuffer(Socket, Socks5Response, SizeOf(Socks5Response),
Settings.Timeout.Receive, iErrorCode, bIsTimeout) then
begin
Result := True;
case Socks5Response.rep of
0: UpdateItem(AItemIndex, 6, -1, 2, 'OK');
1: UpdateItem(AItemIndex, 6, -1, 4, 'general failure');
2: UpdateItem(AItemIndex, 6, -1, 4, 'access denied');
3: UpdateItem(AItemIndex, 6, -1, 4, 'network unreachable');
4: UpdateItem(AItemIndex, 6, -1, 4, 'host unreachable');
5: UpdateItem(AItemIndex, 6, -1, 4, 'connection refused');
6: UpdateItem(AItemIndex, 6, -1, 4, 'ttl expired');
7: UpdateItem(AItemIndex, 6, -1, 4, 'command not supported');
8: UpdateItem(AItemIndex, 6, -1, 4, 'address type not supported');
else UpdateItem(AItemIndex, 6, -1, 3, 'unknown reply: ' +
IntToStr(Socks5Response.rep));
end;
end
else if bIsTimeout then
UpdateItem(AItemIndex, 6, -1, 5, 'recv timeout (2)')
else
UpdateItem(AItemIndex, 6, -1, 4, 'recv error (2)');
end
else if bIsTimeout then
UpdateItem(AItemIndex, 6, -1, 5, 'send timeout (2)')
else
UpdateItem(AItemIndex, 6, -1, 4, 'send error (2)');
end
else
UpdateItem(AItemIndex, 6, -1, 4, 'invalid method: ' +
IntToStr(Socks5ConnectResponse.method));
end
else if bIsTimeout then
UpdateItem(AItemIndex, 6, -1, 5, 'recv timeout (1)')
else
UpdateItem(AItemIndex, 6, -1, 4, 'recv error (1)');
end
else if bIsTimeout then
UpdateItem(AItemIndex, 6, -1, 5, 'send timeout (1)')
else
UpdateItem(AItemIndex, 6, -1, 4, 'send error (1)');
end
else if bIsTimeout then
UpdateItem(AItemIndex, 6, -1, 5, 'connect timeout')
else
UpdateItem(AItemIndex, 6, -1, 4, 'connect error');
if Socket INVALID_SOCKET then closesocket(Socket);
end;
function CheckConnect(AItemIndex: Integer; const AIP: string; APort: Word):
Boolean;
var
Socket : TSocket;
iErrorCode, iHTTPCode: Integer;
bIsTimeout: Boolean;
sBuffer : AnsiString;
begin
Result := False;
Socket := INVALID_SOCKET;
UpdateItem(AItemIndex, 7, -1, 1, 'connecting');
if WSConnect(AIP, APort, Settings.Timeout.Connect, Socket, iErrorCode,
bIsTimeout) then
begin
UpdateItem(AItemIndex, 7, -1, -1, 'sending request');
if SendStr(Socket, 'CONNECT ' + Settings.Check.ConnectHost + ' HTTP/1.1' +
sLineBreak + sLineBreak, Settings.Timeout.Send, iErrorCode, bIsTimeout)
then
begin
UpdateItem(AItemIndex, 7, -1, 6, 'receiving data');
SetLength(sBuffer, 12);
if ReceiveBuffer(Socket, Pointer(sBuffer)^, 12, Settings.Timeout.Receive,
iErrorCode, bIsTimeout) then
begin
Result := True;
iHTTPCode := GetHTTPCode(string(sBuffer));
if iHTTPCode = 200 then
UpdateItem(AItemIndex, 7, -1, 2, 'OK')
else
UpdateItem(AItemIndex, 7, -1, 4, 'Code: ' + IntToStr(iHTTPCode));
end
else if bIsTimeout then
UpdateItem(AItemIndex, 7, -1, 5, 'recv timeout')
else
UpdateItem(AItemIndex, 7, -1, 4, 'recv error');
end
else if bIsTimeout then
UpdateItem(AItemIndex, 7, -1, 5, 'send timeout')
else
UpdateItem(AItemIndex, 7, -1, 4, 'send error');
end
else if bIsTimeout then
UpdateItem(AItemIndex, 7, -1, 5, 'connect timeout')
else
UpdateItem(AItemIndex, 7, -1, 4, 'connect error');
if Socket INVALID_SOCKET then closesocket(Socket);
end;
var
iItemIndex, I: Integer;
sIP, sHost : string;
iPort : Word;
iRTT : Cardinal;
begin
InterlockedIncrement(iThreadCount);
PostMessage(frmMain.Handle, TH_MESSAGE, TH_THREAD_START, 0);
while True do
begin
EnterCriticalSection(CriticalSection);
if (ilItemIndexes.Count = 0) or bAbort then
begin
LeaveCriticalSection(CriticalSection);
Break;
end;
iItemIndex := ilItemIndexes[0];
ilItemIndexes.Delete(0);
LeaveCriticalSection(CriticalSection);
PostMessage(frmMain.Handle, TH_MESSAGE, TH_START, iItemIndex);
sIP := frmMain.lvProxies.Items[iItemIndex].Caption;
iPort := StrToInt(frmMain.lvProxies.Items[iItemIndex].SubItems[0]);
if Settings.Resolve and not bAbort then
begin
UpdateItem(iItemIndex, 1, 7, -1, 'resolving');
if not GetHostByIP(sIP, sHost) then sHost := '';
UpdateItem(iItemIndex, 1, -1, -1, sHost);
end;
if Settings.Ping and not bAbort then
begin
UpdateItem(iItemIndex, 2, -1, -1, 'pinging');
if not Ping(sIP, Settings.Timeout.Ping, iRTT) then iRTT := 0;
UpdateItem(iItemIndex, 2, -1, -1, IntToStr(iRTT));
end;
if Settings.Check.HTTP and not bAbort then
begin
for I := 0 to Settings.RetryCount do
if CheckHTTP(iItemIndex, sIP, Settings.MyIP, iPort) or bAbort then Break;
end;
if Settings.Check.Socks4 and not bAbort then
begin
for I := 0 to Settings.RetryCount do
if CheckSocks4(iItemIndex, sIP, iPort) or bAbort then Break;
end;
if Settings.Check.Socks5 and not bAbort then
begin
for I := 0 to Settings.RetryCount do
if CheckSocks5(iItemIndex, sIP, iPort) or bAbort then Break;
end;
if Settings.Check.Connect and not bAbort then
begin
for I := 0 to Settings.RetryCount do
if CheckConnect(iItemIndex, sIP, iPort) or bAbort then Break;
end;
PostMessage(frmMain.Handle, TH_MESSAGE, TH_STATUS, iItemIndex);
end;
InterlockedDecrement(iThreadCount);
PostMessage(frmMain.Handle, TH_MESSAGE, TH_THREAD_END, 0);
end;
procedure ShowPopupMenuByCursor(APopupMenu: TPopupMenu);
var
Point: TPoint;
begin
GetCursorPos(Point);
APopupMenu.Popup(Point.X, Point.Y);
end;
function TfrmMain.GetCountry(const AIP: string; out ACountryName, ACountryCode:
string): Boolean;
var
GeoIPCountry: TGeoIPCountry;
begin
Result := FGeoIP.GetCountry( AIP, GeoIPCountry) = GEOIP_SUCCESS;
if Result then
begin
ACountryName := GeoIPCountry.CountryName;
ACountryCode := GeoIPCountry.CountryCode;
end;
end;
function TfrmMain.GetMyIP(out AMyIP: string; out AErrorCode: Integer; out
AIsTimeout: Boolean): Boolean;
var
sHeader, sData: string;
begin
Result := GetHTTP('216.146.38.70', 'GET / HTTP/1.1' + sLineBreak +
'Host: checkip.dyndns.com' + sLineBreak + 'Connection: close' + sLineBreak +
sLineBreak, 80, Settings.Timeout.Connect, Settings.Timeout.Receive,
Settings.Timeout.Send, sHeader, sData, AErrorCode, AIsTimeout) and
ExtractIP(sData, AMyIP);
end;
function GetImageIndex(S: string): Integer;
begin
S := LowerCase(S);
if S = 'ad' then Result := 0
else if S = 'ae' then Result := 1
else if S = 'af' then Result := 2
else if S = 'ag' then Result := 3
else if S = 'ai' then Result := 4
else if S = 'al' then Result := 5
else if S = 'am' then Result := 6
else if S = 'an' then Result := 7
else if S = 'ao' then Result := 8
else if S = 'ar' then Result := 9
else if S = 'as' then Result := 10
else if S = 'at' then Result := 11
else if S = 'au' then Result := 12
else if S = 'aw' then Result := 13
else if S = 'ax' then Result := 14
else if S = 'az' then Result := 15
else if S = 'ba' then Result := 16
else if S = 'bb' then Result := 17
else if S = 'bd' then Result := 18
else if S = 'be' then Result := 19
else if S = 'bf' then Result := 20
else if S = 'bg' then Result := 21
else if S = 'bh' then Result := 22
else if S = 'bi' then Result := 23
else if S = 'bj' then Result := 24
else if S = 'bm' then Result := 25
else if S = 'bn' then Result := 26
else if S = 'bo' then Result := 27
else if S = 'br' then Result := 28
else if S = 'bs' then Result := 29
else if S = 'bt' then Result := 30
else if S = 'bv' then Result := 31
else if S = 'bw' then Result := 32
else if S = 'by' then Result := 33
else if S = 'bz' then Result := 34
else if S = 'ca' then Result := 35
else if S = 'catalonia' then Result := 36
else if S = 'cc' then Result := 37
else if S = 'cd' then Result := 38
else if S = 'cf' then Result := 39
else if S = 'cg' then Result := 40
else if S = 'ch' then Result := 41
else if S = 'ci' then Result := 42
else if S = 'ck' then Result := 43
else if S = 'cl' then Result := 44
else if S = 'cm' then Result := 45
else if S = 'cn' then Result := 46
else if S = 'co' then Result := 47
else if S = 'cr' then Result := 48
else if S = 'cs' then Result := 49
else if S = 'cu' then Result := 50
else if S = 'cv' then Result := 51
else if S = 'cx' then Result := 52
else if S = 'cy' then Result := 53
else if S = 'cz' then Result := 54
else if S = 'de' then Result := 55
else if S = 'dj' then Result := 56
else if S = 'dk' then Result := 57
else if S = 'dm' then Result := 58
else if S = 'do' then Result := 59
else if S = 'dz' then Result := 60
else if S = 'ec' then Result := 61
else if S = 'ee' then Result := 62
else if S = 'eg' then Result := 63
else if S = 'eh' then Result := 64
else if S = 'england' then Result := 65
else if S = 'er' then Result := 66
else if S = 'es' then Result := 67
else if S = 'et' then Result := 68
else if S = 'europeanunion' then Result := 69
else if S = 'fam' then Result := 70
else if S = 'fi' then Result := 71
else if S = 'fj' then Result := 72
else if S = 'fk' then Result := 73
else if S = 'fm' then Result := 74
else if S = 'fo' then Result := 75
else if S = 'fr' then Result := 76
else if S = 'ga' then Result := 77
else if S = 'gb' then Result := 78
else if S = 'gd' then Result := 79
else if S = 'ge' then Result := 80
else if S = 'gf' then Result := 81
else if S = 'gh' then Result := 82
else if S = 'gi' then Result := 83
else if S = 'gl' then Result := 84
else if S = 'gm' then Result := 85
else if S = 'gn' then Result := 86
else if S = 'gp' then Result := 87
else if S = 'gq' then Result := 88
else if S = 'gr' then Result := 89
else if S = 'gs' then Result := 90
else if S = 'gt' then Result := 91
else if S = 'gu' then Result := 92
else if S = 'gw' then Result := 93
else if S = 'gy' then Result := 94
else if S = 'hk' then Result := 95
else if S = 'hm' then Result := 96
else if S = 'hn' then Result := 97
else if S = 'hr' then Result := 98
else if S = 'ht' then Result := 99
else if S = 'hu' then Result := 100
else if S = 'id' then Result := 101
else if S = 'ie' then Result := 102
else if S = 'il' then Result := 103
else if S = 'in' then Result := 104
else if S = 'io' then Result := 105
else if S = 'iq' then Result := 106
else if S = 'ir' then Result := 107
else if S = 'is' then Result := 108
else if S = 'it' then Result := 109
else if S = 'jm' then Result := 110
else if S = 'jo' then Result := 111
else if S = 'jp' then Result := 112
else if S = 'ke' then Result := 113
else if S = 'kg' then Result := 114
else if S = 'kh' then Result := 115
else if S = 'ki' then Result := 116
else if S = 'km' then Result := 117
else if S = 'kn' then Result := 118
else if S = 'kp' then Result := 119
else if S = 'kr' then Result := 120
else if S = 'kw' then Result := 121
else if S = 'ky' then Result := 122
else if S = 'kz' then Result := 123
else if S = 'la' then Result := 124
else if S = 'lb' then Result := 125
else if S = 'lc' then Result := 126
else if S = 'li' then Result := 127
else if S = 'lk' then Result := 128
else if S = 'lr' then Result := 129
else if S = 'ls' then Result := 130
else if S = 'lt' then Result := 131
else if S = 'lu' then Result := 132
else if S = 'lv' then Result := 133
else if S = 'ly' then Result := 134
else if S = 'ma' then Result := 135
else if S = 'mc' then Result := 136
else if S = 'md' then Result := 137
else if S = 'me' then Result := 138
else if S = 'mg' then Result := 139
else if S = 'mh' then Result := 140
else if S = 'mk' then Result := 141
else if S = 'ml' then Result := 142
else if S = 'mm' then Result := 143
else if S = 'mn' then Result := 144
else if S = 'mo' then Result := 145
else if S = 'mp' then Result := 146
else if S = 'mq' then Result := 147
else if S = 'mr' then Result := 148
else if S = 'ms' then Result := 149
else if S = 'mt' then Result := 150
else if S = 'mu' then Result := 151
else if S = 'mv' then Result := 152
else if S = 'mw' then Result := 153
else if S = 'mx' then Result := 154
else if S = 'my' then Result := 155
else if S = 'mz' then Result := 156
else if S = 'na' then Result := 157
else if S = 'nc' then Result := 158
else if S = 'ne' then Result := 159
else if S = 'nf' then Result := 160
else if S = 'ng' then Result := 161
else if S = 'ni' then Result := 162
else if S = 'nl' then Result := 163
else if S = 'no' then Result := 164
else if S = 'np' then Result := 165
else if S = 'nr' then Result := 166
else if S = 'nu' then Result := 167
else if S = 'nz' then Result := 168
else if S = 'om' then Result := 169
else if S = 'pa' then Result := 170
else if S = 'pe' then Result := 171
else if S = 'pf' then Result := 172
else if S = 'pg' then Result := 173
else if S = 'ph' then Result := 174
else if S = 'pk' then Result := 175
else if S = 'pl' then Result := 176
else if S = 'pm' then Result := 177
else if S = 'pn' then Result := 178
else if S = 'pr' then Result := 179
else if S = 'ps' then Result := 180
else if S = 'pt' then Result := 181
else if S = 'pw' then Result := 182
else if S = 'py' then Result := 183
else if S = 'qa' then Result := 184
else if S = 're' then Result := 185
else if S = 'ro' then Result := 186
else if S = 'rs' then Result := 187
else if S = 'ru' then Result := 188
else if S = 'rw' then Result := 189
else if S = 'sa' then Result := 190
else if S = 'sb' then Result := 191
else if S = 'sc' then Result := 192
else if S = 'scotland' then Result := 193
else if S = 'sd' then Result := 194
else if S = 'se' then Result := 195
else if S = 'sg' then Result := 196
else if S = 'sh' then Result := 197
else if S = 'si' then Result := 198
else if S = 'sj' then Result := 199
else if S = 'sk' then Result := 200
else if S = 'sl' then Result := 201
else if S = 'sm' then Result := 202
else if S = 'sn' then Result := 203
else if S = 'so' then Result := 204
else if S = 'sr' then Result := 205
else if S = 'st' then Result := 206
else if S = 'sv' then Result := 207
else if S = 'sy' then Result := 208
else if S = 'sz' then Result := 209
else if S = 'tc' then Result := 210
else if S = 'td' then Result := 211
else if S = 'tf' then Result := 212
else if S = 'tg' then Result := 213
else if S = 'th' then Result := 214
else if S = 'tj' then Result := 215
else if S = 'tk' then Result := 216
else if S = 'tl' then Result := 217
else if S = 'tm' then Result := 218
else if S = 'tn' then Result := 219
else if S = 'to' then Result := 220
else if S = 'tr' then Result := 221
else if S = 'tt' then Result := 222
else if S = 'tv' then Result := 223
else if S = 'tw' then Result := 224
else if S = 'tz' then Result := 225
else if S = 'ua' then Result := 226
else if S = 'ug' then Result := 227
else if S = 'um' then Result := 228
else if S = 'us' then Result := 229
else if S = 'uy' then Result := 230
else if S = 'uz' then Result := 231
else if S = 'va' then Result := 232
else if S = 'vc' then Result := 233
else if S = 've' then Result := 234
else if S = 'vg' then Result := 235
else if S = 'vi' then Result := 236
else if S = 'vn' then Result := 237
else if S = 'vu' then Result := 238
else if S = 'wales' then Result := 239
else if S = 'wf' then Result := 240
else if S = 'ws' then Result := 241
else if S = 'ye' then Result := 242
else if S = 'yt' then Result := 243
else if S = 'za' then Result := 244
else if S = 'zm' then Result := 245
else if S = 'zw' then Result := 246
else Result := -1;
if Result -1 then Inc(Result, 9);
end;
function AppPath: string;
begin
Result := ExtractFilePath(Application.ExeName);
end;
function FileToStr(const AFile: string): string;
var
sBuffer: AnsiString;
begin
with TFileStream.Create(AFile, fmOpenRead) do try
SetLength(sBuffer, Size);
ReadBuffer(Pointer(sBuffer)^, Size);
Result := string(sBuffer);
finally
Free;
end;
end;
procedure StrToFile(const AFile, S: string);
begin
with TFileStream.Create(AFile, fmCreate) do try
WriteBuffer(Pointer(AnsiString(S))^, Length(S));
finally
Free;
end;
end;
{ TfrmMain }
procedure TfrmMain.UpdateProxyCount;
begin
StatusBar.Panels[0].Text := Format(' Proxy Count: %u', [lvProxies.Items.Count]);
end;
procedure TfrmMain.UpdateThreadCount;
begin
StatusBar.Panels[1].Text := Format(' Thread Count: %u', [iThreadCount]);
end;
procedure TfrmMain.AddProxy(const AProxy: string);
function GetIPPortFromProxy(const AProxy: string; out AIP, APort: string): Boolean;
var
iPos: Integer;
begin
iPos := Pos(':', AProxy);
Result := iPos > 0;
if Result then
begin
AIP := Trim(Copy(AProxy, 1, Pred(iPos)));
APort := Trim(Copy(AProxy, Succ(iPos)));
end;
end;
var
sIP, sPort, sCountryName, sCountryCode: string;
begin
if FProxies.Add(AProxy) then
begin
GetIPPortFromProxy(AProxy, sIP, sPort);
with lvProxies.Items.Add do
begin
Caption := sIP;
SubItems.Add(sPort);
SubItems.Add('-');
SubItems.Add('-');
if Settings.CountryLookup and Assigned(FGeoIP) and GetCountry(sIP,
sCountryName, sCountryCode) then
begin
SubItems.Add(sCountryName + ' (' + sCountryCode + ')');
SubItemImages[3] := GetImageIndex(sCountryCode);
end
else
SubItems.Add('');
SubItems.Add('-');
SubItems.Add('-');
SubItems.Add('-');
SubItems.Add('-');
SubItems.Add('-');
SubItems.Add('-');
SubItems.Add('-');
ImageIndex := 0;
end;
end;
end;
procedure TfrmMain.ExtractProxies(const S: string);
const
PATTERN = '((?:(?:25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\.){3}(?:25[0-5]|' +
'2[0-4][0-9]|[01]?[0-9][0-9]?))(?::|\s+)(6553[0-5]|655[0-2]\d|' +
'65[0-4]\d\d|6[0-4]\d\d\d|[1-5]\d\d\d\d|[1-9]\d{0,3})';
var
Match: TMatch;
begin
lvProxies.Items.BeginUpdate;
try
for Match in TRegex.Matches(S, PATTERN) do
AddProxy(Match.Groups[1].Value + ':' + Match.Groups[2].Value);
finally
lvProxies.Items.EndUpdate;
end;
UpdateProxyCount;
end;
procedure TfrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
procedure SaveSettings;
begin
with TIniFile.Create(AppPath + 'settings.ini'), Settings do try
with Check do
begin
WriteBool('Settings', 'CheckHTTP', HTTP);
WriteBool('Settings', 'CheckSocks4', Socks4);
WriteBool('Settings', 'CheckSocks5', Socks5);
WriteBool('Settings', 'CheckConnect', Connect);
WriteString('Settings', 'Proxyjudge', Proxyjudge);
WriteString('Settings', 'SocksHost', SocksHost);
WriteString('Settings', 'ConnectHost', ConnectHost);
end;
with Timeout do
begin
WriteInteger('Settings', 'ConnectTimeout', Connect);
WriteInteger('Settings', 'ReceiveTimeout', Receive);
WriteInteger('Settings', 'SendTimeout', Send);
WriteInteger('Settings', 'PingTimeout', Ping);
end;
WriteString('Settings', 'MyIP', MyIP);
WriteInteger('Settings', 'ThreadCount', ThreadCount);
WriteInteger('Settings', 'RetryCount', RetryCount);
WriteBool('Settings', 'PingIPs', Ping);
WriteBool('Settings', 'ResolveIPs', Resolve);
WriteBool('Settings', 'CountryLookup', CountryLookup);
WriteBool('Settings', 'Autoscroll', miAutoscroll.Checked);
WriteBool('Settings', 'Maximized', frmMain.WindowState = wsMaximized);
WriteInteger('Form', 'Height', frmMain.Height);
WriteInteger('Form', 'Width', frmMain.Width);
WriteInteger('Form', 'Top', frmMain.Top);
WriteInteger('Form', 'Left', frmMain.Left);
finally
Free;
end;
end;
begin
SaveSettings;
try
StrToFile(AppPath + 'proxy.txt', ProxiesToStr(False));
except
on E: Exception do
MessageDlg(Format('Unable to write "%s": "%s"', [AppPath + 'proxy.txt',
E.Message]), mtError, [mbOK], 0);
end;
end;
procedure TfrmMain.FormCreate(Sender: TObject);
function TryWSAStartup: Boolean;
var
WSAData: TWSAData;
begin
Result := WSAStartup(MakeWord(2, 2), WSAData) = NO_ERROR;
end;
begin
if not TryWSAStartup then
MessageDlg('WSAStartup failed.', mtError, [mbOK], 0);
FProxies := TStringDictionary.Create;
FProxies.CaseInsensitive := True;
ilItemIndexes := TList.Create;
InitializeCriticalSection(CriticalSection);
ProgressBar.Parent := StatusBar;
FGeoIP := nil;
//if Settings.CountryLookup then
try
FGeoIP := TGeoIP.Create(AppPath + 'GeoIP.dat');
except
//FGeoIP := nil;
end;
end;
procedure TfrmMain.FormDestroy(Sender: TObject);
begin
FProxies.Free;
ilItemIndexes.Free;
DeleteCriticalSection(CriticalSection);
if Assigned(FGeoIP) then FGeoIP.Free;
WSACleanup;
end;
procedure TfrmMain.FormResize(Sender: TObject);
var
Rect: TRect;
begin
SendMessage(StatusBar.Handle, SB_GETRECT, 2, Integer(@Rect));
with Rect do ProgressBar.SetBounds(Left, Top, Right - Left, Bottom - Top);
end;
procedure TfrmMain.FormShow(Sender: TObject);
procedure LoadSettings;
begin
with TIniFile.Create(AppPath + 'settings.ini'), Settings do try
with Check do
begin
HTTP := ReadBool('Settings', 'CheckHTTP', DEFAULT_SETTINGS.Check.HTTP);
Socks4 := ReadBool('Settings', 'CheckSocks4', DEFAULT_SETTINGS.Check.Socks4);
Socks5 := ReadBool('Settings', 'CheckSocks5', DEFAULT_SETTINGS.Check.Socks5);
Connect := ReadBool('Settings', 'CheckConnect', DEFAULT_SETTINGS.Check.Connect);
Proxyjudge := ReadString('Settings', 'Proxyjudge', DEFAULT_SETTINGS.Check.Proxyjudge);
SocksHost := ReadString('Settings', 'SocksHost', DEFAULT_SETTINGS.Check.SocksHost);
ConnectHost := ReadString('Settings', 'ConnectHost', DEFAULT_SETTINGS.Check.ConnectHost);
end;
with Timeout do
begin
Connect := ReadInteger('Settings', 'ConnectTimeout', DEFAULT_SETTINGS.Timeout.Connect);
Receive := ReadInteger('Settings', 'ReceiveTimeout', DEFAULT_SETTINGS.Timeout.Receive);
Send := ReadInteger('Settings', 'SendTimeout', DEFAULT_SETTINGS.Timeout.Send);
Ping := ReadInteger('Settings', 'PingTimeout', DEFAULT_SETTINGS.Timeout.Ping);
end;
MyIP := ReadString('Settings', 'MyIP', DEFAULT_SETTINGS.MyIP);
ThreadCount := ReadInteger('Settings', 'ThreadCount', DEFAULT_SETTINGS.ThreadCount);
RetryCount := ReadInteger('Settings', 'RetryCount', DEFAULT_SETTINGS.RetryCount);
Ping := ReadBool('Settings', 'PingIPs', DEFAULT_SETTINGS.Ping);
Resolve := ReadBool('Settings', 'ResolveIPs', DEFAULT_SETTINGS.Resolve);
CountryLookup := ReadBool('Settings', 'CountryLookup', DEFAULT_SETTINGS.CountryLookup);
miAutoscroll.Checked := ReadBool('Settings', 'Autoscroll', True);
if ReadBool('Settings', 'Maximized', False) then
frmMain.WindowState := wsMaximized
else
begin
frmMain.Height := ReadInteger('Form', 'Height', 300);
frmMain.Width := ReadInteger('Form', 'Width', 700);
frmMain.Top := ReadInteger('Form', 'Top', 0);
frmMain.Left := ReadInteger('Form', 'Left', 0);
end;
finally
Free;
end;
end;
var
iErrorCode: Integer;
bIsTimeout: Boolean;
begin
LoadSettings;
if FileExists(AppPath + 'proxy.txt') then
try
ExtractProxies(FileToStr(AppPath + 'proxy.txt'));
except
on E: Exception do
MessageDlg(Format('Unable to read "%s": "%s"', [AppPath + 'proxy.txt',
E.Message]), mtError, [mbOK], 0);
end;
if not GetMyIP(Settings.MyIP, iErrorCode, bIsTimeout) then
begin
if bIsTimeout then
MessageDlg('Unable to get my IP: Timeout', mtError, [mbOK], 0)
else
MessageDlg(Format('Unable to get my IP: "%s"',
[sysErrorMessage(iErrorCode)]), mtError, [mbOK], 0);
end;
end;
procedure TfrmMain.lvProxiesCustomDrawItem(Sender: TCustomListView;
Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
begin
{if Odd(Item.Index) then
(Sender as TListView).Canvas.Brush.Color := $F0F0F0
else
(Sender as TListView).Brush.Color := clWindow;}
end;
procedure TfrmMain.lvProxiesCustomDrawSubItem(Sender: TCustomListView;
Item: TListItem; SubItem: Integer; State: TCustomDrawState;
var DefaultDraw: Boolean);
begin
{if SubItem = 2 then
begin
if Item.SubItems[Pred(SubItem)] = 'resolving' then
Sender.Canvas.Font.Color := clGray
else
Sender.Canvas.Font.Color := ColorToRGB(clWindowText);
end
else
Sender.Canvas.Font.Color := ColorToRGB(clWindowText);}
end;
procedure TfrmMain.miAddClick(Sender: TObject);
var
S: string;
begin
if InputQuery('Add Proxy', 'Enter Proxy: ', S) then ExtractProxies(S);
end;
procedure TfrmMain.miCheckAllClick(Sender: TObject);
procedure FillItemIndexes(ASelected: Boolean);
var
I: Integer;
begin
ilItemIndexes.Clear;
if ASelected then
begin
for I := 0 to Pred(lvProxies.Items.Count) do
if lvProxies.Items[i].Selected then ilItemIndexes.Add(I);
end
else
begin
for I := 0 to Pred(lvProxies.Items.Count) do
ilItemIndexes.Add(I);
end;
end;
procedure StartThreads(AThreadCount: Integer);
var
I: Integer;
C: Cardinal;
begin
iThreadCount := 0;
for I := 1 to AThreadCount do
BeginThread(nil, 0, @ThreadProc, nil, 0, C);
end;
begin
FillItemIndexes((Sender as TMenuItem).Tag = 1);
bAbort := False;
with tbtnCheck do
begin
Caption := 'Abort';
ImageIndex := 6;
end;
with ProgressBar do
begin
Max := ilItemIndexes.Count;
StatusBar.Panels[3].Text := Format(' checking; %u of %u proxy/ies ' +
'checked (%f%%)', [Position, Max, Position / Max * 100]);
end;
tbtnSettings.Enabled := False;
if ilItemIndexes.Count >= Settings.ThreadCount then
StartThreads(Settings.ThreadCount)
else
StartThreads(ilItemIndexes.Count);
end;
procedure TfrmMain.miCopyAllClick(Sender: TObject);
begin
ClipBoard.AsText := ProxiesToStr((Sender as TMenuItem).Tag = 1);
end;
procedure TfrmMain.miLoadClick(Sender: TObject);
begin
if OpenDialog.Execute then
try
ExtractProxies(FileToStr(OpenDialog.FileName));
except
on E: Exception do
MessageDlg(Format('Unable to open/read "%s": "%s"',
[OpenDialog.FileName, E.Message]), mtError, [mbOK], 0);
end;
end;
procedure TfrmMain.miPasteClick(Sender: TObject);
begin
ExtractProxies(ClipBoard.AsText);
end;
procedure TfrmMain.miRemoveAllClick(Sender: TObject);
begin
FProxies.Clear;
lvProxies.Clear;
UpdateProxyCount;
end;
procedure TfrmMain.miRemoveSelectedClick(Sender: TObject);
var
I: Integer;
begin
with lvProxies do
begin
for I := 0 to Pred(Items.Count) do
if Items[i].Selected then
FProxies.Delete(Items[i].Caption + Items[i].SubItems[0]);
DeleteSelected;
end;
UpdateProxyCount;
end;
procedure TfrmMain.miSaveAllClick(Sender: TObject);
begin
if SaveDialog.Execute then
try
StrToFile(SaveDialog.FileName, ProxiesToStr((Sender as TMenuItem).Tag = 1));
except
on E: Exception do
MessageDlg(Format('Unable to open/write "%s": "%s"',
[saveDialog.FileName, E.Message]), mtError, [mbOK], 0);
end;
end;
procedure TfrmMain.miSelectAllClick(Sender: TObject);
begin
lvProxies.SelectAll;
end;
procedure TfrmMain.miSelectHTTPClick(Sender: TObject);
var
I, J: Integer;
begin
J := (Sender as TMenuItem).Tag + 4;
with lvProxies do
begin
Items.BeginUpdate;
try
for I := 0 to Pred(Items.Count) do
if Items[i].SubItemImages[J] = 2 then Items[i].Selected := True;
finally
Items.EndUpdate;
end;
end;
end;
procedure TfrmMain.pmCheckPopup(Sender: TObject);
begin
miCheckAll.Enabled := lvProxies.Items.Count > 0;
miCheckSelected.Enabled := lvProxies.SelCount > 0;
end;
procedure TfrmMain.pmExportPopup(Sender: TObject);
begin
with lvProxies do
begin
miCopy.Enabled := Items.Count > 0;
miCopySelected.Enabled := SelCount > 0;
miSave.Enabled := Items.Count > 0;
miSaveSelected.Enabled := SelCount > 0;
end;
end;
procedure TfrmMain.pmImportPopup(Sender: TObject);
begin
miPaste.Enabled := Trim(ClipBoard.AsText) '';
end;
procedure TfrmMain.pmProxiesPopup(Sender: TObject);
begin
with lvProxies do
begin
miSelect.Enabled := Items.Count > 0;
miPaste1.Enabled := Trim(ClipBoard.AsText) '';
miExport.Enabled := Items.Count > 0;
miRemove.Enabled := (iThreadCount = 0) and (Items.Count > 0);
miRemoveSelected.Enabled := SelCount > 0;
miCopySelected.Enabled := SelCount > 0;
miSaveSelected.Enabled := SelCount > 0;
end;
end;
procedure TfrmMain.pmRemovePopup(Sender: TObject);
begin
miRemoveAll.Enabled := (iThreadCount = 0) and (lvProxies.Items.Count > 0);
miRemoveSelected.Enabled := (iThreadCount = 0) and (lvProxies.SelCount > 0);
end;
function TfrmMain.ProxiesToStr(ASelected: Boolean): string;
var
I: Integer;
begin
Result := '';
with lvProxies do
if ASelected then
begin
for I := 0 to Pred(Items.Count) do
if Items[i].Selected then
Result := Result + Items[i].Caption + ':' + Items[i].SubItems[0] +
sLineBreak;
end
else
begin
for I := 0 to Pred(Items.Count) do
Result := Result + Items[i].Caption + ':' + Items[i].SubItems[0] +
sLineBreak;
end;
end;
procedure TfrmMain.tbtnAboutClick(Sender: TObject);
begin
MessageDlg(Format('ProxyChecker%scoded by trip%sin Delphi XE3%s%sthanks to ' +
'famfamfam.com for the icons', [sLineBreak, sLineBreak, sLineBreak,
sLineBreak]), mtInformation, [mbOK], 0);
end;
procedure TfrmMain.tbtnCheckClick(Sender: TObject);
begin
if tbtnCheck.Caption = 'Check' then
ShowPopupMenuByCursor(pmCheck)
else if tbtnCheck.Caption = 'Abort' then
begin
tbtnCheck.Caption := 'aborting';
bAbort := True;
end;
end;
procedure TfrmMain.tbtnExportClick(Sender: TObject);
begin
ShowPopupMenuByCursor(pmExport);
end;
procedure TfrmMain.tbtnImportClick(Sender: TObject);
begin
ShowPopupMenuByCursor(pmImport);
end;
procedure TfrmMain.tbtnRemoveClick(Sender: TObject);
begin
ShowPopupMenuByCursor(pmRemove);
end;
procedure TfrmMain.tbtnSettingsClick(Sender: TObject);
begin
frmSettings.ShowModal;
end;
procedure TfrmMain.ThreadMessage(var AMessage: TMessage);
var
UpdateItem: PUpdateItem;
begin
case AMessage.WParam of
TH_UPDATE_ITEM:
begin
UpdateItem := PUpdateItem(AMessage.LParam);
try
with UpdateItem^, lvProxies.Items[itemIndex] do
begin
if Text '' then SubItems[subItemIndex] := Text;
if ImgIndex -1 then ImageIndex := ImgIndex;
if SubItemImageIndex -1 then
SubItemImages[subItemIndex] := SubItemImageIndex;
end;
finally
Dispose(UpdateItem);
end;
end;
TH_START:
begin
if miAutoscroll.Checked then
lvProxies.Items[AMessage.LParam].MakeVisible(False);
end;
TH_STATUS:
begin
lvProxies.Items[AMessage.LParam].ImageIndex := 8;
with ProgressBar do
begin
StepIt;
StatusBar.Panels[3].Text := Format(' checking; %u of %u proxy/ies ' +
'checked (%f%%)', [Position, Max, Position / Max * 100]);
end;
end;
TH_THREAD_START: UpdateThreadCount;
TH_THREAD_END:
begin
UpdateThreadCount;
if iThreadCount = 0 then
begin
with tbtnCheck do
begin
Caption := 'Check';
ImageIndex := 0;
end;
tbtnSettings.Enabled := True;
StatusBar.Panels[3].Text := ' Check completed';
ProgressBar.Position := 0;
ilItemIndexes.Clear;
end;
end;
end;
end;
end.