fmain.pas

千年源代码,只缺少控件,可以做二次开发用,好不容易得来的

unit FMain;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ScktComp, StdCtrls, ComCtrls, iniFiles, mmSystem, uRecordDef, ExtCtrls,
  uKeyClass;

type
  TfrmMain = class(TForm)
    sckRemoteAccept: TServerSocket;
    cmdClose: TButton;
    PageControl1: TPageControl;
    tsEvent: TTabSheet;
    tsMonitor: TTabSheet;
    lstEvent: TListBox;
    txtLog: TMemo;
    sckAccept: TServerSocket;
    cmdAddRecord: TButton;
    tsStatus: TTabSheet;
    StaticText1: TStaticText;
    lblTotalRecordCount: TStaticText;
    StaticText3: TStaticText;
    lblUsedRecordCount: TStaticText;
    StaticText5: TStaticText;
    lblUnusedRecordCount: TStaticText;
    timerDisplay: TTimer;
    timerProcess: TTimer;
    StaticText7: TStaticText;
    lblGateConnectCount: TStaticText;
    StaticText9: TStaticText;
    lblRemoteConnectCount: TStaticText;
    StaticText11: TStaticText;
    lblElaspedTime: TStaticText;
    cmdSaveUserData: TButton;
    cmdBackup: TButton;
    StaticText2: TStaticText;
    lblLockedCount: TStaticText;
    sckItemRemote: TServerSocket;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure cmdCloseClick(Sender: TObject);
    procedure sckRemoteAcceptAccept(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure sckRemoteAcceptClientConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure sckRemoteAcceptClientDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure sckRemoteAcceptClientError(Sender: TObject;
      Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
      var ErrorCode: Integer);
    procedure sckRemoteAcceptClientRead(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure sckRemoteAcceptClientWrite(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure sckAcceptAccept(Sender: TObject; Socket: TCustomWinSocket);
    procedure sckAcceptClientConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure sckAcceptClientDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure sckAcceptClientError(Sender: TObject;
      Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
      var ErrorCode: Integer);
    procedure sckAcceptClientRead(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure sckAcceptClientWrite(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure cmdAddRecordClick(Sender: TObject);
    procedure timerDisplayTimer(Sender: TObject);
    procedure timerProcessTimer(Sender: TObject);
    procedure cmdSaveUserDataClick(Sender: TObject);
    procedure cmdBackupClick(Sender: TObject);
    procedure sckItemRemoteAccept(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure sckItemRemoteClientDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure sckItemRemoteClientError(Sender: TObject;
      Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
      var ErrorCode: Integer);
    procedure sckItemRemoteClientRead(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure sckItemRemoteClientWrite(Sender: TObject;
      Socket: TCustomWinSocket);
  private
    { Private declarations }
    BackupStream : TFileStream;
    boBackup : Boolean;
    BackupPos : Integer;
  public
    { Public declarations }
    procedure AddEvent (aStr : String);
    procedure AddLog (aStr : String);

    function GetUserDataFields : String;
    function GetItemDataFields : String;

    procedure AddTodayData (KeyValue, aStr : String);
    procedure SaveTodayData (aFileName : String);

    function BackupFDB : Boolean;
  end;

var
  frmMain: TfrmMain;

  ElaspedSec, StartTick : Integer;

  FDBFileName : String;
  BufferSizeS2S : Integer;
  GateAcceptPort, RemoteAcceptPort, ItemRemoteAcceptPort : Integer;

  TodayDate : TDateTime;
  TodayCharList : TStringList;

  CurrentCharList : TStringKeyClass;

implementation

uses
   uConnector, uRemoteConnector, uDBProvider, uUtil;

{$R *.DFM}

procedure TfrmMain.AddEvent (aStr : String);
begin
   if lstEvent.Items.Count > 100 then begin
      lstEvent.Items.Delete (0);
   end;
   lstEvent.Items.Add (aStr);
   lstEvent.ItemIndex := lstEvent.Items.Count - 1;
end;

procedure TfrmMain.AddLog (aStr : String);
begin
   if txtLog.Lines.Count > 1000 then begin
      txtLog.Lines.Delete (0);
   end;
   txtLog.Lines.Add (aStr);
end;

procedure TfrmMain.FormCreate(Sender: TObject);
var
   boFlag : Boolean;
   iniFile : TIniFile;
begin
   AddLog (format ('DB Server Started %s %s', [DateToStr (Date), TimeToStr (Time)]));

   ElaspedSec := 0;
   StartTick := timeGetTime;

   TodayDate := Date;

   BackupStream := nil;
   boBackup := false;
   BackupPos := 0;

   if not FileExists ('.\DB.INI') then begin
      iniFile := TIniFile.Create ('.\DB.INI');
      iniFile.WriteString ('DB_SERVER', 'FileName', 'TESTDB.FDB');
      iniFile.WriteInteger ('DB_SERVER', 'BufferSizeS2S', 1024 * 1024);
      iniFile.WriteInteger ('DB_SERVER', 'GateAcceptPort', 3051);
      iniFile.WriteInteger ('DB_SERVER', 'RemoteAcceptPort', 1024);
      iniFile.WriteInteger ('DB_SERVER', 'ItemRemoteAcceptPort', 1020);
      iniFile.Free;
   end;

   iniFile := TIniFile.Create ('.\DB.INI');
   FDBFileName := iniFile.ReadString ('DB_SERVER', 'FileName', 'TESTDB.FDB');
   BufferSizeS2S := iniFile.ReadInteger ('DB_SERVER', 'BufferSizeS2S', 1024 * 1024);
   GateAcceptPort := iniFile.ReadInteger ('DB_SERVER', 'GateAcceptPort', 3051);
   RemoteAcceptPort := iniFile.ReadInteger ('DB_SERVER', 'RemoteAcceptPort', 1024);
   ItemRemoteAcceptPort := iniFile.ReadInteger ('DB_SERVER', 'ItemRemoteAcceptPort', 1020);
   iniFile.Free;

   DBProvider := TDBProvider.Create (FDBFileName);
   DBProvider.SetPrintControl (txtLog);
   boFlag := DBProvider.OpenDB;
   if boFlag = false then begin
      DBProvider.CreateDB;
      DBProvider.OpenDB;
      DBProvider.AddBlankRecord (10000);
      DBProvider.CloseDB;

      DBProvider.OpenDB;
   end;

   TodayCharList := TStringList.Create;

   if FileExists ('.\UserData\Today.SDB') then begin
      TodayCharList.LoadFromFile ('.\UserData\Today.SDB');
      if TodayCharList.Count > 0 then begin
         TodayCharList.Delete (0);
      end;
   end;

   CurrentCharList := TStringKeyClass.Create;

   ConnectorList := TConnectorList.Create;
   RemoteConnectorList := TRemoteConnectorList.Create;

   sckRemoteAccept.Port := RemoteAcceptPort;
   sckRemoteAccept.Active := true;

   sckItemRemote.Port := ItemRemoteAcceptPort;
   sckItemRemote.Active := true;

   sckAccept.Port := GateAcceptPort;
   sckAccept.Active := true;

   timerDisplay.Interval := 1000;
   timerDisplay.Enabled := true;

   timerProcess.Interval := 10;
   timerProcess.Enabled := true;
end;

procedure TfrmMain.FormDestroy(Sender: TObject);
begin
   if sckRemoteAccept.Active = true then begin
      sckRemoteAccept.Socket.Close;
   end;
   if sckAccept.Active = true then begin
      sckAccept.Socket.Close;
   end;
   if sckItemRemote.Active = true then begin
      sckItemRemote.Socket.Close;
   end;

   timerDisplay.Enabled := false;
   timerProcess.Enabled := false;

   CurrentCharList.Free;

   RemoteConnectorList.Free;
   ConnectorList.Free;

   SaveTodayData ('');
   
   TodayCharList.Clear;
   TodayCharList.Free;

   DBProvider.CloseDB;
   DBProvider.Free;
end;

procedure TfrmMain.cmdCloseClick(Sender: TObject);
begin
   if boBackup = true then exit;
   if Application.MessageBox ('Do you want to exit program?', 'DB SERVER', MB_OKCANCEL) <> ID_OK then exit;
   Close;
end;

procedure TfrmMain.sckRemoteAcceptAccept(Sender: TObject;
  Socket: TCustomWinSocket);
begin
   RemoteConnectorList.CreateConnect (Socket, rt_userdata);
   AddEvent ('Remote Accepted ' + Socket.RemoteAddress);
end;

procedure TfrmMain.sckRemoteAcceptClientConnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
   //
end;

procedure TfrmMain.sckRemoteAcceptClientDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
   RemoteConnectorList.DeleteConnect (Socket);
   AddEvent ('Remote DisConnected ' + Socket.RemoteAddress);
end;

procedure TfrmMain.sckRemoteAcceptClientError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
begin
   AddEvent ('Remote Socket Error ' + Socket.RemoteAddress);
   ErrorCode := 0;
end;

procedure TfrmMain.sckRemoteAcceptClientRead(Sender: TObject;
  Socket: TCustomWinSocket);
var
   cmdStr : String;
begin
   if Socket.ReceiveLength > 0 then begin
      cmdStr := Socket.ReceiveText;
      RemoteConnectorList.AddReceiveData (Socket, cmdStr);