盒子论坛 v2.1

unit Unit2;

interface

uses Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
  Data.FMTBcd, Vcl.StdCtrls, Data.DB, Data.SqlExpr, DBGridEhGrouping,
  DBClientEx,
  ToolCtrlsEh, DBGridEhToolCtrls, DynVarsEh, EhLibVCL, GridsEh, DBAxisGridsEh,
  DBGridEh, Vcl.ComCtrls, Datasnap.DBClient, Datasnap.Provider, frxClass,
  frxDBSet, ShellAPI, Vcl.ExtCtrls;

type
  Tmainform = class(TForm)
    ClientDataSetEx1: TClientDataSetEx;
    Button1: TButton;
    Label1: TLabel;
    autowf: TCheckBox;
    CheckBox1: TCheckBox;
    Timer1: TTimer;
    StatusBar1: TStatusBar;
    procedure Button1Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCreate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    // procedure print(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    bRestart: Boolean;
  end;

  // Procedure GetPrnFieldWidth(cds:Tclientdatasetex);

var
  mainform: Tmainform;
  // Prn_FieldWidth: Array of integer;

implementation

{$R *.dfm}

uses PRINTERS, ServerContainerUnit1;

procedure Tmainform.Button1Click(Sender: TObject);
begin
  bRestart := True;
  CLose;
end;

procedure Tmainform.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  ServerContainer1.DSServer1.Stop;
  StatusBar1.Panels[0].Text:='服务已关闭';
  sleep(3000);
  if (bRestart) and (autowf.Checked = True) then
    ShellExecute(Self.Handle, 'open', PChar(Application.ExeName), nil, nil,
      SW_SHOWNORMAL);
end;

procedure Tmainform.FormCreate(Sender: TObject);
begin
  mainform.bRestart := false;
  sleep(6000);
  ServerContainer1.DSServer1.Start;
  StatusBar1.Panels[0].Text:='服务已开启';
end;

procedure Tmainform.Timer1Timer(Sender: TObject);
var
  timevalue: string;
  ipos: integer;
  trunctime: integer;
begin
  Timer1.Enabled := false;

  timevalue := FormatDateTime('hh:nn:ss', Now());
  ipos := pos(':', timevalue);
  if ipos > 0 then
    timevalue := copy(timevalue, 1, ipos - 1);
  trunctime := strtoint(timevalue);
  if (trunctime >= 0) and (trunctime <= 1) then
  begin
    mainform.bRestart := true;
    repeat
      sleep(1000);
      timevalue := FormatDateTime('hh:nn:ss', Now());
      ipos := pos(':', timevalue);
      if ipos > 0 then
        timevalue := copy(timevalue, 1, ipos - 1);
      trunctime := strtoint(timevalue);
      mainform.Label1.Caption := '服务器将在2个小时内重起';
    until (trunctime > 1);
    mainform.CLose;
  end;

  Timer1.Enabled := true;
end;

end.
----------------------------------------------
-

作者：

xfyserver (s)	★☆☆☆☆	-
	普通会员

2020/2/28 14:41:53

1楼：

unit ServerContainerUnit1;

interface

uses System.SysUtils, System.Classes,
  Datasnap.DSTCPServerTransport,
  Datasnap.DSServer, Datasnap.DSCommonServer,
  IPPeerServer, IPPeerAPI, Datasnap.DSAuth, IdTCPConnection, Datasnap.DSSession,
  System.Generics.Collections, FireDAC.Stan.Intf, FireDAC.Stan.Option,
  FireDAC.Stan.Error, FireDAC.UI.Intf, FireDAC.Phys.Intf, FireDAC.Stan.Def,
  FireDAC.Phys, FireDAC.Comp.Client, Vcl.ExtCtrls;

type
  TServerContainer1 = class(TDataModule)
    DSServer1: TDSServer;
    DSTCPServerTransport1: TDSTCPServerTransport;
    DSServerClass3: TDSServerClass;
    FDManager1: TFDManager;
    procedure DSServerClass1GetClass(DSServerClass: TDSServerClass;
      var PersistentClass: TPersistentClass);
    procedure DSServerClass2GetClass(DSServerClass: TDSServerClass;
      var PersistentClass: TPersistentClass);
    procedure DSServerClass3GetClass(DSServerClass: TDSServerClass;
      var PersistentClass: TPersistentClass);
    procedure DSTCPServerTransport1Connect(Event: TDSTCPConnectEventObject);
    procedure DSTCPServerTransport1Disconnect
      (Event: TDSTCPDisconnectEventObject);
    procedure DataModuleCreate(Sender: TObject);
    procedure DSServer1Connect(DSConnectEventObject: TDSConnectEventObject);
    procedure Timer1Timer(Sender: TObject);
    procedure DataModuleDestroy(Sender: TObject);
  private
    { Private declarations }
    // sClient: String;
    // ConnInfoStr: String;

  class var
    iSessionNumber: integer;
    FConnections: TObjectDictionary<TIdTCPConnection, TDSTCPChannel>;

    procedure UpdateClientConnections;
    procedure UpdateSessionNumber;
    procedure ShowClientConnections(DSConnectEventObject
      : TDSConnectEventObject);

    procedure AddSessionListener;
    procedure ReleaseAnySessionObject(const Session: TDSSession);
    procedure AddConnectionToList(Conn: TIdTCPConnection;
      Channel: TDSTCPChannel);

    procedure UpdateTCPMonitorInfo;
  public
    procedure DisConnectConnection(theConnection: TIdTCPConnection);
  end;

var
  ServerContainer1: TServerContainer1;

implementation

{$R *.dfm}

uses
  ServerMethodsUnit3;

procedure TServerContainer1.UpdateClientConnections;
begin
  // mainform.lbClients.Items.Add(sClient);
end;

procedure TServerContainer1.UpdateSessionNumber;
begin
  // mainform.edtSessionNumber.Text := IntToStr(FConnections.Count);
end;

procedure TServerContainer1.ShowClientConnections(DSConnectEventObject
  : TDSConnectEventObject);
var
  sb: TStringBuilder;
  ClientConnection: TIdTCPConnection;
  sClient: String;
begin
  sb := TStringBuilder.Create;
  ClientConnection := TIdTCPConnection(DSConnectEventObject.ChannelInfo.Id);
  try
    sb.Append('AppName : ' + DSConnectEventObject.ChannelInfo.
      ClientInfo.AppName);
    sb.Append(' ');
    sb.Append('Protocol : ' + DSConnectEventObject.ChannelInfo.
      ClientInfo.Protocol);
    sb.Append(' ');
    sb.Append('IpAddress : ' + DSConnectEventObject.ChannelInfo.ClientInfo.
      IpAddress);
    sb.Append(' ');
    sb.Append('ClientPort : ' + DSConnectEventObject.ChannelInfo.ClientInfo.
      ClientPort);
    sb.Append(' ');
    sb.Append('id : ' + IntToStr(DSConnectEventObject.ChannelInfo.Id));

    sClient := sb.ToString;
    TThread.Synchronize(nil, UpdateClientConnections);
  finally
    sb.Free;
  end;
end;

procedure TServerContainer1.Timer1Timer(Sender: TObject);
var
  timevalue: string;
  ipos: integer;
  trunctime: integer;
begin
{ Timer1.Enabled := false;

  timevalue := FormatDateTime('hh:nn:ss', Now());
  ipos := pos(':', timevalue);
  if ipos > 0 then
    timevalue := copy(timevalue, 1, ipos - 1);
  trunctime := strtoint(timevalue);
  if (trunctime >= 0) and (trunctime <= 1) then
  begin
    mainform.bRestart := true;
    repeat
      sleep(1000);
      timevalue := FormatDateTime('hh:nn:ss', Now());
      ipos := pos(':', timevalue);
      if ipos > 0 then
        timevalue := copy(timevalue, 1, ipos - 1);
      trunctime := strtoint(timevalue);
      mainform.Label1.Caption := '服务器将在2个小时内重起';
    until (trunctime > 1);
    mainform.CLose;
  end;

  Timer1.Enabled := true;}
end;

procedure TServerContainer1.AddSessionListener;
begin
  TDSSessionManager.Instance.AddSessionEvent(
    procedure(Sender: TObject; const EventType: TDSSessionEventType;
      const Session: TDSSession)
    begin
      case EventType of
        SessionCreate:
          begin
          // Inc(iSessionNumber);
          // TThread.Synchronize(nil, UpdateSessionNumber);
          end;
        SessionClose:
          begin
          ReleaseAnySessionObject(Session);
          end;
      end;
    end);
end;

procedure TServerContainer1.ReleaseAnySessionObject(const Session: TDSSession);
begin
  if (Session.HasObject(Session.SessionName)) then
  begin
    Session.RemoveObject(Session.SessionName, true);
  end;
end;

procedure TServerContainer1.AddConnectionToList(Conn: TIdTCPConnection;
Channel: TDSTCPChannel);
VAR
  pConn: TIdTCPConnection;
  ConnInfoStr: String;
begin
  pConn := Conn;
  if (Conn <> nil) and (Channel <> nil) and (Channel.ChannelInfo <> nil) and
    (Channel.ChannelInfo.ClientInfo.IpAddress <> EmptyStr) then
  begin
    with Channel.ChannelInfo.ClientInfo do
    begin

      ConnInfoStr := Format('%s:%s:%s', [IpAddress, ClientPort,
        Channel.SessionId]);
    end;
  end
  else
    ConnInfoStr := '通道咨询错误。';
end;

procedure TServerContainer1.UpdateTCPMonitorInfo;
begin
  // mainform.lbTCPMonitorInfo.Items.AddObject(ConnInfoStr, pConn);
end;

procedure TServerContainer1.DataModuleCreate(Sender: TObject);
begin
  FDManager.ConnectionDefs.Clear;

end;

procedure TServerContainer1.DataModuleDestroy(Sender: TObject);
begin
  FDManager.ConnectionDefs.Clear;

end;

procedure TServerContainer1.DisConnectConnection(theConnection
  : TIdTCPConnection);
var
  theChannel: TDSTCPChannel;
begin
  if (theConnection <> nil) then
  begin
    FConnections.TryGetValue(theConnection, theChannel);

    { TThread.Synchronize(nil,
      procedure
      var
      i:integer;
      sip,sport:string;
      begin
      sip:=theChannel.ChannelInfo.ClientInfo.IpAddress;
      sport:=theChannel.ChannelInfo.ClientInfo.ClientPort;
      //     disstr:=Format('%s:%s',[sIP,sport]);
      i:= frmMainForm.lbTcpMonitorInfo.Items.IndexOf(Format('%s:%s',[sIP,sport]));
      if i<>-1 then
      frmMainForm.lbTcpMonitorInfo.Items[i]:=Format('%s:%s 被动断开',[sip,sport]);
      end
      ); }
    System.TMonitor.Enter(FConnections);
    FConnections.Remove(theConnection);
    System.TMonitor.Exit(FConnections);

    theChannel.CLose;
    theChannel := nil;
  end;
end;

procedure TServerContainer1.DSServer1Connect(DSConnectEventObject
  : TDSConnectEventObject);
var
  ip: string;
begin
  ClientConnection := DSConnectEventObject.ChannelInfo.ClientInfo;
  ip := ClientConnection.IpAddress;
  // mainform.Label1.Caption:=ip;
  ip := '';
end;

procedure TServerContainer1.DSServerClass1GetClass(DSServerClass
  : TDSServerClass; var PersistentClass: TPersistentClass);
begin
  // PersistentClass := ServerMethodsUnit1.TServerMethods1;
end;

procedure TServerContainer1.DSServerClass2GetClass(DSServerClass
  : TDSServerClass; var PersistentClass: TPersistentClass);
begin
  // PersistentClass := ServerMethodsUnit2.TServerMethods2;
end;

procedure TServerContainer1.DSServerClass3GetClass(DSServerClass
  : TDSServerClass; var PersistentClass: TPersistentClass);
begin
  PersistentClass := ServerMethodsUnit3.TServerMethods3;
end;

procedure TServerContainer1.DSTCPServerTransport1Connect
  (Event: TDSTCPConnectEventObject);
begin
  { System.TMonitor.Enter(FConnections);
    try
    FConnections.Add(TIdTCPConnection(Event.Connection), Event.Channel);
    finally
    System.TMonitor.Exit(FConnections);
    end;

    AddConnectionToList(TIdTCPConnection(Event.Connection), Event.Channel);
    TThread.Synchronize(nil, UpdateTCPMonitorInfo);
    TThread.Synchronize(nil, UpdateSessionNumber); }

end;

procedure TServerContainer1.DSTCPServerTransport1Disconnect
  (Event: TDSTCPDisconnectEventObject);
var
  sip, sport, s: string;
  Conn: TIdTCPConnection;
  i: integer;
begin
  { conn:=TIdTCPConnection(Event.Connection);

    if Assigned(conn) then
    begin
    sip:=conn.Socket.Binding.PeerIP;
    sport:=IntToStr(conn.Socket.Binding.PeerPort);
    System.TMonitor.Enter(ServerContainer1.FConnections);
    if FConnections.ContainsKey(conn) then
    FConnections.Remove(conn);
    System.TMonitor.Exit(FConnections);
    s := Format('%s:%s',[sip,sport]);
    for I := 0 to mainform.lbTcpMonitorInfo.Items.Count - 1 do
    begin

    if mainform.lbTcpMonitorInfo.Items[i].IndexOf(s)<>-1 then
    begin
    mainform.lbTcpMonitorInfo.Items[i]:=Format('%s:%s 主动断开',[sip,sport]);
    break
    end;
    end;
    end;
    mainform.edtSessionNumber.Text:=IntToStr(FConnections.Count);
  }
  sip := '';
  sport := '';
  s := '';;
  Conn := nil;

end;

end.
----------------------------------------------
-

作者：

xfyserver (s)	★☆☆☆☆	-
	普通会员

2020/2/28 14:42:13

2楼：

unit ServerMethodsUnit3;

interface

uses System.SysUtils, System.Classes, System.Json,
  DataSnap.DSProviderDataModuleAdapter,
  DataSnap.DSServer, DataSnap.DSAuth, DataSnap.Provider, Data.DB,
  Data.Win.ADODB, ProviderEx, DBClient, Data.FMTBcd, Data.DBXMSSQL,
  Data.SqlExpr, dateutils, windows, vcl.forms, UniProvider,
  SQLServerUniProvider,
  DBAccess, Uni, dbclientex, typinfo, variants, MemDS, FireDAC.Stan.Intf,
  FireDAC.Stan.Option, FireDAC.Stan.Param, FireDAC.Stan.Error, FireDAC.DatS,
  FireDAC.Phys.Intf, FireDAC.DApt.Intf, FireDAC.Stan.Async, FireDAC.DApt,
  FireDAC.UI.Intf, FireDAC.Stan.Def, FireDAC.Stan.Pool, FireDAC.Phys,
  FireDAC.VCLUI.Wait, FireDAC.Comp.Client, FireDAC.Comp.DataSet,
  FireDAC.Phys.MSSQL, FireDAC.Phys.MSSQLDef, Data.DBXTransport, vcl.ExtCtrls;

type
  TServerMethods3 = class(TDSServerModule)
    DataSetProvider1: TDataSetProvider;
    DataSetProviderEx1: TDataSetProviderEx;
    DataSetProvider2: TDataSetProvider;
    DataSetProvider3: TDataSetProvider;
    DataSetProvider4: TDataSetProvider;
    ClientDataSetEx1: TClientDataSetEx;
    UniStoredProc1: TUniStoredProc;
    softdsp: TDataSetProvider;
    servercds: TClientDataSetEx;
    UniStoredProc5: TUniStoredProc;
    c11dsp: TDataSetProvider;
    c12dsp: TDataSetProvider;
    UniStoredProc2: TUniStoredProc;
    fxdsp1: TDataSetProvider;
    fxdsp2: TDataSetProvider;
    execsqldsp: TDataSetProvider;
    FDQuery1: TFDQuery;
    FDQuery2: TFDQuery;
    FDQuery3: TFDQuery;
    FDQuery4: TFDQuery;
    FDQuery5: TFDQuery;
    execsqlqry: TFDQuery;
    FDQuery7: TFDQuery;
    FDQuery8: TFDQuery;
    FDQuery9: TFDQuery;
    FDQuery10: TFDQuery;
    FDQuery11: TFDQuery;
    FDConnection1: TFDConnection;
    FDQuery6: TFDQuery;
    gndsp: TDataSetProvider;
    UniStoredProc3: TUniStoredProc;
    imgdsp: TDataSetProvider;
    procedure DSPUpdateError(Sender: TObject; DataSet: TCustomClientDataSet;
      E: EUpdateError; UpdateKind: TUpdateKind;
      var Response: TResolverResponse);
    // procedure DSServerModuleCreate(Sender: TObject);
    function getswdate(year, week, one: string): string;
    procedure DataSetProvider3BeforeApplyUpdates(Sender: TObject;
      var OwnerData: OleVariant);
    procedure DSServerModuleCreate(Sender: TObject);
    function execsqldspDataRequest(Sender: TObject; Input: OleVariant)
      : OleVariant;
    function gndspDataRequest(Sender: TObject; Input: OleVariant): OleVariant;
    procedure Timer1Timer(Sender: TObject);
    procedure DSServerModuleDestroy(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    destructor Destroy; override;
    function EchoString(Value: string): string;
    function ReverseString(Value: string): string;
    // function getserverdspname: string;
    // function getdsp(ProviderName:string):TDataSetProviderEx;
    // procedure Releaseserverdspname(ProviderName: string);
    // function cleardsp:TDataSetProviderEx;
    function getdjbh(djtype: string): string;
    // procedure setck;
    // procedure setdjck(djsn:string);
    // procedure setdjgys(djsn:string);
    // procedure djgz(djsn:string);
    // procedure setclsqd(djsn:string);
    // procedure setusergn;
    // procedure setkcb(djsn:string);
    // procedure setbxdfp(djsn:string);
    // procedure createbxdyf(djsn:string);
    function delck(ckname: string): boolean;
    procedure setmaxdjsn(spn, f672, djbh: string);
    // function getcanfp:double;
    // procedure getsgbz;
    // procedure getgnbz;
    // procedure setkcdbxzpro;
    procedure setf1;
    // procedure setygkcpro(djsn:string);
    // procedure setgrgz(year,ym:integer);
    // procedure setgngz(year,ym:integer);
    function getmaxsn(tbname: string): integer;

    function getdjsn(f154: string): string;
    function CreateDSProvider(ProviderName: String): boolean;
    function CreateDSProviderEx(ProviderName, SQL, KeyFields: string;
      Detail: OleVariant): boolean;

    function ResetDspDataSetSQL(ProviderName, SQL: string): boolean;
    function ResetDspDataSetSQLEx(Provider: TDataSetProviderEx;
      SQL, KeyFields: string; Detail: OleVariant): boolean;

    procedure setserverdb(var DB: string);
    procedure gscon;
    function gtserverdb: string;
    procedure settb(tb, fdlist: string);
    procedure setgntb(spn: string);

    procedure execsql(sqltxt: string);

    function getnowtdate: string;
    function getclientip: string;

    procedure RollbackTrans;
    procedure CommitTrans;
    procedure BeginTrans;
  end;

var
  ClientConnection: TDBXClientInfo;
  // serverdb:string;

implementation

// var

{$R *.dfm}

uses System.StrUtils, MIDASLIB, ServerContainerUnit1;

{
  procedure SetSysDateFormat;
  var
  fs: TFormatSettings;
  begin
  // 设置WINDOWS系统的短日期的格式
  SetLocaleInfo(LOCALE_SYSTEM_DEFAULT, LOCALE_SSHORTDATE, 'yyyy-MM-dd');
  Application.UpdateFormatSettings := false;
  // 设定程序本身所使用的日期时间格式
  fs.LongDateFormat := 'yyyy-MM-dd';
  fs.ShortDateFormat := 'yyyy-MM-dd';
  fs.LongTimeFormat := 'hh:nn:ss';
  fs.ShortTimeFormat := 'hh:nn:ss';
  fs.DateSeparator := '-';
  fs.timeSeparator := ':';
  end;
}

procedure TServerMethods3.BeginTrans;
begin
  FDConnection1.StartTransaction;
end;

procedure TServerMethods3.CommitTrans;
begin
  FDConnection1.Commit;
end;

procedure TServerMethods3.RollbackTrans;
begin
  FDConnection1.Rollback;
end;

procedure TServerMethods3.setgntb(spn: string);
var
  FDStoredProc1: TFDStoredProc;
begin
  FDStoredProc1 := TFDStoredProc.Create(self);
  FDStoredProc1.Connection := FDConnection1;
  // FDStoredProc1.Prepare
  with FDStoredProc1 do
  begin
    storedprocname := spn;
    // UniDirectional := false;
    Prepare;
    // parambyname('tb').Value := tb;
    // parambyname('fdlist').Value := fdlist;
    execute;
    // result:=UniStoredProc1.ParamByName('f150').Value;
    close;
  end;
end;

procedure TServerMethods3.execsql(sqltxt: string);
var
  execsql: TFDQuery;
begin
  execsql := TFDQuery.Create(self);
  execsql.Connection := FDConnection1;
  // FDStoredProc1.Prepare
  with execsql do
  begin
    close;
    sql.Text := sqltxt;
    // UniDirectional := false;
    //Prepare;
    // parambyname('tb').Value := tb;
    // parambyname('fdlist').Value := fdlist;
    execute;
    // result:=UniStoredProc1.ParamByName('f150').Value;
    //close;
  end;
end;

function TServerMethods3.getnowtdate: string;
var
  str: string;
begin
  // str:=datetostr(trunc(now));
  result := FormatdateTime('c', now);
end;

function TServerMethods3.getswdate(year, week, one: string): string;
var
  str: string;
begin
  // year:=formatdatetime('yyyy',date);
  result := datetostr(StartOfAWeek(strtoint(year), strtoint(week),
    strtoint(one)));
end;

function TServerMethods3.gndspDataRequest(Sender: TObject; Input: OleVariant)
  : OleVariant;
var
  f672, f61: string;
  ipos: integer;
  maxsn: integer;
begin
  {
    with fdquery6 do
    begin
    close;
    sql.Clear;
    sql.Add('select MAX(convert(int,c9)) from c9');
    //parambyname('f672').Value:=f672;
    //parambyname('f61').Value:=f61;
    open;
    if isempty
    then
    maxsn:=1
    else
    maxsn:=fields[0].Value;
    end;
  }

  ipos := pos(';', Input);
  if ipos > 0 then
  begin
    f672 := copy(Input, 0, ipos - 1);
    f61 := copy(Input, ipos + 1, length(Input));
    with FDQuery6 do
    begin
      close;
      parambyname('f672').Value := f672;
      parambyname('f61').Value := f61;
      execsql;
    end;
  end;
end;

function MyCreateDetailDataSet(AOwner: TComponent; DataSource: TDataSource;
  const AName: String; const ASQL: String): TDataSet; stdcall;
var
  Qry: TFDQuery;
begin
  Qry := TFDQuery.Create(AOwner);
  Qry.Connection := TFDQuery(DataSource.DataSet).Connection;
  Qry.Name := AName;
  Qry.MasterSource := DataSource;
  Qry.SQL.Text := ASQL;
  result := Qry;
end;

function MyCreateProviderEx(AOwner: TComponent; FDConnection: TFDConnection;
  ProviderName, SQL, KeyFields: string; Detail: OleVariant;
  SetFieldsReadOnly: boolean; EUpdateError: TResolverErrorEvent): boolean;
var
  ProvComp: TComponent;
  Qry: TFDQuery;
  DsProvider: TDataSetProviderEx;
begin

  Qry := TFDQuery.Create(AOwner);
  Qry.Connection := FDConnection;
  Qry.SQL.Text := SQL;
  DsProvider := TDataSetProviderEx.Create(AOwner);
  DsProvider.Name := ProviderName;
  DsProvider.Options := [poCascadeDeletes, poCascadeUpdates, poAllowCommandText,
    poUseQuoteChar, poFetchBlobsOnDemand]; // poFetchBlobsOnDemand
  // DsProvider.ResolveToDataSet := True;
  DsProvider.UpdateMode := upWhereKeyOnly;
  DsProvider.DataSet := Qry;
  DsProvider.KeyFields := KeyFields;
  DsProvider.OnUpdateError := EUpdateError;
  DsProvider.CreateDetailDataSet(AOwner, Detail, @MyCreateDetailDataSet);
end;

function MyCreateProvider(AOwner: TComponent; UniConnection: TSQLConnection;
  ProviderName: String; SetFieldsReadOnly: boolean;
  EUpdateError: TResolverErrorEvent): boolean;
var
  ProvComp: TComponent;
  Qry: TSQLQuery;
  DsProvider: TDataSetProvider;
begin
  Qry := TSQLQuery.Create(AOwner);
  // if not SetFieldsReadOnly then
  // Qry.Options.SetFieldsReadOnly := False;
  Qry.sqlConnection := UniConnection;
  // Qry.UniDirectional := True;
  DsProvider := TDataSetProvider.Create(AOwner);

  DsProvider.Name := ProviderName;
  DsProvider.Options := DsProvider.Options + [poAllowCommandText];
  // DsProvider.ResolveToDataSet := True;
  // DsProvider.UpdateMode := upWhereKeyOnly;
  DsProvider.DataSet := Qry;
  DsProvider.OnUpdateError := EUpdateError;
end;

{ procedure setaqrsn(mxcds,mxsncds: TADOQuery);
  var
  maxsn:integer;
  begin
  if mxcds.State<>dsInactive  then
  begin
  maxsn:=getmaxsn(mxsncds);
  with mxcds do
  begin
  //edit;
  first;
  repeat
  if fieldbyname('sn').Value=-1 then
  begin
  edit;
  fieldbyname('sn').Value:=maxsn;
  post;
  maxsn:=maxsn+1;
  end;
  next
  until eof;
  end;
  end;
  end; }

function TServerMethods3.EchoString(Value: string): string;
begin
  result := Value;
end;

function TServerMethods3.execsqldspDataRequest(Sender: TObject;
  Input: OleVariant): OleVariant;
var
  sqltxt, txt, paramlist, para, paramvalue: string;
  sqllist: Tstringlist;
  ipos, ipos1: integer;
begin
  try
    sqllist := Tstringlist.Create;
    sqllist.Text := Input;
    paramlist := sqllist.Strings[0];
    sqllist.Delete(0);
    // txt:=input;
    // execsqlqry.sq
    with execsqlqry do
    begin
      close;
      SQL.Clear;
      SQL.Add(sqllist.Text);
      // sql.SaveToFile('c:\123.txt');
      // sql:=sqllist;
      prepared;
      ipos := pos(',', paramlist);
      while ipos <> 0 do
      begin
        para := copy(paramlist, 0, ipos - 1);
        paramlist := copy(paramlist, ipos + 1, paramlist.length);
        ipos1 := pos('=', para);
        paramvalue := copy(para, ipos1 + 1, para.length);
        para := copy(para, 1, ipos1 - 1);
        parambyname(para).Value := paramvalue;
        ipos := pos(',', paramlist);
      end;
      execsql;
      close;
    end;
  finally
    sqllist.Free;
  end;
end;

{
  function TServerMethods3.getserverdspname: string;
  begin
  Result := Getdspname();

  end;

  function TServerMethods3.getdsp(ProviderName:string):TDataSetProviderEx;
  var
  i,count:integer;
  begin
  count:=self.ComponentCount - 1;
  result:=nil;
  for i := 0 to count do
  begin
  if self.Components[i] is TDataSetProviderEx then
  begin
  if self.Components[i].Name = ProviderName then
  begin
  result:=TDataSetProviderEx(self.Components[i]);
  break;
  end;
  //list.Add(self.Components[i]);
  end;
  end;
  end; }

function TServerMethods3.getdjbh(djtype: string): string;
var
  i, count: integer;
  bhcds: TClientDataSetEx;
begin

  with UniStoredProc1 do
  begin

    //
    parambyname('djtype').Value := djtype;
    // parambyname('kddate').Value := strtodate('2017-07-17');
    // parambyname('djsn').Value:='';
    // open;
    execute;
    result := UniStoredProc1.parambyname('djsn').Value;
    // result:=bhcds.fields[0].Value;
    close;
  end;

end;

function TServerMethods3.delck(ckname: string): boolean;
var
  i, count: integer;
  bhcds: TClientDataSetEx;
begin

  with UniStoredProc1 do
  begin

    //
    parambyname('ckname').Value := ckname;
    // parambyname('kddate').Value := strtodate('2017-07-17');
    // parambyname('djsn').Value:='';
    // open;
    execute;
    result := UniStoredProc1.parambyname('have').Value;
    // result:=bhcds.fields[0].Value;
    close;
  end;

end;

procedure TServerMethods3.setmaxdjsn(spn, f672, djbh: string);
var
  FDStoredProc1: TFDStoredProc;
begin
  FDStoredProc1 := TFDStoredProc.Create(self);
  FDStoredProc1.Connection := FDConnection1;
  // FDStoredProc1.Prepare
  with FDStoredProc1 do
  begin
    storedprocname := spn;
    // UniDirectional := false;
    Prepare;
    parambyname('f672').Value := f672;
    parambyname('djbh').Value := djbh;
    execute;
    // result:=UniStoredProc1.ParamByName('f150').Value;
    close;
  end;
end;

function TServerMethods3.getdjsn(f154: string): string;
begin

  with UniStoredProc1 do
  begin
    storedprocname := 'getdjsn;1';
    // UniDirectional := false;
    PrepareSQL;
    parambyname('f154').Value := f154;
    execute;
    result := UniStoredProc1.parambyname('f150').Value;
    close;
  end;
end;

procedure TServerMethods3.settb(tb, fdlist: string);
begin

  with UniStoredProc1 do
  begin
    storedprocname := 'checktbfd;1';
    // UniDirectional := false;
    PrepareSQL;
    parambyname('tb').Value := tb;
    parambyname('fdlist').Value := fdlist;
    execute;
    // result:=UniStoredProc1.ParamByName('f150').Value;
    close;
  end;
end;

procedure TServerMethods3.Timer1Timer(Sender: TObject);
var
  i: integer;
begin

end;

function TServerMethods3.getmaxsn(tbname: string): integer;
var
  i, count: integer;
  bhcds: TClientDataSetEx;
begin

  with UniStoredProc1 do
  begin
    UniStoredProc1.storedprocname := 'getmaxsn;1';
    UniStoredProc1.Prepare;
    parambyname('tb').Value := tbname;
    // parambyname('kddate').Value := strtodate('2017-07-17');
    // parambyname('djsn').Value:='';
    // open;
    execute;
    result := UniStoredProc1.parambyname('maxsn').Value;
    // result:=bhcds.fields[0].Value;
    close;
  end;

end;

{
  function TServerMethods3.getcanfp:double;
  var
  i,count:integer;
  bhcds:Tclientdatasetex;
  begin

  with fpsqnum do
  begin

  //
  //parambyname('tb').Value:=tbname;
  //parambyname('kddate').Value := strtodate('2017-07-17');
  //parambyname('djsn').Value:='';
  //open;
  execute;
  result:=fpsqnum.ParamByName('fpsqnum').Value;
  //result:=bhcds.fields[0].Value;
  close;
  end;

  end;
}

procedure TServerMethods3.setf1;
var
  i, count: integer;
  bhcds: TClientDataSetEx;
begin

  with UniStoredProc5 do
  begin

    //
    // parambyname('tb').Value:=tbname;
    // parambyname('kddate').Value := strtodate('2017-07-17');
    // parambyname('djsn').Value:='';
    // open;
    execute;
    // result:=fpsqnum.ParamByName('fpsqnum').Value;
    // result:=bhcds.fields[0].Value;
    close;
  end;

end;
{
  procedure TServerMethods3.Releaseserverdspname(ProviderName: string);
  var
  i: integer;
  list: Tlist;
  dsp: TDataSetProviderEx;
  count:integer;
  begin
  //list := Tlist.Create;
  Releasedspname(ProviderName);

  dsp:=nil;
  dsp:=getdsp(ProviderName);
  if dsp<>nil then
  BEGIN
  dsp.dataset.free;
  dsp.Free;
  END;

  end; }
{
  function TServerMethods3.cleardsp:TDataSetProviderEx;
  var
  i,count:integer;
  dsp:TDataSetProviderEx;
  Qry: TUniQuery;
  begin
  count:=self.ComponentCount - 1;
  result:=nil;
  for i := count downto 0 do
  //repeat
  begin
  if self.Components[i] is TDataSetProviderEx then
  begin
  dsp:=TDataSetProviderEx(self.Components[i]);
  dsp.DataSet.Free;
  DSP.Free;
  //count:=self.ComponentCount - 1;
  end;
  //list.Add(self.Components[i]);

  end;

  count:=self.ComponentCount - 1;
  for i := count downto 0 do
  begin
  if self.Components[i] is TUniQuery then
  begin
  qry:=TUniQuery(self.Components[i]);
  //dsp.DataSet.Free;
  qry.Free;
  //list.Add(self.Components[i]);
  end;
  end;
  end; }

function TServerMethods3.ReverseString(Value: string): string;
begin
  result := System.StrUtils.ReverseString(Value);
end;

function TServerMethods3.CreateDSProvider(ProviderName: String): boolean;
begin
  result := false;
  // MyCreateProvider(self, 公司数据库, ProviderName, True, DSPUpdateError);
  result := True;
end;

function TServerMethods3.CreateDSProviderEx(ProviderName, SQL,
  KeyFields: string; Detail: OleVariant): boolean;
var
  i: integer;
  dsp: TDataSetProviderEx;
  dspExist: boolean;
begin
  dspExist := false;
  for i := 0 to self.ComponentCount - 1 do
  begin
    if (self.Components[i].Name = ProviderName) then
    begin
      dspExist := True;
      if self.Components[i] is TDataSetProviderEx then
      begin
        dsp := (self.Components[i]) as TDataSetProviderEx;
{$IFDEF DEBUG_ON}
        dsp.Free;
        dspExist := false;
{$ENDIF}
      end
      else
      begin
{$IFDEF DEBUG_ON}
        self.Components[i].Free;
        dspExist := false;
{$ENDIF}
      end;
      Break;
    end;
  end;

  if not dspExist then
    MyCreateProviderEx(self, FDConnection1, ProviderName, SQL, KeyFields,
      Detail, True, DSPUpdateError);
end;

procedure TServerMethods3.DataSetProvider3BeforeApplyUpdates(Sender: TObject;
  var OwnerData: OleVariant);
begin
  // OwnerData.fieldbyname('sn').value:=-1
end;

procedure TServerMethods3.DSPUpdateError(Sender: TObject;
  DataSet: TCustomClientDataSet; E: EUpdateError; UpdateKind: TUpdateKind;
  var Response: TResolverResponse);
begin
  raise E;
end;

procedure TServerMethods3.DSServerModuleCreate(Sender: TObject);
begin
  // xx.SaveToStream;
  // setserverdb('data00000000001');
end;

procedure TServerMethods3.DSServerModuleDestroy(Sender: TObject);
begin
  FDConnection1.close;
end;

destructor TServerMethods3.Destroy;
begin
  FDConnection1.Connected := false;
  inherited;
end;

procedure TServerMethods3.setserverdb(var DB: string);
var
  nowdate: Tdate;
  oDef: IFDStanConnectionDef;
  olist: Tstringlist;
begin
  try
    olist := Tstringlist.Create;
    // olist.Add('DriverID = MSSQL');
    olist.Add('server=127.0.0.1');
    olist.Add('database=' + DB);
    olist.Add('User_name=sa');
    olist.Add('Password=JiaJiang2015');
    olist.Add('CharacterSet=UTF8');
    // olist.Add('Pooled=true');

    oDef := ServerContainer1.FDManager1.ConnectionDefs.FindConnectionDef
      ('mycon_' + DB);
    if oDef = nil then
      FDManager.AddConnectionDef('mycon_' + DB, 'MSSQL', olist);
    // FDConnection1.Params.Clear;
    FDConnection1.ConnectionDefName := 'mycon_' + DB;
    // serverdb:='mycon_' + DB;
    FDConnection1.Connected := True;
  finally
    olist.Free;
  end;

  { showmessage('1');
    FDConnection1.Params.Clear;
    oDef := ServerContainer1.FDManager1.ConnectionDefs.FindConnectionDef('mycon');
    if oDef=nil then
    begin
    oDef := ServerContainer1.FDManager1.ConnectionDefs.AddConnectionDef;
    oDef.Name := 'mycon';
    //oDef.Params.DriverID := 'MSSQL';
    oDef.Params.add('DriverID := MSSQL');
    oDef.Params.Add('[server]=127.0.0.1');
    oDef.Params.Add('Database ='+DB);
    oDef.Params.Add('User_name =sa');
    oDef.Params.Add('Password =JiaJiang2015');
    // oDef.Params.Add('OSAuthent = True');
    // oDef.Params.Add('pooled = True');
    oDef.Params.Pooled := True;
    oDef.MarkPersistent;
    oDef.Apply;
    end;
    showmessage('2');
    FDConnection1.ConnectionDefName := 'mycon';
    FDConnection1.Connected := True; }
end;

procedure TServerMethods3.gscon;
begin
  { FDConnection1.Connected:=false;
    FDConnection1.Params.clear;
    FDConnection1.Params.Add('DriverID=MSSQL');
    FDConnection1.Params.Add('Database:=zfsoft');
    FDConnection1.Params.Add('server:=127.0.0.1');
    FDConnection1.Params.Add('username:=sa');
    FDConnection1.Params.Add('password:=JiaJiang2015');
    FDConnection1.connected:=true; }
  // ServerMethods1.公司数据库.Database:=db;
  // rverMethods3.
  // namePool.FMaxCount:=1000;
end;

function TServerMethods3.getclientip: string;
begin
  result := ClientConnection.IpAddress;
end;

function TServerMethods3.gtserverdb: string;
begin
  // softunicon.Connected:=false;
  // result:=FDConnection1.params.Database;
  // softunicon.server:='127.0.0.1';
  // softunicon.username:='sa';
  // softunicon.password:='JiaJiang2015';
  // softunicon.connected:=true;
  // ServerMethods1.公司数据库.Database:=db;
  // rverMethods3.
  // namePool.FMaxCount:=1000;
end;

procedure SetSQLProperty(AControl: TComponent;
  { PropName: string; } Value: String);
var
  pInfo: PPropInfo;
  objTemp: TObject;
begin
  if IsPublishedProp(AControl, 'CommandText') then
  begin
    SetPropValue(AControl, 'CommandText', Value);
    Exit;
  end;
  pInfo := GetPropInfo(AControl.ClassInfo, 'SQL');
  if (pInfo <> nil) and (pInfo^.PropType^.Kind = tkClass) then
  begin
    objTemp := GetObjectProp(AControl, pInfo);
    if Assigned(objTemp) then
    begin
      TStrings(objTemp).Text := Value;
      // pInfo := GetPropInfo(objTemp.ClassInfo, 'Text');
      // if pInfo <> nil then
      // SetPropValue(objTemp, 'Text', Value);
    end;
  end;
end;

function TServerMethods3.ResetDspDataSetSQL(ProviderName, SQL: string): boolean;
var
  i: integer;
  dsp: TDataSetProvider;
begin
  result := false;
  for i := 0 to self.ComponentCount - 1 do
  begin
    if SameText(self.Components[i].Name, ProviderName) then
    begin
      if (self.Components[i] is TDataSetProviderEx) or
        (self.Components[i] is TDataSetProvider) then
      begin
        dsp := (self.Components[i]) as TDataSetProvider;
        if dsp.DataSet <> nil then
        begin
          SetSQLProperty(dsp.DataSet, SQL);
          result := True;
        end;
      end;
      Break;
    end;
  end;
end;

procedure ResetDspChildDetailDatasetSQLEx(DetailDataSetItem
  : TProviderDetailDataSetColumn; const Detail: OleVariant);
var
  i: integer;
  ChildDetail: OleVariant;
begin
  if not VarIsNull(Detail) and VarIsArray(Detail) and VarIsArray(Detail[0]) then
  begin
    for i := 0 to VarArrayHighBound(Detail, 1) do
    begin
      with DetailDataSetItem.ChildDetailDataSet.Items[i] do
      begin
        DataSet.Name := Detail[i][0]; // name
        SetSQLProperty(DataSet, Detail[i][1]); // sql
        KeyFields := Detail[i][2];
        ChildDetail := Detail[i][3];
        ResetDspChildDetailDatasetSQLEx
          (DetailDataSetItem.ChildDetailDataSet.Items[i], ChildDetail);
      end;
    end;
  end;
end;

function ResetDspDataSetSQLEx2(Provider: TDataSetProviderEx;
  SQL, KeyFields: string; Detail: OleVariant): boolean;
var
  HighBound, i: integer;
  ChildDetail: OleVariant;
begin
  // TUniQuery(Provider.DataSet).SQL.text := sql;
  SetSQLProperty(Provider.DataSet, SQL);
  // Provider.UpdateMode := upWhereKeyOnly;
  Provider.KeyFields := KeyFields;

  if not VarIsNull(Detail) and VarIsArray(Detail) and VarIsArray(Detail[0]) then
  begin
    for i := 0 to VarArrayHighBound(Detail, 1) do
    begin
      HighBound := VarArrayHighBound(Detail[i], 1);
      with Provider.DetailDataSet.Items[i] do
      begin
        DataSet.Name := Detail[i][0]; // name
        SetSQLProperty(DataSet, Detail[i][1]); // sql
        KeyFields := Detail[i][2];
        ChildDetail := Detail[i][3];
        ResetDspChildDetailDatasetSQLEx(Provider.DetailDataSet.Items[i],
          ChildDetail);
      end;
    end;
  end;
end;

function TServerMethods3.ResetDspDataSetSQLEx(Provider: TDataSetProviderEx;
  SQL, KeyFields: string; Detail: OleVariant): boolean;
begin
  result := false;
  ResetDspDataSetSQLEx2(Provider, SQL, KeyFields, Detail);
  result := True;
end;

end.
----------------------------------------------
-

作者：

grjs_2004 (grjsITname)	★☆☆☆☆	-
	盒子活跃会员

2020/2/28 16:03:45

3楼：

客户端访问之后，服务器端的数据对象没有释放，导致占用内存越来越多（你可以在服务器开启任务管理器来查看Datasnap服务端所占用的内存变化），就会越来越慢，甚至卡死！

解决方案就是实时释放内存，可以用连接池来实现！
也可以用其他方法！
----------------------------------------------
Everyone will to do best!

作者：

luckyrandom (luckyrandom)	★☆☆☆☆	-
	普通会员

2020/2/28 16:44:32

4楼：

在任务管理器->详细信息，将句柄数、线程显示出来，应该能看到线索
----------------------------------------------
SQL SERVER DBA QQ:315054403 曾经的Delphier 缘在上海

作者：

laimama_1 (苞谷)	★☆☆☆☆	-
	盒子活跃会员

2020/2/28 21:38:14

5楼：

你发这么多代码出来，估计没人会看完。
我的DS服务器已经连续运行快半年了，找找什么东西没有释放吧
----------------------------------------------
-

作者：

xlonger (xlonger)	★☆☆☆☆	-
	普通会员

2020/2/29 7:15:48

6楼：

复杂，系统的问题，只能自己解决了。
----------------------------------------------
我打的是酱油，而不是别的什么油。
我灌的是口水，而不是别的什么水。
我聊的折腾不是那个不折腾的折腾。
我说的阿娇不是那个邓玉娇的阿娇。
3个代表,6个为什么,9个肠胃炎。
D性强的领导干部都不喜欢热比娅。
我特别要讲的是,屁民网黄色论坛是我经常上网必选的网站之一

信息

登陆以后才能回复