u_dwsserver1.pas

一个开源软件

unit u_dwsserver1;

//========================================================================
// DelphiWebStart
// provide a technique to start delphi apps from a TCPServer
// based on Dr. Karlheinz M鰎th and Max Kleiner
// model: Indy Toolset;
// Ex.:  if sRequest = CTR_LIST then begin
//         for idx:= 0 to meData.Lines.Count - 1 do
//    aThread.Connection.WriteLn(ExtractFileName(meData.Lines[idx]));
//    aThread.Connection.WriteLn('::END::');
//    aThread.Connection.Disconnect;
// V1.0 lokal const with path check
// V1.1 set port on 9010/TCP
// V1.2 set on windows with QLibrary
// V1.5 state logger enhanced, save&load at runtime, modified flag,
// check date name to optimize download, new changefinder,
// V1.6 load files from any path on the server (getFullPath2),LOCs=308
// this CLX app needs qtintf70.dll
// http://max.kleiner.com, [e-mail]
//========================================================================

interface

uses
  SysUtils, Types, Classes, QControls, QForms, QDialogs,
  QMenus, QTypes, IdBaseComponent, IdComponent, IdTCPServer, QStdCtrls,
  QExtCtrls, QGrids, udwsfiler;

type
  TAppLoaderFrm_Server = class(TForm)
    Label1: TLabel;
    Panel1: TPanel;
    Panel2: TPanel;
    Panel3: TPanel;
    meData: TMemo;
    Splitter1: TSplitter;
    lbStatus: TListBox;
    cbActivated: TCheckBox;
    IdTCPServer1: TIdTCPServer;
    PopupMn_LList: TPopupMenu;
    LoadlistFile: TMenuItem;
    SaveListFile: TMenuItem;
    strGrd: TStringGrid;
    Label2: TLabel;
    pnlCF: TPanel;
    edtDrive: TEdit;
    Label3: TLabel;
    btnchfind: TButton;
    procedure LoadBinariesListClick(Sender: TObject);
    procedure SaveBinariesListClick(Sender: TObject);
    procedure IdTCPServer1Execute(AThread: TIdPeerThread);
    procedure IdTCPServer1Connect(AThread: TIdPeerThread);
    procedure IdTCPServer1Disconnect(AThread: TIdPeerThread);
    procedure cbActivatedClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure strgrdGetEditText(Sender: TObject; ACol, ARow: Integer;
      var Value: WideString);
    procedure strgrdSetEditText(Sender: TObject; ACol, ARow: Integer;
      const Value: WideString);
    procedure strgrdSelectCell(Sender: TObject; ACol, ARow: Integer;
      var CanSelect: Boolean);
    procedure btnchfindClick(Sender: TObject);
  private
    myGridC: TBuildAppGrid;
    myDatFile: shortString;
    function GetFullPath(const filename: String): String;
    function GetFullPath2(const filename: String): String;
    procedure gridToMemo;
   public
    { Public declarations }
  end;

var
  AppLoaderFrm_Server: TAppLoaderFrm_Server;

implementation

 uses changefind;

{$R *.xfm}

const
  CTR_LIST = 'return_list';
  CTR_FILE = 'return_file';
  FILE_PATH = 'binaries3.txt';
  DWS_PORT = 9010;
  DWSVersion ='V1.6';

function TAppLoaderFrm_Server.GetFullPath(const filename: String): String;
var
  idx: Integer;
begin
  for idx:= 0 to meData.Lines.count - 1 do
    if Pos(filename, meData.Lines[idx]) > 0 then
      Result:= ExpandFileName(filename);
end;

function TAppLoaderFrm_Server.GetFullPath2(const filename: String): String;
var
  idx: Integer;
begin
  for idx:= 0 to strGrd.RowCount -1 do
    if Pos(filename, strGrd.Cells[0,idx]) > 0 then
      result:= strGrd.Cells[0, idx];
end;

procedure TAppLoaderFrm_Server.LoadBinariesListClick(Sender: TObject);
begin
  with TOpenDialog.Create(NIL) do begin
    FileName:= '*.txt';
    if Execute then begin
      //myDatFile:= FileName;
      myGridC.aDatfile:= FileName;
      myGridC.fillGrid;
      gridToMemo;
      lbStatus.Items.Insert(0, Format('%-20s %s',
        [DateTimeToStr(now), 'Definitionfile activated: ' + FileName]));
    end;
   free;
  end;
end;

procedure TAppLoaderFrm_Server.SaveBinariesListClick(Sender: TObject);
begin
  with TSaveDialog.Create(NIL) do begin
    filename:= '*.txt';
    if Execute then begin
      myGridC.aDatfile:= filename;
      if FileExists(filename) then begin
        if MessageDlg('File exists!, do you want to override?',
        mtConfirmation, [mbYes, mbNo], 0) = mrYes then begin
          myGridC.storeGrid;
          lbStatus.Items.Insert(0, Format('%-20s %s',
          [DateTimeToStr(now), 'Existing Definitionfile overwrite: '+ filename]));
        end;
      end else begin
         myGridC.storeGrid;
         lbStatus.Items.Insert(0, Format('%-20s %s',
         [DateTimeToStr(now), 'New Definitionfile stored: ' + filename]));
      end;
    end;
    Free;
  end;
end;

procedure TAppLoaderFrm_Server.IdTCPServer1Execute(AThread: TIdPeerThread);
var
  fname, sRequest: String;
  idx, iPos: Integer;
  FileStream: TFileStream;
begin
  sRequest:= AThread.Connection.ReadLn;
  lbStatus.Items.Insert(0, Format('%-20s %s %s',
    [DateTimeToStr(now), AThread.Connection.Socket.Binding.PeerIP, sRequest]));
  // comes with writeline from client
  if sRequest = CTR_LIST then begin
    for idx:= 0 to meData.Lines.Count - 1 do
    AThread.Connection.WriteLn(ExtractFileName(meData.Lines[idx]));
    AThread.Connection.WriteLn('::END::');
    AThread.Connection.Disconnect;
    lbStatus.Items.Insert(0, Format('%-20s %s',
      [DateTimeToStr(now), 'return filelist ...']));
  end else
  if Pos(CTR_FILE, sRequest) > 0 then begin
    iPos:= Pos(CTR_FILE, sRequest);
    fname:= Trim(copy(sRequest, iPos+12, length(sRequest)- iPos - 11));
    delete(fname,pos(' ',fname),
               length(fname)- pos(' ', fname) + 1);
    fname:= GetFullPath2(fname);
    lbStatus.Items.Insert(0, Format('%-20s %s',
       [DateTimeToStr(now), 'Filename: ' + fname]));
    if FileExists(fname) then begin
      lbStatus.Items.Insert(0, Format('%-20s %s',
        [DateTimeToStr(now), 'Transfer starts ...']));
      FileStream := TFileStream.Create(fname, fmOpenRead + fmShareDenyNone);
      try
        AThread.Connection.OpenWriteBuffer;
        AThread.Connection.WriteStream(FileStream);
        AThread.Connection.CloseWriteBuffer;
      finally
        FreeAndNil(FileStream);
        AThread.Connection.Disconnect;
        lbStatus.Items.Insert(0, Format('%-20s %s',
          [DateTimeToStr(now), 'Transfer finished ...']));
      end
    end else lbStatus.Items.Insert(0, 'File not Found...');
  end;
end;

procedure TAppLoaderFrm_Server.IdTCPServer1Connect(AThread: TIdPeerThread);
begin
  lbStatus.Items.Insert(0, Format('%-20s %s',
  [DateTimeToStr(now), 'DWS Connected with ' +
                AThread.Connection.Socket.Binding.PeerIP]));
                //+ connection.socket in D7
end;

procedure TAppLoaderFrm_Server.IdTCPServer1Disconnect(AThread: TIdPeerThread);
begin
  lbStatus.Items.Insert(0, Format('%-20s %s',
     [DateTimeToStr(now), 'DWS Connection closed']));
end;

procedure TAppLoaderFrm_Server.cbActivatedClick(Sender: TObject);
begin
  if cbActivated.Checked then begin
      IdTCPServer1.Active:= true;
      IdTCPServer1.defaultPort:= DWS_PORT;
  end else IdTCPServer1.Active:= false;
  cbActivated.Checked := IdTCPServer1.Active;
  case cbActivated.Checked of
    true: lbStatus.Items.Insert(0, Format('%-20s %s',
      [DateTimeToStr(now), 'DWS Server activ on port: ' + intToStr(DWS_PORT)]));
    false: lbStatus.Items.Insert(0, Format('%-20s %s',
      [DateTimeToStr(now), 'DWS Server is halted ... ']));
  end;
end;

procedure TAppLoaderFrm_Server.FormCreate(Sender: TObject);
begin
  myDatFile:= FILE_PATH;
  myGridC:= TBuildAppGrid.Create_initGrid(strGrd, myDatFile);
  myGridC.fillGrid;
  ShortDateFormat := 'dd.mm.yyyy';
  LongTimeFormat := 'hh.mm.ss';
  meData.WordWrap:= false;
  meData.ScrollBars:= ssAutoBoth;
  AppLoaderFrm_Server.Caption:= 'DelphiWebStart '+DWSVersion;
  //meData.Lines.LoadFromFile(ExpandFileName(FILE_PATH));
  if fileexists(FILE_PATH) then begin
    gridToMemo;
    lbStatus.Items.Insert(0, Format('%-20s %s',
       [DateTimeToStr(now), 'State Logger started, DWS '+DWSVersion]));
    lbStatus.Items.Insert(0, Format('%-20s %s',
       [DateTimeToStr(now), 'Definitionfile activated: ' + myDatFile]));
    lbStatus.Items.Insert(0, Format('%-20s %s',
       [DateTimeToStr(now), 'DWSServer.exe /allowinstances not set']));
  end;
end;

procedure TAppLoaderFrm_Server.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  myGridC.storeGrid;
  myGridC.Free;
end;


procedure TAppLoaderFrm_Server.strgrdGetEditText(Sender: TObject; ACol, ARow: Integer;
  var Value: WideString);
begin
  // cause of linux names
  if ACol = 0 then
    if value <> '' then
     Value:= AnsiLowerCase(Value);
end;

procedure TAppLoaderFrm_Server.strgrdSetEditText(Sender: TObject; ACol, ARow: Integer;
  const Value: WideString);
begin
  if ACol = 1 then begin
    try
      if value <> '' then
        strtoInt(Value);
    except
      raise Exception.Create('must be an integer value in app size');
    end;
  end;
 //myGridC.modified:= false;
// better solution in selectcell
end;

procedure TAppLoaderFrm_Server.gridToMemo;
var crow: integer;
begin
  //shows appname, date and description
  medata.Lines.Clear;
  for crow:= 1 to Pred(strGrd.RowCount) do begin
    medata.Lines.Add(format('%-5s %25s %10s',
       [strGrd.Cells[0, crow], strGrd.Cells[3, crow],
                strGrd.Cells[2, crow]]));
  end;
end;

procedure TAppLoaderFrm_Server.strgrdSelectCell(Sender: TObject; ACol,
  ARow: Integer; var CanSelect: Boolean);
begin
  myGridC.modified:= true;
end;

procedure TAppLoaderFrm_Server.btnchfindClick(Sender: TObject);
 var mycf: TChangeFinder;
     drive: string[10];
begin
  screen.cursor:=crHourglass;
  drive:= edtDrive.Text + ':';
  mycf:= TChangeFinder.Create_prepList_and_Date(lbStatus);
  try
    mycf.SearchDirectories(drive + '\','*.*');
  finally
    mycf.Free;
  end;
  screen.cursor:=crDefault;
end;


end.