uaunits.~pas

基于Midas 技术的多层应用开发包第二版（带开发文档）

{******************************************************************************************}
{                                                                                          }
{       Universal Agent on demond SDK                                                      }
{                                                                                          }
{                                                                                          }
{ COPYRIGHT                                                                                }
{ =========                                                                                }
{ The UA SDK (software) is Copyright (C) 2001-2003, by vinson zeng(曾胡龙).                }
{ All rights reserved.                                                                     }
{ The authors - vinson zeng (曾胡龙),                                                      }
{ exclusively own all copyrights to the Advanced Application                               }
{ Controls (AppControls) and all other products distributed by Utilmind Solutions(R).      }
{                                                                                          }
{ LIABILITY DISCLAIMER                                                                     }
{ ====================                                                                     }
{ THIS SOFTWARE IS DISTRIBUTED "AS IS" AND WITHOUT WARRANTIES AS TO PERFORMANCE            }
{ OF MERCHANTABILITY OR ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED.                 }
{ YOU USE IT AT YOUR OWN RISK. THE AUTHOR WILL NOT BE LIABLE FOR DATA LOSS,                }
{ DAMAGES, LOSS OF PROFITS OR ANY OTHER KIND OF LOSS WHILE USING OR MISUSING THIS SOFTWARE.}
{                                                                                          }
{ RESTRICTIONS                                                                             }
{ ============                                                                             }
{ You may not attempt to reverse compile, modify,                                          }
{ translate or disassemble the software in whole or in part.                               }
{ You may not remove or modify any copyright notice or the method by which                 }
{ it may be invoked.                                                                       }
{******************************************************************************************}


{-----------------------------------------------------------------------------
 Unit Name: UAUnits
 Author:    vinson zeng
 Purpose:
 History:
-----------------------------------------------------------------------------}



unit UAUnits;

interface
uses
   Windows, Variants, ActiveX, Classes,SysUtils,
   Forms,Controls,Registry,Dialogs,WinSock,ADODB,
   DB,StdCtrls,DbClient,Messages,NB30;

const
  UA_DataPacket_Major_Version = $AF501;

  KEY_UA_Client        = '\SOFTWARE\UA\UA Client';

  csSettings           = 'Settings';
  ckIP                 = 'IP';
  ckPort               = 'Port';
  ckWaitTimes          = 'WaitTimes';
  ckTryConnectTimes    = 'TryConnectTimes';
  ckIsLocalNet         = 'IsLocalNet';


type

  StringArray = array of string;

  TUADataPacketType = (dtpRequest,dtpUpdate,dtpExecute);

  TUAErrorRespone = (ureRetry,ureAbout,ureHelp,ureSendErrorReport,ureDetail);

  TGUID128 = Array[0..3] of LongWord;


  TOperationType = (otRequest,otUpdate,otExecute);

  // add for srvobj type define 2003-12-29 by vinson zeng
  //                业务，  事务，  功能，    调度，  数据库连接，安全，日志，扩展
  TSrvObjMgrType = (sotBiz,sotTrans,sotFuncs,sotSche,sotDbConn,sotSec,sotLog,sotExt);

  TUAErrorProcType = (eptSend,eptIgnore,eptAbort);

  TUADebugDefine = (ddRequest,ddUpdate,ddExecute,ddLockObj,ddUnLockObj,ddCatchException,ddStartTrans,ddRollbackTrans,ddCommitTrans);
  TUADebugDefines = set of TUADebugDefine;

  CharSet = set of Char;


  TUAUpdateType =(upModifyAll,upModifyOne,upInsert,
                   upDeleteAll,upDeleteOne);


  TUAUpdateTypes = set of TUAUpdateType;

  TUAExcetionType = (etSystem ,etSql,etCustom);

   // UA SrvObj Exception Define  // add by vinson 2003-12-03
  TUAExcepions = ( UA_E_INVOKE_TIMEOUT,
                   UA_E_TRAN_ROLLBACK,
                   UA_E_UNKNOW_SERVICE,
                   UA_E_UNKNOW_METHOD,
                   UA_E_PARAMS,
                   UA_E_INTERNAL,
                   UA_E_DB_CONNECT,
                   UA_E_NOPERMISSION,
                   UA_E_UNKNOW,
                   UA_E_EXEC_STPREDPROC,
                   UA_E_FATUALERROR,
                   UA_E_EXEC_SQL_STATEMENTS,
                   UA_E_GET_TABLE_STRUC,
                   UA_E_OPEN_TABLE,
                   UA_E_PHY_RECCOUNT,
                   UA_E_EXEC_MODIFY_SQL,
                   UA_E_EXEC_DELETE_SQL,
                   UA_E_EXEC_INSERT_SQL,
                   UA_E_DB_DISCONNECT);

   //-----------------------------------------

   TUAUpdateErrorCode =(ueOk,
                        ueSelectSql,
                        ueModChanged,
                        ueModOneButMany,
                        ueModOneSql,
                        ueModManySql,
                        ueInsSql,
                        ueInsExit,
                        ueDelNonExit,
                        ueDelOneButMany,
                        ueDelOneSql,
                        ueDelManySql);

   // Local Exception Params
   TUALocalErrorParam = class(TPersistent)
   private
//     FError:Exception;
   protected
   public
     destructor Destroy; override;

   end;

   TCliUserInfo = class(TObject)
   public
     FIp:string;
     FProxyIp:string;
     FWorkAccName:string;
     FUserId:string;
     FUserName:string;
     FLastActivity:TDateTime;
   end;


  TAccountObj = class(TObject)
  public
    DBName:string;
    AccName:string;
    DCreate:TDateTime;
    StorePath:string;
    IsDisable:integer;
    IsDefault:integer;
  end;


//UA Error Define for AppServer
const

   s_HexDigitsUpper: String [16] = '0123456789ABCDEF';
   AutoRunRegistryKey = 'SOFTWARE\Microsoft\Windows\CurrentVersion\Run';

   TUAUpdateErrorMsg : array [0..11] of string =
                  ('成功',
                   '原来选择的SQL语句执行错误',
                   '要修改的记录已经被修改',
                   '修改一条记录，但是存在多条记录',
                   '修改一条记录的时候，SQL语句执行错误',
                   '修改多条记录的时候，SQL语句执行错误',
                   '插入一条记录，SQL语句执行错误',
                   '插入的记录已经存在',
                   '要删除的记录不存在',
                   '删除一条记录，但是存在多条记录',
                   '删除一条记录，SQL语句执行错误',
                   '删除多条记录，SQL语句执行错误');

   // add by vinson zeng  2003-12-03

   TUAExceptionMsg :array [0..18] of string =
                   ('无法调用服务对象',
                    '执行数据库事务处理发生错误，已经回滚',
                    '不存在的服务对象名称',
                    '不存在的服务处理方法',
                    '对协议数据包进行解析发生错误',
                    '服务对象内部错误',
                    '连接数据库发生错误',
                    '操作未经授权',
                    '发生无法确认的错误',
                    '执行后台存储过程 [%s] 发生错误',
                    '服务器端发生严重错误',
                    '执行Sql语句发生错误',
                    '提取物理表记录计数发生错误',
                    '服务器尝试打开一个数据表时发生错误',
                    '提取物理表记录计数发生错误',
                    '执行UA数据更新SQL语句发生错误',
                    '执行UA数据删除SQL语句发生错误',
                    '执行UA数据插入SQL语句发生错误',
                    '断开与数据库服务器连接发生错误'
                   );

   // Normal UA Error Code {Range: -$AF1091 To -$AF9999}
   TUAExceptionCode :array [0..18] of integer =
                  (
                   -$C101,-$C102,-$C103,-$C104,
                   -$C105,-$C106,-$C107,-$C108,
                   -$C110,-$C111,-$C112,-$C113,
                   -$C114,-$C115,-$C116,-$C117,
                   -$C118,-$C119,-$C120
                  );

//------------------------------
var
  UADebugMemo:TMemo;
  AdoDs_UALog:TAdoQuery;
  UA_SiteID:LongWord;
  UA_Debug:Boolean;



function  ShowNetworkSetting(Sender:TComponent):Boolean;
procedure WriteClientSetting(Sender: TComponent);

function  RandomSeed: LongWord;
function  RandomUniform: LongWord;
function  RandomHex(const Digits: Integer = 8): String;
procedure RandomUniformInit(const Seed: LongWord);
procedure InitGUID;
function  GenerateGUID32: LongWord;

{NetWork }
function  GetHostEnt: PHostEnt;
function  GetHostEntByName(const HostName: string): PHostEnt;

function  LocalIP: string;
function  GetComputerName: string;
function  GetUserName: string;

function  UniqueName(Instance: TComponent; const Name: string; Owner: TComponent): string;
function  GenUniqueId: string;
function  HadWhiteSpace(const S: string): Boolean;

function  WinExecute(const ExeName, Params: String; const ShowWin: Word; const Wait: Boolean): Boolean;

// for MS-Sql2000 Procedure ADO
procedure _AssignParamValues(Source,Destiny: TParams);
procedure ParametersAssignedToParams(Parameters:TParameters;Params:TParams);
procedure ParamsAssignedToParameters(Params:TParams;Parameters:TParameters);
function  StoredProcParamsToVariant(Params:TParams):Variant;
procedure VariantToStoredProcParams(Source:Variant;Dest:TParams);
function  _GetBasicClientInfo(var vDataIn: OleVariant): string;

//-----------------------------------
procedure UA_variantToStream(AVariant:Variant; AStream:TStream);
function  UA_StreamToVariant(AStream:TStream):Variant;

//--------for debug -------------
procedure InitUADebugMemo(LMemo:TMemo);
procedure UADebugEx(UADebugDefine:TUADebugDefine;dRec:TDateTime;LObj:TObject;sMsg:string);
procedure UARunLogToDb(LAdoConn:TAdoConnection;dRec:TDateTime;vDataIn:OleVariant;sSrvObj:string;sService:string;OpMsg:string);
//----------------------------
function DoubleQuote(Value : string) : string; forward;
function BlobFieldValueAsString(lField:TField):string;
function FieldValueToSqlStr(lDataType: TFieldType;aValue: Variant): string;
//----- add by vinson zeng 2004-07-30...etc
function CnvtDateTimeToSQLVarChar(Value: TDateTime): string;
//----- %% end of %% ----------------------
function GenSelectDS(sTableName:string;cdsSrc:TClientDataSet;lFieldKeys: array of string):string;


//-----For Sql Server 2000
function ExistsTable(AdoConn:TAdoConnection;sTableName: string): Boolean; //判断表是否存在
function CreateUA_SysTable(AdoConn:TAdoConnection):Boolean;

function  EncryptString(var S: string):string;
function  DecryptString(var S: string):string;
function  StringToPChar(const S: string): PChar;
function  PCharToString(P: PChar): string;
function  LongWordToBase(const I: LongWord; const Digits, Base: Byte): String;
function  LongWordToHex(const I: LongWord; const Digits: Byte): String;

// add by vinson zeng for XML 2004-05-26
procedure WriteStrToStream(Stream:TStream;const Str:string);
function  ReadStrFromStream(Stream:TStream):String;
//--------%% end of %% --------------------------




implementation
uses uaNetworkSetting{,Lzh};

const
  N = 624; // Period parameters
  M = 397;

var
  mti : Integer;
  mt  : Array[0..N - 1] of LongWord; // the array for the state vector
  RandomUniformInitialized : Boolean = False;

var
  GUIDInit : Boolean = False;
  GUIDBase : TGUID128 = (0, 0, 0, 0);


{-----------------------------------------------------------------------------
  Procedure: WriteClientSetting
  Author:    administrator
  Date:      04-三月-2004
  Arguments: Sender: TComponent
  Result:    None
-----------------------------------------------------------------------------}

procedure WriteClientSetting(Sender: TComponent);
var
  Reg: TRegINIFile;
  Sections: TStringList;
  i: Integer;
begin
  with Sender as  TNetworkSettingForm do
  begin
    Reg := TRegINIFile.Create('');
    try
      Reg.RootKey := HKEY_LOCAL_MACHINE;
      Reg.OpenKey(KEY_UA_Client, True);
      Sections := TStringList.Create;
      try
        Reg.ReadSections(Sections);
        for i := 0 to Sections.Count - 1 do
          TRegistry(Reg).DeleteKey(Sections[i]);
      finally
        Sections.Free;
      end;
        Reg.WriteString(csSettings,ckIP,edt_AppServerIP.Text);
        Reg.WriteInteger(csSettings,ckPort,StrToInt(edt_AppServerPort.Text));
        Reg.WriteInteger(csSettings,ckWaitTimes,StrToInt(sedt_Timout.Text));
        Reg.WriteInteger(csSettings,ckTryConnectTimes,StrToInt(sedt_tryconnections.Text));
        Reg.WriteBool(csSettings,ckIsLocalNet,cb_LocateNet.Checked);
    finally
      Reg.Free;
    end;

    MessageDlg('建议在修改网络参数成功后，退出当前应用程序。', mtInformation,[mbOk], 0);

  end;
end;

{-----------------------------------------------------------------------------
  Procedure: ShowNetworkSetting
  Author:    administrator
  Date:      04-三月-2004
  Arguments: Sender:TComponent
  Result:    Boolean
-----------------------------------------------------------------------------}

function ShowNetworkSetting(Sender:TComponent):Boolean;
var
  aFrm: TNetworkSettingForm;
begin

  aFrm := TNetworkSettingForm.Create(Sender);
  try
    aFrm.ShowModal;
    Result := (aFrm.ModalResult = mrOk);
    if Result and aFrm.FPassed then
    begin
      WriteClientSetting(aFrm);
    end;
  finally
    if Assigned(aFrm) then
      FreeAndNil(aFrm);
  end;
end;

{-----------------------------------------------------------------------------
  Procedure: RandomSeed
  Author:    vinosn zeng
  Date:      04-三月-2004
  Arguments: None
  Result:    LongWord
-----------------------------------------------------------------------------}

function RandomSeed: LongWord;
var
    I            : Int64;
    Ye, Mo, Da   : Word;
    H, Mi, S, S1 : Word;
begin
  Result := $A5F04182;
  // Date
  DecodeDate(Date, Ye, Mo, Da);
  Result := Result xor Ye xor (Mo shl 16) xor (Da shl 24);

  // Time
  DecodeTime(Time, H, Mi, S, S1);
  Result := Result xor H xor (Mi shl 8) xor (S1 shl 16) xor (S shl 24);

//  {$IFDEF OS_WIN32}
  // Ticks since start-up
  Result := Result xor GetTickCount;

  // CPU Frequency
  if QueryPerformanceFrequency(I) then
    Result := Result xor LongWord(I) xor LongWord(I shr 32);

  // CPU Counter
  if QueryPerformanceCounter(I) then
    Result := Result xor LongWord(I) xor LongWord(I shr 32);

  // Process
  Result := Result xor GetCurrentProcess xor GetCurrentThreadID;
//  {$ENDIF}

end;


{-----------------------------------------------------------------------------
  Procedure: RandomUniformInit
  Author:    administrator
  Date:      04-三月-2004
  Arguments: const Seed: LongWord
  Result:    None
-----------------------------------------------------------------------------}

procedure RandomUniformInit(const Seed: LongWord);
var I : Integer;
begin
  mt[0] := Seed;
  For I := 1 to N - 1 do
    mt[I] := LongWord(Int64(69069) * mt[I - 1]);
  mti := N;
  RandomUniformInitialized := True
end;



{-----------------------------------------------------------------------------
  Procedure: RandomUniform
  Author:    vinson zeng
  Date:      04-三月-2004
  Arguments: None
  Result:    LongWord
-----------------------------------------------------------------------------}

function RandomUniform: LongWord;
const
  Matrix_A = $9908B0DF; // constant vector a
  T_Mask_B = $9D2C5680; // Tempering parameters
  T_Mask_C = $EFC60000;
  Up_Mask  = $80000000; // most significant w-r bits
  Low_Mask = $7FFFFFFF; // least significant r bits
  mag01    : Array[0..1] of LongWord = (0, Matrix_A);

var
  y  : LongWord;
  kk : Integer;

begin
  if not RandomUniformInitialized then
    RandomUniformInit(RandomSeed);
  if mti >= N then { generate N words at one time }
    begin
      For kk := 0 to N - M - 1 do
        begin
          y := (mt[kk] and Up_Mask) or (mt[kk + 1] and Low_Mask);
          mt[kk] := mt[kk + M] xor (y shr 1) xor mag01[y and 1]
        end;
      For kk := N - M to N - 2 do
        begin
          y := (mt[kk] and Up_Mask) or (mt[kk + 1] and Low_Mask);
          mt[kk] := mt[kk + M - N] xor (y shr 1) xor mag01[y and 1]
        end;
      y := (mt[N - 1] and Up_Mask) or (mt[0] and Low_Mask);
      mt[N - 1] := mt[M - 1] xor (y shr 1) xor mag01[y and 1];
      mti := 0
    end;
  y := mt[mti];
  Inc(mti);
  y := y xor (y shr 11);
  y := y xor ((y shl 7) and T_Mask_B);
  y := y xor ((y shl 15) and T_Mask_C);
  y := y xor (y shr 18);
  Result := y;
end;


function RandomHex(const Digits: Integer): String;
var I : Integer;
begin
  Result := '';
  Repeat
    I := Digits - Length(Result);
    if I > 0 then
      Result := Result + IntToHex(RandomUniform, 8);
  Until I <= 0;
  SetLength(Result, Digits);
end;

procedure InitGUID;
var I : Integer;
begin
  GUIDBase[0] := RandomSeed;
  For I := 1 to 3 do
    GUIDBase[I] := RandomUniform;