udwsclient.pas

一个开源软件

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, [e-mail]
//========================================================================


interface

uses
  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; //with
end;

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.