uaunits.~pas

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

  GUIDInit := True;
end;


function GenerateGUID32: LongWord;
begin
  if not GUIDInit then
    InitGUID;
  Result := GUIDBase[3];
  GUIDBase[3] := LongWord(GUIDBase[3] + 1);
end;


function GetHostEnt: PHostEnt;
begin
  Result := GetHostEntByName('');
end;

function GetHostEntByName(const HostName: string): PHostEnt;
begin
  Result := WinSock.GetHostByName(PChar(HostName));
end;

function LocalIP:string;
var
  WSAData: TWSAData;
  HostName, Address: string;
  HostEnt: PHostEnt;
begin
  { no error checking...}
  WSAStartup($0101,WSAData);
  SetLength(HostName, 255);
  gethostname(PChar(HostName), 255);
  SetLength(HostName, StrLen(PChar(HostName)));
  HostEnt := gethostbyname(PChar(HostName));
  with HostEnt^ do
    Address := Format('%d.%d.%d.%d', [Byte(h_addr^[0]), Byte(h_addr^[1]),
      Byte(h_addr^[2]), Byte(h_addr^[3])]);
  WSACleanup;

  Result := Address;
end;



function HadWhiteSpace(const S: string): Boolean;
var
  I: Integer;
begin
  Result := false;
  for I := Length(S) downto 1 do
  begin
    if S[I] = #32 then
    begin
      Result := true;
      Break;
    end;
  end;
end;


function GetComputerName: string;
var
  L: Cardinal;
begin
  Result := StringOfChar(#0, Max_Path);
  L := Max_Path;
  Windows.GetComputerName(PChar(Result), L);
  Result := StrPas(PChar(Result))
end;

function GetUserName: string;
var
  L: Cardinal;
begin
  Result := StringOfChar(#0, Max_Path + 1);
  L := Max_Path;
  if Windows.GetUserName(PChar(Result), L) then
    SetLength(Result, StrLen(PChar(Result)))
  else SetLength(Result, 0);
end;

function UniqueName(Instance: TComponent; const Name: string; Owner: TComponent): string;
var
  I: Integer;
  Tmp: TComponent;
begin

  I := 0;
  Result := Name;
  if Assigned(Owner) then
  begin
    Tmp := Owner.FindComponent(Result);
    if Assigned(Tmp) and (Tmp <> Instance) then
    while (Tmp <> nil) do
    begin
      Result := Format('%s_%d', [Name, I]);
      Inc(I);
      Tmp := Owner.FindComponent(Result);
    end;
  end
  else
  begin
    Result := '';
    if Assigned(FindGlobalComponent(Name)) then
    begin
      Result := Name;
      while FindGlobalComponent(Result) <> nil do
      begin
        Result := Format('%s_%d', [Name, I]);
        Inc(I);
      end;
    end;
  end;
  
end;


procedure ParametersAssignedToParams(Parameters:TParameters;Params:TParams);
var
  i:integer;
  lParam:TParam;
begin

  Params.Clear;
  for i := 0 to Parameters.Count -1 do
  begin
    lParam := TParam.Create(Params);
    lParam.Name := Parameters.Items[i].Name;
    lParam.DataType := TFieldType(Ord(Parameters.Items[i].DataType));
    case lParam.DataType of
      FtString: if VarToStr(Parameters.Items[i].Value) = '0' then lParam.AsString := '' else lParam.AsString := VarToStr(Parameters.Items[i].Value);
      ftInteger,ftSmallInt:
        if VarIsNull(Parameters.Items[i].Value) then
          lParam.AsInteger := 0
        else lParam.AsInteger := Parameters.Items[i].Value;
      FtDateTime:
          Begin
            if (Parameters.Items[i].Value = 0) then lParam.AsDateTime := 0
            else lParam.AsDateTime := Parameters.Items[i].Value;
          end;
      else lParam.Value := Parameters.Items[i].Value;
    end;

    lParam.Precision := Parameters.Items[i].Precision;
    lParam.Size :=  Parameters.Items[i].Size;
    lParam.ParamType := TParamType(Ord(Parameters.Items[i].Direction));
  end;

end;

procedure ParamsAssignedToParameters(Params:TParams;Parameters:TParameters);
var
  i:integer;
begin

  for i := 0 to Params.Count -1 do
  begin
    with Parameters.ParamByName(Params.Items[i].Name) do
    begin
      if (Params.Items[i].ParamType in [ptInput,ptInputOutput])
        // and (not VarIsNull(Params.Items[i].Value))
         and (VarCompareValue(Params.Items[i].Value,Unassigned) <> vrEqual) then
       Value := Params.Items[i].Value;
   end;
  end;

end;

procedure _AssignParamValues(Source,Destiny: TParams);
var
  I, J: Integer;
begin
  for I := 0 to Source.Count - 1 do
    for J := 0 to Destiny.Count - 1 do
      if AnsiCompareText(Source.Items[I].Name,Destiny[J].Name) = 0 then
      begin
        Destiny[J].Assign(Source[I]);
        Break;
      end;
end;


function  StoredProcParamsToVariant(Params:TParams):Variant;
var
  I, Idx, Count: Integer;
Begin
  Result := NULL;
  Count := 0;
  for I := 0 to Params.Count - 1 do
    Inc(Count);
  if Count > 0 then
  Begin
    Idx := 0;
    Result := VarArrayCreate([0, Count - 1], varVariant);
    for I := 0 to Params.Count - 1 do
      with Params[I] do
        Begin
          Result[Idx] := VarArrayOf([Name, Value, Ord(DataType), Ord(ParamType)]);
          Inc(Idx);
        end;
  end;
end;

procedure VariantToStoredProcParams(Source:Variant;Dest:TParams);
var
  TempParams: TParams;
  Param : TParam;
  i,j: Integer;
  VarValue : Variant;
Begin
  if not VarIsNull(Source) and VarIsArray(Source) and VarIsArray(Source[0]) then
  Begin
    TempParams := TParams.Create;
    try
      j := VarArrayHighBound(Source, 1);
      for i := 0 to j do
      try
        Param := TParam.Create(Dest);
        with Param do
        Begin
          if VarArrayHighBound(Source[i], 1) > 1 then
            DataType := TFieldType(Source[i][2]);
          if VarArrayHighBound(Source[i], 1) > 2 then
            ParamType := TParamType(Source[i][3]);
          Name := Source[i][0];
          VarValue := Source[i][1];
          case DataType of
            FtString: if VarToStr(VarValue) = '0' then AsString := '' else AsString := VarToStr(VarValue);
            ftInteger,ftSmallInt:
              if VarIsNull(VarValue) then
                AsInteger := 0
              else AsInteger := VarValue;
            FtDateTime:
                Begin
                  if (VarValue = 0) then AsDateTime := 0
                  else AsDateTime := VarValue;
                end;
            else Value := VarValue;
          end;
        end;
      finally
      end;
      _AssignParamValues(TempParams,Dest);
    finally
      TempParams.Free;
    end;
  end;

end;

procedure RaiseUAExcetion(UAExcepions: TUAExcepions);
begin
  raise Exception.Create(TUAExceptionMsg[Ord(UAExcepions)]);
end;


procedure UA_variantToStream(AVariant:Variant; AStream:TStream);
var
   p:PChar;
   sz:integer;
begin
     if not VarIsArray(AVariant) then
        raise Exception.Create('UAVariantToStream : Variant is not an array.');
     sz:=VarArrayHighBound(AVariant,1);
     p:=VarArrayLock(AVariant);
     try
        AStream.Position:=0;
        AStream.WriteBuffer(p^,sz+1);
        AStream.Position:=0;
     finally
        VarArrayUnlock(AVariant);
     end;
end;

function UA_StreamToVariant(AStream:TStream):Variant;
var
   p:PChar;
   sz:integer;
begin
     sz:=AStream.Size;
     Result:=VarArrayCreate([0,sz-1],varByte);
     p:=VarArrayLock(Result);
     try
        AStream.Position:=0;
        AStream.ReadBuffer(p^,sz);
        AStream.Position:=0;
     finally
        VarArrayUnlock(Result);
     end;
end;

procedure InitUADebugMemo(LMemo:TMemo);
begin

  if not Assigned(LMemo) then Exit;
  if UADebugMemo <> nil then Exit;
  UADebugMemo := LMemo;
  UADebugMemo.Lines.Clear;

end;

procedure UADebugEx(UADebugDefine:TUADebugDefine;dRec:TDateTime;LObj:TObject;sMsg:string);
var
  s,s1,sDebug,sAdd:string;
const

   CR=#13#10;
   TUADebugDefineMsg :array [0..8] of string =
                   ('|Request|',
                    '|Update|',
                    '|Execute|',
                    '|Lock Object|',
                    '|UnLock Object|',
                    '|Catch All Exception|',
                    '|Start Transaction|',
                    '|Commit Transaction|',
                    '|Rollback Transaction|'
                  );
begin

  if not UA_Debug then Exit;
  sDebug := TUADebugDefineMsg[Ord(UADebugDefine)];

  if Assigned(LObj) then
  begin
    sAdd := LObj.ClassName + '@'+IntToHex(Int64(Addr(LObj)),8);
  end
  else
    sAdd := 'Null';

  s1 := 'Begin Task Process:'+DateTimeToStr(dRec);
  s := '---------------Begin UA Trace Debug Message -------------------------'+
       CR+
       sDebug + CR+
       'Object Info:' + sAdd +
       CR+sMsg +
       CR + s1 +CR +
       '--------------------%%UA Trace End%%---------------------------------'
       +#13#10;

  if not Assigned(UADebugMemo) then
    OutputDebugString(PChar(s))
  else
  begin
    UADebugMemo.Lines.BeginUpdate;
    try
      if UADebugMemo.Lines.Count > 2000 then
        while UADebugMemo.Lines.Count > 2000 do
           UADebugMemo.Lines.Delete(0);
      UADebugMemo.Lines.Add(s);
    finally
      UADebugMemo.Lines.EndUpdate;
      SendMessage(UADebugMemo.Handle, EM_SCROLLCARET, 0, 0);
    end;
  end;

end;

function _GetBasicClientInfo(var vDataIn: OleVariant): string;
var
  sTmp,sCliHost,sCliUser:string;
  iPos:integer;
begin

  if (not VarIsEmpty(vDataIn))  and
    (VarCompareValue(vDataIn,Unassigned)<> vrEqual) then
  begin
    sTmp    := VarToStr(vDataIn[0][3]);
    iPos    := AnsiPos('#',sTmp);
    sCliHost   := Copy(sTmp,0,iPos -1);
    sCliUser   := Copy(sTmp,iPos+1,Length(sTmp)- iPos);
    Result := 'Tag Id:'+ IntToStr(vDataIn[0][1])+#13#10+
              'UA Ver:'+ vDataIn[0][2] +#13#10+
              'Client IP Address:'+ vDataIn[0][4]+#13#10+
              'Client Host Name:'+sCliHost+#13#10+
              'Client User Name:'+sCliUser+#13#10+
              'Session ID:'+vDataIn[0][5]+#13#10;
  end;
end;

procedure UARunLogToDb(LAdoConn:TAdoConnection;dRec:TDateTime;vDataIn:OleVariant;sSrvObj:string;sService:string;OpMsg:string);
var
  sSql:string;
  sSesId,sTagId,sHost,sUser,sHostIp:string;
  sSiteId:string;
  sUA_User:string;
  sTmp:string;
  iPos:integer;


begin

  if not Assigned(LAdoConn) then Exit;
  if not Assigned(AdoDs_UALog) then
  begin
    AdoDs_UALog := TAdoQuery.Create(Application);
    AdoDs_UALog.Name := UniqueName(AdoDs_UALog,'AdoDs_UALog',Application);
  end;

  sSiteId := #39+IntToStr(UA_SiteID) + #39;

  if (not VarIsEmpty(vDataIn))  and  (not VarIsNull(vDataIn)) and
    (VarCompareValue(vDataIn,Unassigned)<> vrEqual) then
  begin
    sTagId  := #39 +IntToStr(vDataIn[0][1])+#39;
    sSesId  := #39 +VarToStr(vDataIn[0][5])+#39;
    sHostIp := #39 +VarToStr(vDataIn[0][4])+#39;
    sTmp    := #39 +VarToStr(vDataIn[0][3])+#39;
    iPos    := AnsiPos('#',sTmp);
    sHost   := Copy(sTmp,0,iPos -1)+#39 ;
    sUser   := #39+Copy(sTmp,iPos+1,Length(sTmp)- iPos);
    sUA_User := #39+ 'UA_DEBUG'+ #39;
  end;

  sSql := 'insert into UA_RunLog '+
          '(cSesstionId,cTagId,cSiteId,dRec,cHost,cWinUser,cHostIp,cUAUser,cSrvObjName,cService,cOpMsg)'
          +' values ( '
          + sSesId + ','+sTagId +','+sSiteId +','+ #39+DateTimeToStr(dRec) +#39 +','+sHost+ ','+sUser+','
          + sHostIp+',' +sUA_User +','+ #39+ sSrvObj+ #39+ ','+#39+sService +#39+','+#39+OpMsg +#39
          +' )';

  AdoDs_UALog.Connection := LAdoConn;
  try
    try
      if AdoDs_UALog.Active then
        AdoDs_UALog.Close;
      AdoDs_UALog.SQL.Clear;
      AdoDs_UALog.SQL.Add(sSql);
      AdoDs_UALog.ExecSQL;
    except
    end;
  finally
    AdoDs_UALog.Connection := nil;
  end;
end;


function  DoubleQuote(Value:string):string;
var
  I : Integer;
begin
  Result := '';
  for I := 1 to Length(Value) do begin
      if Value[I] = '''' then
          Result := Result + ''''''
      else
          Result := Result + Value[I];
  end;
end;

function  BlobFieldValueAsString(lField:TField):string;
var
  iSize:integer;
  TmpStream :TStream;
  pData:PChar;
  j, k : Integer;
const
    // Hex Code Table  vinson zeng
    HexDigit : array [0..15] of char =
        ('0', '1', '2', '3', '4', '5', '6', '7',
         '8', '9', 'A', 'B', 'C', 'D', 'E', 'F');
begin

  if lField.DataType in [ftBlob, ftMemo, ftGraphic] then
  begin

    TmpStream := lField.DataSet.CreateBlobStream(lField, bmRead);
    try
     iSize := TmpStream.Size;
     if iSize > 0 then
     begin
       pData := AllocMem(iSize); //分配缓冲内存
       TmpStream.ReadBuffer(pData^,iSize);
     end;

     k := 0;

     for j := 0 to iSize - 1 do
     begin
       if PData[j] in [#0..#31, '$', ''''] then Inc(k);
     end;

     // Now we can adjust result size ,must be do it
     SetLength(Result, 2 + iSize + k + k);
     // And do the second pass to set result value

     Result[1] := '''';
     k := 2;
     for j := 0 to iSize - 1 do
     begin
       if pData[j] in [#0..#31, '$', ''''] then
       begin
         Result[k] := '$';
         Inc(k);
         Result[k] := HexDigit[Ord(pData[j]) shr 4];
         Inc(k);
         Result[k] := HexDigit[Ord(pData[j]) and 15];
       end
       else
         Result[k] := pData[j];
      Inc(k);
     end;
     Result[k] := '''';
    finally
      //必须回收已经分配的内存空间
      FreeMem(pData,iSize);
      TmpStream.Free;
    end;
  end;