unit udwsclient;//========================================================================// Delphi Web Start Pattern// provide a technique to start apps from a TCPServer
// based on Dr. Karlheinz M鰎th and Max Kleiner
// model: Indy Toolset;
// Ex.:  with IdTCPClient1 do begin
//         if Connected then DisConnect;
//         showStatus;
//         Host:= edHost.Text;
//         Port:= StrToInt(edPort.Text);
//         Connect;
//         WriteLn(CTR_LIST);
// V1.0 lokal const with path check
// V1.1 libc execute of apps
// V1.2 compilerdirectives, execute of win apps  19.3.03
//   files already on disk aren't transported
// bug_a: filenames with spaces doesn't work
// still searching for a real progressbar while reading from indy-buffer
// to solve with events onWork...
// V1.5 version check control on client, simple on name
// V1.5 exit message to server, letTCPConnect, antifreeze component, LoCs=294
// this CLX app needs qtintf70.dll
// http://max.kleiner.com, max@kleiner.com
//========================================================================
interfaceuses  SysUtils, Types, Classes, QGraphics, QControls, QForms, QDialogs,  QStdCtrls, IdBaseComponent, IdComponent, IdTCPConnection,  IdTCPClient,  IdAntiFreezeBase, IdAntiFreeze, QExtCtrls,  QComCtrls;type  TfrmDWS = class(TForm)    Panel1: TPanel;    Panel2: TPanel;    Panel3: TPanel;    Panel4: TPanel;    Label2: TLabel;    Label3: TLabel;    Label4: TLabel;    Label5: TLabel;    Label6: TLabel;    Splitter1: TSplitter;    edHost: TEdit;    edPath: TEdit;    edPort: TEdit;    btngetfile: TButton;    IdTCPClient1: TIdTCPClient;    lbStatus: TListBox;    lbres: TListBox;    IdAntiFreeze1: TIdAntiFreeze;    lblload: TLabel;    pnlProgbar: TPanel;    progbar: TProgressBar;    chkBVersion: TCheckBox;    startimage: TImage;    procedure btngetfileClick(Sender: TObject);    procedure FormCreate(Sender: TObject);    procedure lbResDblClick(Sender: TObject);    procedure IdTCPClient1Disconnected(Sender: TObject);    procedure IdTCPClient1Work(Sender: TObject; AWorkMode: TWorkMode;
      const AWorkCount: Integer);    procedure FormDestroy(Sender: TObject);  private    procedure showStatus;    function sureDisconnect: boolean;    procedure letTCPConnect;  public    { Public declarations }  end;var  frmDWS: TfrmDWS;implementation{$R *.xfm}{$IFDEF LINUX}uses libc;{$ENDIF}{$IFDEF MSWINDOWS}uses shellapi, windows, starter;{$ENDIF}const  kAnswer = 1;
  kEnd    = 2;
  kEmpty  = 3;
  CTR_LIST = 'return_list';
  CTR_FILE = 'return_file ';
  CTR_END = 'client exit: ';

function ReturnType(const s: String): word;begin
  if pos(s, '::END::') > 0 then Result:= kEnd else
  if length(Trim(s)) = 0 then Result:= kEmpty else
    Result:= kAnswer;
end;

procedure TfrmDWS.btngetfileClick(Sender: TObject);var  sReturn: String;
  wAnswerType: Word;
  LineCnt: Integer;
begin
  lbres.Visible:= true;
  startimage.Free;
  with IdTCPClient1 do begin
    letTCPConnect;
    showStatus;
    try
      //writeln('this is testmessage');
      WriteLn(CTR_LIST);
      lbres.Clear;
      LineCnt:= 0;
      repeat
        sReturn:= ReadLn;
        wAnswerType:= ReturnType(sReturn);
        if wAnswerType = kAnswer then begin
          lbres.Items.Add(sReturn);
          inc(LineCnt);
        end;
      until wAnswerType = kEnd;
      lbStatus.Items.Insert(0, Format('%-20s %s',
      [DateTimeToStr(now), 'DWS Server Files available: '
                + IntToStr(LineCnt) + ' entries']));
      sureDisconnect;
    except
      on E: Exception do ShowMessage(E.Message);
    end;  end; //withend;procedure TfrmDWS.FormCreate(Sender: TObject);begin  ShortDateFormat:= 'dd.mm.yyyy';  LongTimeFormat:= 'hh.mm.ss';  //just a test to find a real progressbar  with progbar do begin     visible:= True;
     Min:= 0;
     //Max:= Size;
     Step:= 5;
  end;
  IdAntiFreeze1.active:= true;
  IdAntiFreeze1.IdleTimeOut:= 500;
  lbres.visible:= false;
  lbStatus.Items.Insert(0, Format('%-20s %s',
     [DateTimeToStr(now), 'DWS client started...']));
  lbStatus.Items.Insert(0, IdTCPClient1.LocalName +'  Client');
  edHost.Text:= IdTCPClient1.LocalName;
  //edHost.Text:= IdTCPClient1.Host;
  //debug
end;
procedure TfrmDWS.lbResDblClick(Sender: TObject);var  FileStream: TFileStream;
  fname: String;begin
  with IdTCPClient1 do begin
    letTCPConnect;
    showStatus;
    //progbar.Repaint;
    try
      lbStatus.Items.Insert(0, Format('%-20s %s',
          [DateTimeToStr(now), 'Copy... ' +
          ExtractFileName(lbres.Items[lbres.ItemIndex])]));
      WriteLn(CTR_FILE + lbres.Items[lbres.ItemIndex]);
      fname:= ExpandFileName(edPath.Text + '/' +
        ExtractFileName(lbres.Items[lbres.ItemIndex]));
      delete(fname,pos(' ',fname),length(fname)- pos(' ', fname) + 1);
      if not DirectoryExists(ExtractFileDir(fname)) then
        ForceDirectories(ExtractFileDir(fname));
      //TStarter not on Linux
      if chkBVersion.Checked then
      if not TStarter.checkNameVersion(fname) then begin
        FileStream:= TFileStream.Create(fname, fmCreate);
        while connected do begin
          //progbar.Max:= filestream.size;
          //true means read until disconnect
          ReadStream(FileStream, -1, true);
          //currentReadBuffersize;
          lbStatus.Items.Insert(0, Format('%-20s %s',
          [DateTimeToStr(now),IntToStr(FileStream.Size)+ ' Chk Bytes copied']));
        end;
       FreeAndNil(FileStream);
       sureDisconnect;
      end; //if
      if not chkBVersion.Checked then begin
        FileStream:= TFileStream.Create(fname, fmCreate);
        while connected do
          ReadStream(FileStream, -1, true);
        lbStatus.Items.Insert(0, Format('%-20s %s',
        [DateTimeToStr(now), IntToStr(FileStream.Size) + ' Bytes copied']));
        FreeAndNil(FileStream);
        sureDisconnect;
      end;
     //then start application
     {$IFDEF LINUX}
      pid:= fork;
        if pid = 0 then begin
          if execvp(pchar(fname),NIL) <> 0 then halt(1);
        end else begin
          waitpid(pid, @status, 0);
        end;
      //execv(pchar(filename),NIL);
      //libc.system(pchar(filename));
     {$ENDIF}
     {$IFDEF MSWINDOWS}
     // shellapi.WinExec('c:\testcua.bat', SW_SHOW);
     with lbStatus.items do begin
       case shellapi.shellExecute(0,'open', pchar(fname), '',NIL,
                    SW_SHOWNORMAL) of
         0: insert(0, 'out of memory or resources');
         ERROR_BAD_FORMAT: insert(0, 'file is invalid in image');
         ERROR_FILE_NOT_FOUND: insert(0,'file was not found');
         ERROR_PATH_NOT_FOUND: insert(0,'path was not found');
       end;
       Insert(0, Format('%-20s %s',
               [DateTimeToStr(now), fname + ' Loaded...']));
     end
     {$ENDIF}
    except
      on E: Exception do ShowMessage(E.Message);
    end;
  end; //with
end;
procedure TfrmDWS.showStatus;begin  lbStatus.Items.Insert(0, Format('%-20s %s',       [DateTimeToStr(now), 'connect to DWS Server ...']));
  lbStatus.Items.Insert(0, Format('%-20s %s %s',
       [DateTimeToStr(now), 'Host: ', edHost.Text]));
  lbStatus.Items.Insert(0, Format('%-20s %s %s',
       [DateTimeToStr(now), 'Port: ', edPort.Text]));
end;function TfrmDWS.sureDisconnect: boolean;begin
 result:= false;
 if IdTCPClient1.Connected then
 try
   IdTCPClient1.Disconnect;
   repeat
     until NOT IdTCPClient1.Connected;
   result:= true;
 except
 end;
end;

procedure TfrmDWS.IdTCPClient1Disconnected(Sender: TObject);begin
  lbStatus.Items.Insert(0, Format('%-20s %s',
     [DateTimeToStr(now), 'DWS Connection closed ...']));
end;

procedure TfrmDWS.IdTCPClient1Work(Sender: TObject; AWorkMode: TWorkMode;  const AWorkCount: Integer);
begin
  //progbar.Step:= aWorkCount div 8 ;
  progbar.StepIt;
end;

procedure TfrmDWS.FormDestroy(Sender: TObject);begin
  with IdTCPClient1 do begin
    letTCPConnect;
    WriteLn(CTR_END + IdTCPClient1.LocalName);
    sureDisconnect;
  end;
end;

procedure TfrmDWS.letTCPConnect;begin
  with IdTCPClient1 do begin
    if Connected then sureDisconnect;
    Host:= edHost.Text;
    Port:= StrToInt(edPort.Text);
    Connect;
  end;
end;

end.