 //////////////////////////////////////////////////////////////////////////////
 // DIM library, uses by DIM server for CRW-DAQ.
 //////////////////////////////////////////////////////////////////////////////
unit dimlib;

{$I _crw_sysdef.inc}

{$I _crw_sysmode.inc}

interface

uses
 //////////////////////////////////////////////////////
 {$I _crw_uses_first.inc} // NB: MUST BE FIRST USES !!!
 //////////////////////////////////////////////////////
 {$IFDEF WINDOWS} messages, shellapi, jwatlhelp32, {$ENDIF}
 sysutils, classes, math, process,
 _crw_alloc, _crw_str, _crw_fio, _crw_base64, _crw_fifo,
 _crw_environ, _crw_rtc, _crw_proc, _crw_wmctrl, _crw_dim;

const
 DimScanSpaces : TCharSet = [' ',ASCII_TAB,ASCII_CR,ASCII_LF,',','='];

const
 dis_info    = 1;
 dis_cmnd    = 2;
 dic_info    = 3;
 dic_cmnd    = 4;
 DimDefData  = #0#0#0#0;
 DimDefFill  = #255#255#255#255;
 DimPollList = 'timed,monitored';
 DimKindList = 'dis_info,dis_cmnd,dic_info,dic_cmnd';

 //
 // TDimList uses to keep list of DIM servises.
 //
type
 TDimList = class(TLatch)
 private
  myItems:packed array[1..1024*64] of packed record
   Name : LongString;
   Data : LongString;
   Fill : LongString;
   Serv : Integer;
   Kind : Integer;
  end;
  function  GetName(aTag:Integer):LongString;
  procedure SetName(aTag:Integer; const aName:LongString);
  function  GetData(aTag:Integer):LongString;
  procedure SetData(aTag:Integer; const aData:LongString);
  function  GetFill(aTag:Integer):LongString;
  procedure SetFill(aTag:Integer; const aFill:LongString);
  function  GetServ(aTag:Integer):Integer;
  procedure SetServ(aTag:Integer; const aServ:Integer);
  function  GetKind(aTag:Integer):Integer;
  procedure SetKind(aTag:Integer; const aKind:Integer);
 public
  constructor Create;
  destructor  Destroy;override;
 public
  property  Name[aTag:Integer]:LongString read GetName write SetName;
  property  Data[aTag:Integer]:LongString read GetData write SetData;
  property  Fill[aTag:Integer]:LongString read GetFill write SetFill;
  property  Serv[aTag:Integer]:Integer    read GetServ write SetServ;
  property  Kind[aTag:Integer]:Integer    read GetKind write SetKind;
 end;

 // Procedure to kill DimList
procedure Kill(var TheObject:TDimList); overload;

 // Get date and time as 2005.31.12-15:00:00
function GetDateTimeStr(ms:Double):LongString;

 // Return host name. It's DIM_HOST_NODE or HostName or ComputerName.
function GetNodeName:LongString;

 // Return true if DIM_DNS_NODE is local computer.
function IsLocalDimDnsNode:Boolean;

 // Get DIM site path like c:\Crw32exe\resource\DimSite
function GetDimSite:LongString;

 // Get Name path like c:\Crw32exe\resource\DimSite\Dim\Bin\Name
function GetDimBin(const Name:LongString):LongString;

 // Get common DIM site path like:
 // Windows: c:\ProgramFiles\Common Files\resource\DimSite
 // Unix:    /opt/dim
function GetCommonDimSite:LongString;

 // Get common Name path like:
 // Windows: c:\Program Files\Common Files\resource\DimSite\Dim\Bin\Name
 // Unix:    /opt/dim/Name
function GetCommonDimBin(const Name:LongString):LongString;

 // Check if dns.exe is started on local machine
function LocalDimDnsCount:Integer;

 // Start dns.exe on local machine
function StartLocalDimDns:Boolean;

 // Start did.exe on local machine
function StartLocalDimDid:Boolean;

 // Start DimTree.exe on local machine
function StartLocalDimTree:Boolean;

 // Get DIM DNS node.
function GetDimDnsNode:LongString;

 // Procedure to be called on Exceptions.
procedure DimBugReport(E:Exception; O:TObject; Note:LongString);

 // User callback to be called on Exceptions.
var DimBugReportCallback:procedure(E:Exception;O:TObject;Note:LongString)=nil;

implementation

procedure DimBugReport(E:Exception; O:TObject; Note:LongString);
begin
 if Assigned(DimBugReportCallback)
 then DimBugReportCallback(E,O,Note)
 else Echo(E.Message);
end;

constructor TDimList.Create;
begin
 inherited;
end;

destructor TDimList.Destroy;
var i:Integer;
begin
 Lock;
 try
  for i:=Low(myItems) to High(myItems) do begin
   myItems[i].Name:='';
   myItems[i].Data:='';
   myItems[i].Fill:='';
   myItems[i].Serv:=0;
  end;
 finally
  UnLock;
 end;
 inherited;
end;

function TDimList.GetName(aTag:Integer):LongString;
begin
 Result:='';
 if Assigned(Self) then
 if (aTag>=Low(myItems)) then
 if (aTag<=High(myItems)) then
 try
  Lock;
  try
   Result:=myItems[aTag].Name;
  finally
   UnLock;
  end;
 except
  on E:Exception do DimBugReport(E,Self,'GetName');
 end;
end;

procedure TDimList.SetName(aTag:Integer; const aName:LongString);
begin
 if Assigned(Self) then
 if (aTag>=Low(myItems)) then
 if (aTag<=High(myItems)) then
 try
  Lock;
  try
   myItems[aTag].Name:=Trim(aName);
  finally
   UnLock;
  end;
 except
  on E:Exception do DimBugReport(E,Self,'SetName');
 end;
end;

function TDimList.GetData(aTag:Integer):LongString;
begin
 Result:='';
 if Assigned(Self) then
 if (aTag>=Low(myItems)) then
 if (aTag<=High(myItems)) then
 try
  Lock;
  try
   Result:=myItems[aTag].Data;
  finally
   UnLock;
  end;
 except
  on E:Exception do DimBugReport(E,Self,'GetData');
 end;
end;

procedure TDimList.SetData(aTag:Integer; const aData:LongString);
begin
 if Assigned(Self) then
 if (aTag>=Low(myItems)) then
 if (aTag<=High(myItems)) then
 try
  Lock;
  try
   myItems[aTag].Data:=aData;
  finally
   UnLock;
  end;
 except
  on E:Exception do DimBugReport(E,Self,'SetData');
 end;
end;

function TDimList.GetFill(aTag:Integer):LongString;
begin
 Result:='';
 if Assigned(Self) then
 if (aTag>=Low(myItems)) then
 if (aTag<=High(myItems)) then
 try
  Lock;
  try
   Result:=myItems[aTag].Fill;
  finally
   UnLock;
  end;
 except
  on E:Exception do DimBugReport(E,Self,'GetFill');
 end;
end;

procedure TDimList.SetFill(aTag:Integer; const aFill:LongString);
begin
 if Assigned(Self) then
 if (aTag>=Low(myItems)) then
 if (aTag<=High(myItems)) then
 try
  Lock;
  try
   myItems[aTag].Fill:=aFill;
  finally
   UnLock;
  end;
 except
  on E:Exception do DimBugReport(E,Self,'SetFill');
 end;
end;

function TDimList.GetServ(aTag:Integer):Integer;
begin
 Result:=0;
 if Assigned(Self) then
 if (aTag>=Low(myItems)) then
 if (aTag<=High(myItems)) then
 try
  Lock;
  try
   Result:=myItems[aTag].Serv;
  finally
   UnLock;
  end;
 except
  on E:Exception do DimBugReport(E,Self,'GetServ');
 end;
end;

procedure TDimList.SetServ(aTag:Integer; const aServ:Integer);
begin
 if Assigned(Self) then
 if (aTag>=Low(myItems)) then
 if (aTag<=High(myItems)) then
 try
  Lock;
  try
   myItems[aTag].Serv:=aServ;
  finally
   UnLock;
  end;
 except
  on E:Exception do DimBugReport(E,Self,'SetServ');
 end;
end;

function TDimList.GetKind(aTag:Integer):Integer;
begin
 Result:=0;
 if Assigned(Self) then
 if (aTag>=Low(myItems)) then
 if (aTag<=High(myItems)) then
 try
  Lock;
  try
   Result:=myItems[aTag].Kind;
  finally
   UnLock;
  end;
 except
  on E:Exception do DimBugReport(E,Self,'GetKind');
 end;
end;

procedure TDimList.SetKind(aTag:Integer; const aKind:Integer);
begin
 if Assigned(Self) then
 if (aTag>=Low(myItems)) then
 if (aTag<=High(myItems)) then
 try
  Lock;
  try
   myItems[aTag].Kind:=aKind;
  finally
   UnLock;
  end;
 except
  on E:Exception do DimBugReport(E,Self,'SetKind');
 end;
end;

procedure Kill(var TheObject:TDimList); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do DimBugReport(E,nil,'Kill');
 end; 
end;

function GetDateTimeStr(ms:Double):LongString;
begin
 Result:=GetDateStr(ms,'.',true)+'-'+GetTimeStr(ms);
end;

function GetNodeName:LongString;
const node:TDimNameBuffer='';
begin
 if (node='') then
 if (get_node_name(node)=0) then
 StrPLCopy(node,LoCaseStr(ComputerName),SizeOf(node)-1);
 Result:=StrPas(node);
end;

function IsLocalDimDnsNode:Boolean;
var node:TDimNameBuffer;
begin
 if (dim_get_dns_node(node)<>0)
 then Result:=IsSameText(StrPas(node),ComputerName)
           or IsSameText(StrPas(node),GetNodeName)
           or IsSameText(StrPas(node),'localhost')
 else Result:=false;
end;

function GetDimSite:LongString;
var IniFile:LongString; Site:LongString;
begin
 Result:=''; Site:='';
 IniFile:=UnifyFileAlias(GetEnv('CRW_DAQ_SYS_INI_FILE'));
 if Length(IniFile)>0 then
 if ReadIniFilePath(Result,'[System]','DimSite',ExtractFilePath(IniFile),Site)
 then Result:=UnifyFileAlias(Site);
 // Fallback solution if the DimSite was not found in IniFile.
 if (Result='') then Result:=UnifyFileAlias(GetCommonDimSite);
end;

function GetDimBin(const Name:LongString):LongString;
begin
 Result:=GetDimSite;
 if (Result='') then Exit;
 if IsWindows
 then Result:=AddPathDelim(Result)+'dim\bin\'+Trim(Name)
 else Result:=AddPathDelim(Result)+Trim(Name);
end;

{$IFDEF WINDOWS}
function GetCommonDimSite:LongString;
const Site:LongString='';
begin
 Result:=Site;
 if Length(Result)=0 then begin
  Result:=GetEnv('CommonProgramFiles');
  if not DirExists(Result) then Result:=ReadRegistryString(HKEY_LOCAL_MACHINE,
          'SOFTWARE\Microsoft\Windows\CurrentVersion','CommonFilesDir');
  if not DirExists(Result) then Result:=ReadRegistryString(HKEY_LOCAL_MACHINE,
          'Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders',
          'Common AppData');
  if not DirExists(Result) then Result:=TempDir;
  Result:=AddPathDelim(Result)+'CRW-DAQ\Resource\DimSite';
  Site:=Result;
 end; 
end;
{$ENDIF WINDOWS}
{$IFDEF UNIX}
function GetCommonDimSite:LongString;
begin
 Result:='/opt/dim';
end;
{$ENDIF UNIX}

function GetCommonDimBin(const Name:LongString):LongString;
begin
 Result:=GetCommonDimSite;
 if (Result='') then Exit;
 if IsWindows
 then Result:=AddPathDelim(Result)+'dim\bin\'+Trim(Name)
 else Result:=AddPathDelim(Result)+Trim(Name);
end;

function SmartCopy(const Src,Dst:LongString; Check:Boolean=True):Boolean;
begin
 if FileExists(Src) then
 if not IsSameText(UnifyFileAlias(Src),UnifyFileAlias(Dst)) then
 if (GetFileDate(Src)<>GetFileDate(Dst))
 or (GetFileSize(Src)<>GetFileSize(Dst))
 or (GetFileAttr(Src)<>GetFileAttr(Dst)) then begin
  if FileExists(Dst) then FileErase(Dst);
  if not FileExists(Dst) then if MkDir(ExtractFilePath(Dst)) then FileCopy(Src,Dst);
 end;
 Result:=not Check or FileExists(Dst);
end;

{$IFDEF SKIP_DRAFT}
function SmartExecute(Exe,Arg:LongString; SW:Integer):Boolean;
var tid:Integer;
begin
 tid:=task_init('');
 task_ctrl(tid,'AppName='+Exe);
 task_ctrl(tid,'CmdLine='+Arg);
 task_ctrl(tid,'HomeDir='+ExtractFilePath(Exe));
 task_ctrl(tid,'Display='+IntToStr(SW));
 Result:=task_run(tid);
 task_free(tid);
end;
{$ELSE  SKIP_DRAFT}
function SmartExecute(Exe,Arg:LongString; SW:Integer):Boolean;
var proc:TProcess;
begin
 try
  proc:=TProcess.Create(nil);
  try
   {$PUSH}
   {$WARN SYMBOL_DEPRECATED OFF}
   proc.CommandLine:=Trim(Exe+' '+Arg);
   {$POP}
   proc.CurrentDirectory:=ExtractFileDir(Exe);
   if IsUnix then proc.Environment.Text:=EnvironmentVariableList.Text;
   if InRange(SW+1,Ord(Low(TShowWindowOptions)),Ord(High(TShowWindowOptions)))
   then proc.ShowWindow:=TShowWindowOptions(SW+1);
   proc.Execute;
   Result:=proc.Running;
  finally
   proc.Free;
  end;
 except
  on E:Exception do DimBugReport(E,nil,'SmartExecute');
 end;
end;
{$ENDIF SKIP_DRAFT}

function DnsExe:LongString;
begin
 if IsWindows
 then Result:='dns.exe'
 else Result:='dns';
end;

function DidExe:LongString;
begin
 if IsWindows
 then Result:='did.exe'
 else Result:='did';
end;

function DimTreeExe:LongString;
begin
 if IsWindows
 then Result:='dimtree.exe'
 else Result:='dimtree';
end;

{$IFDEF WINDOWS}
function GetWindowProcessId(hWnd:HWND):DWORD;
begin
 Result:=0;
 if IsWindow(hWnd) then
 GetWindowThreadProcessId(hWnd,@Result);
end;

function GetExeFileByPid(Pid:DWORD):LongString;
var hProcessSnap:THandle; pe32:PROCESSENTRY32;
begin
 Result:='';
 if Pid<>0 then begin
  hProcessSnap:=CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS,0);
  if(hProcessSnap<>0) and (hProcessSnap<>INVALID_HANDLE_VALUE) then
  try
   ZeroMemory(@pe32,sizeof(pe32));
   pe32.dwSize:=sizeof(pe32);
   if Process32First(hProcessSnap,pe32) then
   repeat
    if pe32.th32ProcessID=Pid then begin
     Result:=SysUtils.Trim(pe32.szExeFile);
     Break;
    end;
   until not Process32Next(hProcessSnap,pe32);
  finally
   CloseHandle(hProcessSnap);
  end;
 end;
end;

function DimDnsWindowCallback(H:HWND; L:LPARAM):Bool; stdcall;
var Buff : packed array[0..255] of char;
begin
 Result:=true;
 if GetClassName(H,Buff,SizeOf(Buff))>0 then
 if StrIComp(Buff,'ConsoleWindowClass')=0 then
 if GetWindowText(H,Buff,SizeOf(Buff))>0 then
 if PosI('dns.exe',StrPas(Buff))>0 then // Has dns.exe in Title
 //if IsSameText(ExtractFileNameExt(StrPas(Buff)),'dns.exe') then
 if SameText(GetExeFileByPid(GetWindowProcessId(H)),'dns.exe') then
 Inc(Integer(Pointer(L)^));
end;

function LocalDimDnsCount:Integer;
begin
 Result:=0;
 EnumWindows(@DimDnsWindowCallback,LPARAM(@Result));
end;
{$ENDIF WINDOWS}
{$IFDEF UNIX}
function LocalDimDnsCount:Integer;
var p:Integer; ps:LongString;
begin
 Result:=0;
 ps:=GetListOfProcesses(0,0,DnsExe);
 if (ps='') then Exit; // Not found
 p:=1; // Find number of lines of ps
 while InRange(p,1,Length(ps)) do begin
  p:=PosEol(ps,p,1);
  Inc(Result);
 end;
end;
{$ENDIF UNIX}

function StartLocalDimBin(const Name,Args:LongString; SW:Integer):Boolean;
begin
 Result:=false;
 if IsUnix then begin
  Result:=SmartExecute(GetDimBin(Name),Args,SW);
 end else
 if IsWindows then
 if SmartCopy(GetDimBin(Name),GetCommonDimBin(Name)) and
    SmartCopy(GetDimBin('dim.dll'),GetCommonDimBin('dim.dll')) and
    SmartCopy(GetDimBin('msvcrtd.dll'),GetCommonDimBin('msvcrtd.dll'),False) and
    SmartCopy(GetDimBin('msvcr80.dll'),GetCommonDimBin('msvcr80.dll'),False) and
    SmartCopy(GetDimBin('msvcp80.dll'),GetCommonDimBin('msvcp80.dll'),False) and
    SmartCopy(GetDimBin('msvcm80.dll'),GetCommonDimBin('msvcm80.dll'),False) and
    SmartCopy(GetDimBin('Microsoft.VC80.CRT.manifest'),GetCommonDimBin('Microsoft.VC80.CRT.manifest'), False)    
 then Result:=SmartExecute(GetCommonDimBin(Name),Args,SW)
 else Result:=SmartExecute(GetDimBin(Name),Args,SW);
end;

function StartLocalDimDns:Boolean;
begin
 Result:=StartLocalDimBin(DnsExe,'-d',SW_HIDE);
end;

function StartLocalDimDid:Boolean;
begin
 Result:=StartLocalDimBin(DidExe,'',SW_SHOWNORMAL);
end;

function StartLocalDimTree:Boolean;
begin
 Result:=StartLocalDimBin(DimTreeExe,'',SW_SHOWNORMAL);
end;

function GetDimDnsNode:LongString;
var Node:TDimNameBuffer;
begin
 if (dim_get_dns_node(Node)>0)
 then Result:=StrLower(Node)
 else Result:='';
end;

///////////////////////////////////////
// Unit initialization and finalization
///////////////////////////////////////

procedure Init_dimlib;
begin
end;

procedure Free_dimlib;
begin
end;

initialization

 Init_dimlib;

finalization

 Free_dimlib;

end.

//////////////
// END OF FILE
//////////////

