program DimSrv;         { DIM server for CRW-DAQ     }
{
[]
;******************************************************************************
;*** Data segment dtabmax should be at least 1024*2+MaxServ*14+MaxTags+MaxMails*2
;*** String table stabmax should be at least 1024*2+MaxServ*5+MaxMails
;******************************************************************************
[Compiler.Options]
Compiler.dtabmax = 1024*2+1024*14+4096+2048*2
Compiler.stabmax = 1024*2+1024*5+2048
Compiler.dtabmin = 1024*1
Compiler.stabmin = 1024*1
[]
;******************************************************************************
}
const                   { Last modified: 20061206    }
 timed       = 1;       { Update service by timer    }
 monitored   = 2;       { Update service by monitor  }
 dis_info    = 1;       { information server         }
 dis_cmnd    = 2;       { command server             }
 dic_info    = 3;       { information client         }
 dic_cmnd    = 4;       { command client             }
 PollList    = 'timed,monitored';
 KindList    = 'dis_info,dis_cmnd,dic_info,dic_cmnd';
 MaxServ     = 1024;    { max. number of services    }
 MaxTags     = 4096;    { max. number of tags        }
 MaxMails    = 2048;    { max. number of mails       }
 MaxLeng     = 16384;   { max. length of I/O string  }
 SendTimeOut = 100;     { timeout on message send    }
 TimerPeriod = 1000;    { poll period for Dim.Timer  }
 StartDelay  = 7000;    { Delay on start             }
 IniFlags    = 28;      { Delete comment, Trim       }
 MimeDump_1  = '/////w=='; { mime_encode(dump(-1))   }
 dim_dll     = 'dim.dll';
 MSVCRTD_DLL = 'MSVCRTD.DLL';
 borlndmm_dll= 'borlndmm.dll';
 DimSiteBin  = 'resource\DimSite\Dim\Bin\';
 PPrioList   = 'Idle,Normal,High,RealTime';
 TPrioList   = 'tpIdle,tpLowest,tpLower,tpNormal,tpHigher,tpHighest,tpTimeCritical';
var
 b           : Boolean; { Temporary variable         }
 Ok          : Boolean; { Is initialization Ok ?     }
 errors      : Integer; { Error count                }
 errorcode   : Integer; { Error code for this device }
 errorserv   : Integer; { Error code for service     }
 errorterm   : Integer; { Error code for host death  }
 fixmaxavail : Integer; { String manager leak test   }
 StdIn_Line  : String;  { Temporary variable         }
 winConsole  : String;  { Console window name        }
 DebugFlags  : Integer; { 1=Trouble,2=Success,4=ViewInp,8=ViewOut,16=Stat }
 Dim         : record
  DnsNode    : String;  { DIM_DNS_NODE               }
  Section    : String;  { DIM_SECTION                }
  Server     : String;  { DIM server path            }
  TStart     : Real;    { Time of DIM server start   }
  Timer      : Integer; { Timer to check DIM task    }
  Count      : Integer; { Number of known services   }
  Task       : String;  { Name of DIM task           }
  Buff       : String;  { DIM task input buffer      }
  Line       : String;  { Temporary variable         }
  Tid        : Integer; { DIM task identifier        }
  Prio       : array[1..4] of Integer; {Priorities   }
  Padding    : Integer; { Use data fields padding?   }
  ClnList    : Integer; { List of connected clients  }
  IPipeSize  : Integer; { StdInPipeSize              }
  OPipeSize  : Integer; { StdOutPipeSize             }
  Serv       : array[1..MaxServ] of record { Services}
   Kind      : Integer; { one of dis_info..dic_cmnd  }
   Name      : String;  { DIM service name           }
   Nick      : String;  { DIM service nickname       }
   Sign      : String;  { Signature #n=              }
   Frmt      : String;  { DIM format string          }
   Fill      : String;  { Error filler               }
   Poll      : Integer; { timed,monitored            }
   Tout      : Integer; { timeout, milliseconds      }
   Dead      : Integer; { dead time on start, msec   }
   Last      : real;    { time of last update, msec  }
   TagIndex  : Integer; { Index in Tags table        }
   TagCount  : Integer; { Count of uses tags         }
   MailIndex : Integer; { Index in Mails table       }
   MailCount : Integer; { Count of uses mails        }
  end;
  Tags       : record   { list of tag references     }
   Count     : Integer; { counter of uses tags       }
   Ref       : array[1..MaxTags] of Integer;
  end;
  Mails      : record   { list of mails to send      }
   Count     : Integer; { counter of uses mails      }
   Dev       : array[1..MaxMails] of Integer;
   Msg       : array[1..MaxMails] of String;
  end;
  Stat       : record   { statistic information      }
   Period    : Real;    { period to update stat.info }
   LastTime  : Real;    { time of last update        }
   Errors    : Real;    { DimSrv.exe errors          }
   Memory    : Real;    { DimSrv.exe memory          }
   ServCount : array[dis_info..dic_cmnd] of Integer;
   MsgPerSec : array[dis_info..dic_cmnd] of Integer;
   TagPerSec : array[dis_info..dic_cmnd] of Integer;
   ChrPerSec : array[dis_info..dic_cmnd] of Integer;
  end;
 end;
 SizeOfChar    : Integer;
 SizeOfReal    : Integer;
 SizeOfInteger : Integer;
 {
 Report on host terminated.
 }
 procedure HostTerm(msg:String);
 var b:boolean;
 begin
  if iand(DebugFlags,1)>0 then
  if Length(msg)>0 then writeln(devname+' ! '+msg);
  if runcount=1 then errors:=errors+1 else b:=fixerror(errorterm);
 end;
 {
 Report on trouble.
 }
 procedure Trouble(msg:String);
 var b:boolean;
 begin
  if iand(DebugFlags,1)>0 then
  if Length(msg)>0 then writeln(devname+' ! '+msg);
  if runcount=1 then errors:=errors+1 else b:=fixerror(errorcode);
 end;
 {
 Report on success.
 }
 procedure Success(msg:String);
 begin
  if iand(DebugFlags,2)>0 then
  if Length(msg)>0 then writeln(devname+' : '+msg);
 end;
 {
 Report on data input.
 }
 procedure ViewInp(msg:String);
 begin
  if iand(DebugFlags,4)>0 then
  if Length(msg)>0 then writeln(devname+' > '+msg);
 end;
 {
 Report on data output.
 }
 procedure ViewOut(msg:String);
 begin
  if iand(DebugFlags,8)>0 then
  if Length(msg)>0 then writeln(devname+' < '+msg);
 end;
 {
 Check I/O status.
 }
 function IoError:boolean;
 begin
  IoError:=false;
  if ioresult<>0 then begin
   Trouble('I/O error.');
   IoError:=true;
  end;
 end;
 {
 Increment
 }
 procedure Inc(var n:Integer);
 begin
  n:=n+1;
 end;
 {
 Decrement
 }
 procedure Dec(var n:Integer);
 begin
  n:=n-1;
 end;
 {
 Clear Dim table.
 Dim_Clear(0) clears all fields.
 Dim_Clear(n>0) clear only Serv[n] fields.
 }
 procedure Dim_Clear(n:integer;MakeFree:boolean);
 var i,j:integer;
 begin
  if n=0 then begin
   if MakeFree then begin
    if Dim.Timer<>0 then b:=tm_free(Dim.Timer);
    if Dim.ClnList<>0 then b:=text_free(Dim.ClnList);
   end;
   Dim.Tid:=0;
   Dim.Buff:='';
   Dim.Line:='';
   Dim.Task:='';
   Dim.Timer:=0;
   Dim.Count:=0;
   Dim.TStart:=0;
   Dim.Prio[1]:=0;
   Dim.Prio[2]:=0;
   Dim.Prio[3]:=0;
   Dim.Prio[4]:=0;
   Dim.Padding:=0;
   Dim.ClnList:=0;
   Dim.Server:='';
   Dim.DnsNode:='';
   Dim.Section:='';
   Dim.Stat.Period:=0;
   Dim.Stat.Errors:=0;
   Dim.Stat.Memory:=0;
   Dim.Stat.LastTime:=0;
   for i:=dis_info to dic_cmnd do Dim.Stat.ServCount[i]:=0;
   for i:=dis_info to dic_cmnd do Dim.Stat.MsgPerSec[i]:=0;
   for i:=dis_info to dic_cmnd do Dim.Stat.TagPerSec[i]:=0;
   for i:=dis_info to dic_cmnd do Dim.Stat.ChrPerSec[i]:=0;
   Dim.Tags.Count:=0;
   for i:=1 to MaxTags do Dim.Tags.Ref[i]:=0;
   Dim.Mails.Count:=0;
   for i:=1 to MaxMails do Dim.Mails.Dev[i]:=0;
   for i:=1 to MaxMails do Dim.Mails.Msg[i]:='';
  end;
  for i:=1 to MaxServ do
  if (n=0) or (n=i) then begin
   Dim.Serv[i].Kind:=0;
   Dim.Serv[i].Name:='';
   Dim.Serv[i].Nick:='';
   Dim.Serv[i].Sign:='';
   Dim.Serv[i].Frmt:='';
   Dim.Serv[i].Fill:='';
   Dim.Serv[i].Poll:=0;
   Dim.Serv[i].Tout:=0;
   Dim.Serv[i].Dead:=0;
   Dim.Serv[i].Last:=0;
   Dim.Serv[i].TagIndex:=0;
   Dim.Serv[i].TagCount:=0;
   Dim.Serv[i].MailIndex:=0;
   Dim.Serv[i].MailCount:=0;
  end;
 end;
 {
 Initialize Dim table.
 }
 procedure Dim_Init;
 var i,j,k,t1,t2,ref,dev:Integer; b:Boolean; msg,fmt:String;
  procedure ReadIniStr(var s:string; name:string);
  var i,t:Integer;
  begin
   s:='';
   t:=ReadIniSection(text_new,IniFlags,'','');
   for i:=0 to text_numln(t)-1 do
   if WordCount(text_getln(t,i))>1 then
   if IsSameText(name,ExtractWord(1,text_getln(t,i))) then
   if s='' then s:=ExtractWord(2,text_getln(t,i));
   b:=text_free(t);
  end;
  procedure RememberIndex(var Index:Integer; Value:Integer);
  begin
   if Index=0 then Index:=Value;
  end;
 begin
  {---Clear Dim---}
  Dim_Clear(0,false);
  {---Read StatPeriod---}
  Dim.Stat.Period:=val(ReadIni('StatPeriod'));
  {---Read priorities---}
  Dim.Prio[1]:=val(ReadIni('PriorityClass'));
  Dim.Prio[2]:=val(ReadIni('PriorityMain'));
  Dim.Prio[3]:=val(ReadIni('PriorityIO'));
  Dim.Prio[4]:=val(ReadIni('PriorityTimer'));
  {---Read FIFO size---}
  Dim.IPipeSize:=val(ReadIni('StdInPipe'));
  Dim.OPipeSize:=val(ReadIni('StdOutPipe'));
  if (Dim.IPipeSize<=0) or (Dim.IPipeSize>64*1024) then Dim.IPipeSize:=64;
  if (Dim.OPipeSize<=0) or (Dim.OPipeSize>64*1024) then Dim.OPipeSize:=64;
  Dim.IPipeSize:=Dim.IPipeSize*1024;
  Dim.OPipeSize:=Dim.OPipeSize*1024;
  {---Read DIM_DNS_NODE---}
  ReadIniStr(Dim.DnsNode,'DIM_DNS_NODE');
  if Length(Dim.DnsNode)>0
  then Success('DIM_DNS_NODE='+Dim.DnsNode)
  else Trouble('DIM_DNS_NODE=?');
  {---Find DIM server executable---}
  Dim.Server:=DaqFileRef(ReadIni('DIM_SERVER'),'.EXE');
  if FileExists(Dim.Server)
  then Success('DIM_SERVER='+Dim.Server)
  else Trouble('Could not find DIM_SERVER: '+Dim.Server);
  {---Check borlndmm.dll presence---}
  if not FileExists(AddBackSlash(ExtractFilePath(Dim.Server))+borlndmm_dll)
  then b:=FileCopy(AddBackSlash(ParamStr('HomeDir'))+borlndmm_dll+' '+
                   AddBackSlash(ExtractFilePath(Dim.Server))+borlndmm_dll);
  if not FileExists(AddBackSlash(ExtractFilePath(Dim.Server))+borlndmm_dll)
  then Trouble('Could not find '+borlndmm_dll);
  {---Check dim.dll presence---}
  if not FileExists(AddBackSlash(ExtractFilePath(Dim.Server))+dim_dll)
  then b:=FileCopy(AddBackSlash(ParamStr('HomeDir'))+AddBackSlash(DimSiteBin)+dim_dll+' '+
                   AddBackSlash(ExtractFilePath(Dim.Server))+dim_dll);
  if not FileExists(AddBackSlash(ExtractFilePath(Dim.Server))+dim_dll)
  then Trouble('Could not find '+dim_dll);
  {---Check MSVCRTD.DLL presence---}
  if not FileExists(AddBackSlash(ExtractFilePath(Dim.Server))+MSVCRTD_DLL)
  then b:=FileCopy(AddBackSlash(ParamStr('HomeDir'))+AddBackSlash(DimSiteBin)+MSVCRTD_DLL+' '+
                   AddBackSlash(ExtractFilePath(Dim.Server))+MSVCRTD_DLL);
  if not FileExists(AddBackSlash(ExtractFilePath(Dim.Server))+MSVCRTD_DLL)
  then Trouble('Could not find '+MSVCRTD_DLL);
  {---Read DIM task name---}
  ReadIniStr(Dim.Task,'DIM_TASK');
  if Length(Dim.Task)>0
  then Success('DIM_TASK='+Dim.Task)
  else Trouble('DIM_TASK=?');
  {---Initialize timer---}
  Dim.Timer:=tm_new;
  if not tm_addint(Dim.Timer,TimerPeriod) then Trouble('tm_addint fails.');
  if not tm_start(Dim.Timer) then Trouble('tm_start fails.');
  {---Read DIM_SECTION---}
  Dim.Section:=ReadIni('DIM_SECTION');
  if Length(Dim.Section)>0
  then t1:=ReadIniSection(text_new,IniFlags,'',Dim.Section)
  else t1:=text_new;
  if text_numln(t1)=0 then Trouble('Could not find DIM_SECTION!');
  for i:=0 to text_numln(t1)-1 do
  if WordCount(text_getln(t1,i))=3 then
  if Dim.Count<MaxServ then begin
   Inc(Dim.Count);
   Dim.Serv[Dim.Count].TagIndex:=0;
   Dim.Serv[Dim.Count].TagCount:=0;
   Dim.Serv[Dim.Count].MailIndex:=0;
   Dim.Serv[Dim.Count].MailCount:=0;
   if IsSameText('dis_info',ExtractWord(2,text_getln(t1,i))) then Dim.Serv[Dim.Count].Kind:=dis_info;
   if IsSameText('dis_cmnd',ExtractWord(2,text_getln(t1,i))) then Dim.Serv[Dim.Count].Kind:=dis_cmnd;
   if IsSameText('dic_info',ExtractWord(2,text_getln(t1,i))) then Dim.Serv[Dim.Count].Kind:=dic_info;
   if IsSameText('dic_cmnd',ExtractWord(2,text_getln(t1,i))) then Dim.Serv[Dim.Count].Kind:=dic_cmnd;
   Dim.Serv[Dim.Count].Name:=ExtractWord(3,text_getln(t1,i));
   Dim.Serv[Dim.Count].Nick:=ExtractWord(1,text_getln(t1,i));
   Dim.Serv[Dim.Count].Sign:='#'+str(Dim.Count)+'=';
   {---Read service section---}
   if Dim.Serv[Dim.Count].Kind>0 then
   if Length(Dim.Serv[Dim.Count].Name)>0 then
   if Length(Dim.Serv[Dim.Count].Nick)>0 then begin
    t2:=readinisection(text_new,IniFlags,'',Dim.Serv[Dim.Count].Nick);
    for j:=0 to text_numln(t2)-1 do
    if WordCount(text_getln(t2,j))>1 then begin
     if IsSameText('polling',ExtractWord(1,text_getln(t2,j))) then begin
      if IsSameText('timed',ExtractWord(2,text_getln(t2,j)))
      then Dim.Serv[Dim.Count].Poll:=timed;
      if IsSameText('monitored',ExtractWord(2,text_getln(t2,j)))
      then Dim.Serv[Dim.Count].Poll:=monitored;
      Dim.Serv[Dim.Count].Tout:=val(ExtractWord(3,text_getln(t2,j)));
      Dim.Serv[Dim.Count].Dead:=val(ExtractWord(4,text_getln(t2,j)));
     end;
     if IsSameText('filling',ExtractWord(1,text_getln(t2,j))) then begin
      Dim.Serv[Dim.Count].Fill:=mime_decode(ExtractWord(2,text_getln(t2,j)));
     end;
     if IsSameText('devmsg',ExtractWord(1,text_getln(t2,j))) then begin
      msg:=Trim(Copy(Trim(text_getln(t2,j)),7,MaxLeng));
      dev:=RefFind('Device '+ExtractWord(1,msg));
      if IsSameText(RefInfo(dev,'Type'),'Device') then begin
       msg:=Trim(Copy(msg,Length(ExtractWord(1,msg))+1,MaxLeng));
       if Length(msg)>0 then msg:=msg+CrLf;
       if Dim.Mails.Count<MaxMails then begin
        Inc(Dim.Mails.Count);
        Inc(Dim.Serv[Dim.Count].MailCount);
        Dim.Mails.Dev[Dim.Mails.Count]:=dev;
        Dim.Mails.Msg[Dim.Mails.Count]:=msg;
        RememberIndex(Dim.Serv[Dim.Count].MailIndex,Dim.Mails.Count);
       end else Trouble('Could not add mail:'+text_getln(t2,j));
      end else Trouble('Invalid expression: '+text_getln(t2,j));
     end;
     if IsSameText('Tag',ExtractWord(1,text_getln(t2,j))) then
     for k:=2 to WordCount(text_getln(t2,j)) do begin
      ref:=reffind('Tag '+ExtractWord(k,text_getln(t2,j)));
      if IsSameText('Tag',refinfo(ref,'Type')) then begin
       if Dim.Tags.Count<MaxTags then begin
        Inc(Dim.Tags.Count);
        Inc(Dim.Serv[Dim.Count].TagCount);
        Dim.Tags.Ref[Dim.Tags.Count]:=ref;
        RememberIndex(Dim.Serv[Dim.Count].TagIndex,Dim.Tags.Count);
       end else Trouble('Could not add tag '+refinfo(ref,'Name'));
       Dim.Serv[Dim.Count].Frmt:='C';
      end;
     end;
    end;
    b:=text_free(t2);
   end;
   if (Dim.Serv[Dim.Count].Kind=0)
   or (Dim.Serv[Dim.Count].Tout<0)
   or (Dim.Serv[Dim.Count].Dead<0)
   or (Dim.Serv[Dim.Count].TagCount=0)
   or (Length(Dim.Serv[Dim.Count].Name)=0)
   or (Length(Dim.Serv[Dim.Count].Nick)=0)
   or (Length(Dim.Serv[Dim.Count].Sign)=0)
   or (Length(Dim.Serv[Dim.Count].Frmt)=0)
   or (Dim.Tags.Count=MaxTags) or (Dim.Mails.Count=MaxMails)
   then begin
    while Dim.Serv[Dim.Count].TagCount>0 do begin
     Dec(Dim.Serv[Dim.Count].TagCount);
     Dim.Tags.Ref[Dim.Tags.Count]:=0;
     Dec(Dim.Tags.Count);
    end;
    Dim.Serv[Dim.Count].TagIndex:=0;
    while Dim.Serv[Dim.Count].MailCount>0 do begin
     Dec(Dim.Serv[Dim.Count].MailCount);
     Dim.Mails.Msg[Dim.Mails.Count]:='';
     Dim.Mails.Dev[Dim.Mails.Count]:=0;
     Dec(Dim.Mails.Count);
    end;
    Dim.Serv[Dim.Count].MailIndex:=0;
    Dim_Clear(Dim.Count,true);
    Dec(Dim.Count);
   end else begin
    if Dim.Serv[Dim.Count].Poll=0
    then Dim.Serv[Dim.Count].Poll:=monitored;
    if Length(Dim.Serv[Dim.Count].Fill)=0
    then Dim.Serv[Dim.Count].Fill:=dump(-1);
    Inc(Dim.Stat.ServCount[Dim.Serv[Dim.Count].Kind]);
   end;
  end;
  b:=text_free(t1);
  {---New client list---}
  Dim.ClnList:=text_new;
  {---Read UsePadding---}
  Dim.Padding:=Val(ReadIni('UsePadding'));
  {
  Calculate DIM format
  }
  if Val(ReadIni('UseFormat'))>0 then
  for i:=1 to DIM.Count do begin
   fmt:='';
   msg:='';
   for j:=1 to Dim.Serv[i].TagCount do begin
    ref:=Dim.Tags.Ref[Dim.Serv[i].TagIndex+j-1];
    if TypeTag(ref)=1 then msg:=msg+'L' else
    if TypeTag(ref)=2 then msg:=msg+'D' else
    if TypeTag(ref)=3 then msg:=msg+'C' else Trouble('Bad tag type.');
   end;
   k:=1;
   for j:=1 to Length(msg) do begin
    if j>1 then begin
     if msg[j-1]=msg[j] then k:=k+1 else begin
      if Length(fmt)>0 then fmt:=fmt+';';
      fmt:=fmt+msg[j-1]+':'+str(k);
      k:=1;
     end;
    end;
    if j=Length(msg) then begin
     if Length(fmt)>0 then fmt:=fmt+';';
     fmt:=fmt+msg[j];
    end;
   end;
   Dim.Serv[i].Frmt:=fmt;
  end;
  fmt:='';
  msg:='';
 end;
 {
 Send message to DIM task.
 Wait for some time if transmitter FIFO is over.
 }
 procedure Dim_Send(msg:string);
 var ms:real;
 begin
  if Dim.Tid<>0 then
  if Length(msg)>0 then begin
   if task_txspace(Dim.Tid)<Length(msg) then begin
    ms:=msecnow;
    while(msecnow-ms<SendTimeOut) and (task_txspace(Dim.Tid)<Length(msg)) do b:=Sleep(1);
   end;
   if task_send(Dim.Tid,msg+CrLf)=0
   then Trouble('Send error!')
   else ViewInp(msg);
  end;
 end;
 {
 Update DIM service.
 }
 procedure Dim_Update(n:integer;s:string);
 var nt,kind:Integer; b:Boolean;
  {---Write data from dump to tags---}
  procedure DumpToTags;
  var i,j,k,ref,ofs:Integer;
  begin
   nt:=0;
   ofs:=1;
   for i:=1 to Dim.Serv[n].TagCount do begin
    ref:=Dim.Tags.Ref[Dim.Serv[n].TagIndex+i-1];
    case typetag(ref) of
     0: Trouble('Invalid tag!');
     1: begin
         if Length(s)-ofs+1>=SizeOfInteger then
         nt:=nt+ord(iSetTag(ref,dump2i(Copy(s,ofs,SizeOfInteger))));
         ofs:=ofs+SizeOfInteger;
        end;
     2: begin
         if Length(s)-ofs+1>=SizeOfReal then
         nt:=nt+ord(rSetTag(ref,dump2r(Copy(s,ofs,SizeOfReal))));
         ofs:=ofs+SizeOfReal;
        end;
     3: begin
         if Length(s)-ofs+1>=SizeOfChar then begin
          k:=0;
          j:=ofs;
          while (k=0) and (j<=Length(s)) do begin
           if ord(s[j])=0 then k:=j;
           j:=j+1;
          end;
          if k=0 then k:=Length(s)+1;
          nt:=nt+ord(sSetTag(ref,Copy(s,ofs,k-ofs)));
          ofs:=ofs+(k-ofs+1);
         end;
        end;
    end;
   end;
  end;
  {---Write data from tags to dump---}
  procedure TagsToDump;
  var i,ref:Integer;
  begin
   nt:=0;
   for i:=1 to Dim.Serv[n].TagCount do begin
    ref:=Dim.Tags.Ref[Dim.Serv[n].TagIndex+i-1];
    case typetag(ref) of
     0: Trouble('Invalid tag!');
     1: begin s:=s+dump(iGetTag(ref));  nt:=nt+1; end;
     2: begin s:=s+dump(rGetTag(ref));  nt:=nt+1; end;
     3: begin s:=s+sGetTag(ref)+chr(0); nt:=nt+1; end;
    end;
   end;
  end;
  {---Report update done---}
  procedure UpdateDone;
  var i,p,k,dev,ref:Integer; msg,dat:string;
  begin
   for i:=1 to Dim.Serv[n].MailCount do begin
    dev:=Dim.Mails.Dev[Dim.Serv[n].MailIndex+i-1];
    msg:=Dim.Mails.Msg[Dim.Serv[n].MailIndex+i-1];
    p:=1;
    if Pos('%',msg)>0 then
    while p<Length(msg) do begin
     if msg[p]='%' then begin
      k:=0;
      dat:='';
      if Copy(msg,p+1,2)='**'
      then dat:=mime_encode(s)
      else k:=val(Copy(msg,p+1,2));
      if k>=1 then
      if k<=Dim.Serv[n].TagCount then begin
       ref:=Dim.Tags.Ref[Dim.Serv[n].TagIndex+k-1];
       case typetag(ref) of
        0 : dat:='';
        1 : dat:=mime_encode(dump(iGetTag(ref)));
        2 : dat:=mime_encode(dump(rGetTag(ref)));
        3 : dat:=mime_encode(sGetTag(ref));
       end;
      end;
      if Length(dat)>0 then begin
       msg:=Copy(msg,1,p-1)+dat+Copy(msg,p+3,MaxLeng);
       p:=p+Length(dat)-1;
      end;
     end;
     p:=p+1;
    end;
    if devsend(dev,msg)<Length(msg)
    then Trouble('Could not send devmsg '+RefInfo(dev,'Name')+' '+Trim(msg));
   end;
   Dim.Stat.ChrPerSec[kind]:=Dim.Stat.ChrPerSec[kind]+Length(s);
   Dim.Stat.TagPerSec[kind]:=Dim.Stat.TagPerSec[kind]+nt;
   Dim.Stat.MsgPerSec[kind]:=Dim.Stat.MsgPerSec[kind]+1;
   Dim.Serv[n].Last:=msecnow;
   msg:='';
   dat:='';
   s:='';
  end;
 begin
  if (n>=1) and (n<=Dim.Count) then begin
   kind:=Dim.Serv[n].Kind;
   if (kind=dis_info) or (kind=dic_cmnd) then begin
    if Length(s)>0 then DumpToTags else TagsToDump;
    if Length(s)>0 then begin
     Dim_Send(Dim.Serv[n].Sign+mime_encode(s));
     UpdateDone;
    end;
   end;
   if Length(s)>0 then
   if (kind=dic_info) or (kind=dis_cmnd) then begin
    if msecnow-Dim.TStart>=Dim.Serv[n].Dead then
    if s=Dim.Serv[n].Fill then begin
     if msecnow-Dim.TStart>=StartDelay
     then b:=fixerror(errorserv);
    end else begin
     DumpToTags;
     UpdateDone;
    end;
   end;
  end;
 end;
 {
 Get string like 2006.09.21-00:12:30
 }
 function GetDateTime(ms:Real):String;
 var s:String;
 begin
  s:='';
  s:=Str(ms2sec(ms))+s;   while Length(s)<2  do s:='0'+s; s:=':'+s;
  s:=Str(ms2min(ms))+s;   while Length(s)<5  do s:='0'+s; s:=':'+s;
  s:=Str(ms2hour(ms))+s;  while Length(s)<8  do s:='0'+s; s:='-'+s;
  s:=Str(ms2day(ms))+s;   while Length(s)<11 do s:='0'+s; s:='.'+s;
  s:=Str(ms2month(ms))+s; while Length(s)<14 do s:='0'+s; s:='.'+s;
  s:=Str(ms2year(ms))+s;  while Length(s)<19 do s:='0'+s;
  GetDateTime:=s;
  s:='';
 end;
 {
 Analyse data coming from DIM task stdout.
 }
 procedure Dim_Process(var s:string);
 var i,p,n:integer; cmnd,args,buff:String; b:Boolean;
  function ClientIndex(Client:String):Integer;
  var i,n:Integer;
  begin
   i:=0;
   n:=-1;
   while (i<text_numln(Dim.ClnList)) and (n<0) do begin
    if IsSameText(Client,text_getln(Dim.ClnList,i)) then n:=i;
    i:=i+1;
   end;
   ClientIndex:=n;
  end;
 begin
  cmnd:='';
  args:='';
  buff:='';
  if length(s)>0 then begin
   ViewOut(s);
   if s[1]='@' then begin
    p:=pos('=',s);
    if p>0 then begin
     cmnd:=Copy(s,2,p-2);
     args:=Copy(s,p+1,Length(s)-p);
    end else begin
     cmnd:=Copy(s,2,Length(s)-1);
     args:='';
    end;
    if IsSameText(cmnd,'exit') then begin
     Success('Exit with code '+Trim(args));
    end;
    if IsSameText(cmnd,'errors') then begin
     n:=val(args);
     if n>0 then begin
      b:=fixerror(errorcode);
      Dim.Stat.Errors:=Dim.Stat.Errors+n;
     end;
    end;
    if IsSameText(cmnd,'memory') then begin
     n:=val(args);
     if n>0 then Dim.Stat.Memory:=n;
    end;
    if IsSameText(cmnd,'ClientEnter') then begin
     buff:=ExtractWord(2,args);
     if Length(buff)>0 then
     if ClientIndex(buff)<0 then begin
      b:=text_addln(Dim.ClnList,buff);
      b:=echo(GetDateTime(msecnow)+' -> '+devname+' : '+ExtractWord(2,args)+' connected.');
     end;
    end;
    if IsSameText(cmnd,'ClientKill') then begin
     b:=echo(GetDateTime(msecnow)+' -> '+devname+' : '+ExtractWord(2,args)+' kill request.');
    end;
    if IsSameText(cmnd,'ClientExit') then begin
     buff:=ExtractWord(2,args);
     if Length(buff)>0 then begin
      b:=text_delln(Dim.ClnList,ClientIndex(buff));
      b:=echo(GetDateTime(msecnow)+' -> '+devname+' : '+ExtractWord(2,args)+' disconnected.');
     end;
    end;
   end;
   if s[1]='#' then begin
    p:=pos('=',s);
    if p>0 then begin
     cmnd:=Copy(s,2,p-2);
     args:=Copy(s,p+1,Length(s)-p);
    end else begin
     cmnd:=Copy(s,2,Length(s)-1);
     args:='';
    end;
    n:=val(cmnd);
    if n<>0 then Dim_Update(n,mime_decode(args));
   end;
  end;
  buff:='';
  cmnd:='';
  args:='';
 end;
 {
 Read line from DIM task stdout pipe with CR terminator and LF ignore.
 }
 function Dim_Readln(var s:String):boolean;
 var p,q:integer;
 begin
  s:='';
  Dim_Readln:=false;
  if task_pid(Dim.Tid)<>0 then begin
   if Length(Dim.Buff)<MaxLeng then Dim.Buff:=Dim.Buff+task_recv(Dim.Tid,MaxLeng-Length(Dim.Buff));
   p:=Pos(chr(13),Dim.Buff);
   if p>0 then begin
    Dim_Readln:=true;
    if p>1 then s:=Copy(Dim.Buff,1,p-1);
    if Length(s)>0 then begin
     q:=Pos(chr(10),s);
     if q>0 then s:=Copy(s,q+1,MaxLeng);
    end;
    Dim.Buff:=Copy(Dim.Buff,p+1,MaxLeng);
    if Length(Dim.Buff)>0 then
    if Dim.Buff[1]=chr(10) then Dim.Buff:=Copy(Dim.Buff,2,MaxLeng);
   end else begin
    if Length(Dim.Buff)=MaxLeng then begin
     Trouble('Received line is too long!');
     Dim.Buff:='';
    end;
   end;
  end;
 end;
 {
 Stop DIM server task if one started.
 }
 procedure Dim_Stop;
 var b:Boolean;
 begin
  if Dim.Tid>0 then begin
   if task_wait(Dim.Tid,0) then begin
    Dim_Send('@stop');
    Dim_Send('@exit');
    if task_wait(Dim.Tid,1000) then b:=task_kill(Dim.Tid,0,1,1000);
    Dim.TStart:=_plusinf;
    if task_rxcount(Dim.Tid)>0 then
    while Dim_Readln(Dim.Line) do Dim_Process(Dim.Line);
    Success('DIM Server exit code = '+str(task_result(Dim.Tid)));
   end;
   b:=task_free(Dim.Tid);
  end;
  Dim.Tid:=0;
  Dim.Buff:='';
  Dim.Line:='';
 end;
 {
 Finalize Dim table.
 }
 procedure Dim_Free;
 begin
  Dim_Stop;
  Dim_Clear(0,true);
 end;
 {
 Start DIM server if one not started.
 }
 procedure Dim_Start;
 var i,j:Integer; b:Boolean;
 begin
  if Dim.Tid=0 then begin
   {
   Initialize separate user task, run it invisible...
   }
   Dim.Tid:=task_init(Dim.Server);
   if pos('?',task_ctrl(Dim.Tid,'HomeDir='+ExtractFilePath(Dim.Server))
             +task_ctrl(Dim.Tid,'StdInPipeSize='+str(Dim.IPipeSize))
             +task_ctrl(Dim.Tid,'StdOutPipeSize='+str(Dim.OPipeSize))
             +task_ctrl(Dim.Tid,'Display=0')
          )>0
   then begin
    Trouble('User task setup error!');
    Dim_Stop;
   end;
   {
   Setup priorities...
   }
   Success('Set StdInPriority   = '+task_ctrl(Dim.Tid,'StdInPriority='+
           extractword(Dim.Prio[2]+4,TPrioList)));
   Success('Set StdOutPriority  = '+task_ctrl(Dim.Tid,'StdOutPriority='+
           extractword(Dim.Prio[2]+4,TPrioList)));
   Success('Set ThreadPriority  = '+task_ctrl(Dim.Tid,'ThreadPriority='+
           extractword(Dim.Prio[2]+4,TPrioList)));
   Success('Set ProcessPriority = '+task_ctrl(Dim.Tid,'ProcessPriority='+
           extractword(Dim.Prio[1]+2,PPrioList)));
   {
   Run task if one was created...
   }
   if Dim.Tid>0 then
   if task_run(Dim.Tid) then begin
    Success('TaskId  = '+str(Dim.Tid));
    Success('TaskPid = '+str(task_pid(Dim.Tid)));
    Success('TaskRef = '+str(task_ref(Dim.Tid)));
    Success('CmdLine = '+task_ctrl(Dim.Tid,'CmdLine'));
    Success('HomeDir = '+task_ctrl(Dim.Tid,'HomeDir'));
    Success('PipeIn  = '+task_ctrl(Dim.Tid,'StdInPipeSize'));
    Success('PipeOut = '+task_ctrl(Dim.Tid,'StdOutPipeSize'));
    Success('IPrior. = '+task_ctrl(Dim.Tid,'StdInPriority'));
    Success('OPrior. = '+task_ctrl(Dim.Tid,'StdOutPriority'));
    Success('TPrior. = '+task_ctrl(Dim.Tid,'ThreadPriority'));
    Success('PPrior. = '+task_ctrl(Dim.Tid,'ProcessPriority'));
    Success('Display = '+task_ctrl(Dim.Tid,'Display'));
   end else begin
    Trouble('Could not start DIM Server!');
    Dim_Stop;
   end;
   {
   Is it Ok with user task? Send preset parameters.
   }
   if Dim.Tid>0 then
   if task_wait(Dim.Tid,0) then begin
    Dim_Send('@padding='+Str(Dim.Padding));
    Dim_Send('@dnsnode='+Dim.DnsNode);
    Dim_Send('@dns.exe');
    Dim.Line:='';
    for i:=1 to Dim.Count do begin
     Dim.Line:='+'+str(i)+'=';
     Dim.Line:=Dim.Line+ExtractWord(Dim.Serv[i].Kind,KindList);
     Dim.Line:=Dim.Line+','+Dim.Serv[i].Name;
     Dim.Line:=Dim.Line+','+Dim.Serv[i].Frmt;
     Dim.Line:=Dim.Line+','+ExtractWord(Dim.Serv[i].Poll,PollList);
     Dim.Line:=Dim.Line+','+str(Dim.Serv[i].Tout div 1000);
     Dim.Line:=Dim.Line+','+mime_encode(Dim.Serv[i].Fill);
     Dim_Send(Dim.Line);
    end;
    Dim.Line:='';
    if (Dim.Stat.ServCount[dis_info]>0)
    or (Dim.Stat.ServCount[dis_cmnd]>0)
    then Dim_Send('@start='+Dim.Task);
    Dim.Line:='@priority='+str(Dim.Prio[1]);
    Dim.Line:=Dim.Line+','+str(Dim.Prio[2]);
    Dim.Line:=Dim.Line+','+str(Dim.Prio[3]);
    Dim.Line:=Dim.Line+','+str(Dim.Prio[4]);
    Dim_Send(Dim.Line);
    Dim.Line:='';
    Dim.TStart:=msecnow;
   end else b:=fixerror(errorcode);
  end;
 end;
 {
 DIM service polling: check last polling time, update if needed.
 }
 procedure Dim_Poll;
 var n,kind:Integer; ms:real;
 begin
  ms:=msecnow;
  for n:=1 to Dim.Count do begin
   kind:=Dim.Serv[n].Kind;
   if (kind=dis_info) or (kind=dic_cmnd) then begin
    if Dim.Serv[n].Poll=Timed then begin
     if Dim.Serv[n].Tout>0 then
     if ms-Dim.Serv[n].Last>=Dim.Serv[n].Tout then Dim_Update(n,'');
    end else
    if Dim.Serv[n].Poll=Monitored then begin
     if Dim.Serv[n].Tout>0 then
     if ms-Dim.Serv[n].Last>=Dim.Serv[n].Tout then Dim_Update(n,'');
    end;
   end;
  end;
 end;
 {
 DIM stat. information report.
 }
 procedure Dim_Stat;
 const fw=11; fd=2;
 var i:integer; dt,factor:real; b:boolean;
 begin
  if Dim.Stat.Period>0 then begin
   dt:=msecnow-Dim.Stat.LastTime;
   if dt>=Dim.Stat.Period then begin
    factor:=1e3/dt;
    if iand(DebugFlags,16)>0 then begin
     writeln(devname,' : Stat.Info ','dis_info':fw,'dis_cmnd':fw,'dic_info':fw,'dic_cmnd':fw);
     write(devname,'   ServCount ');
     for i:=dis_info to dic_cmnd do write(Dim.Stat.ServCount[i]:fw);
     writeln;
     write(devname,'   MsgPerSec ');
     for i:=dis_info to dic_cmnd do write(Dim.Stat.MsgPerSec[i]*factor:fw:fd);
     writeln;
     write(devname,'   TagPerSec ');
     for i:=dis_info to dic_cmnd do write(Dim.Stat.TagPerSec[i]*factor:fw:fd);
     writeln;
     write(devname,'   ChrPerSec ');
     for i:=dis_info to dic_cmnd do write(Dim.Stat.ChrPerSec[i]*factor:fw:fd);
     writeln;
     writeln(devname,'   Memory = ',Dim.Stat.Memory:1:0,
                     '   Errors = ',Dim.Stat.Errors:1:0,
                     '   Clients = ',text_numln(Dim.ClnList):1);
    end;
    if aomap(0,12)<>0 then begin
     for i:=dis_info to dic_cmnd do if refao(i-1)<>0 then b:=putao(i-1,time,Dim.Stat.MsgPerSec[i]*factor);
     for i:=dis_info to dic_cmnd do if refao(i+3)<>0 then b:=putao(i+3,time,Dim.Stat.TagPerSec[i]*factor);
     for i:=dis_info to dic_cmnd do if refao(i+7)<>0 then b:=putao(i+7,time,Dim.Stat.ChrPerSec[i]*factor);
    end;
    for i:=dis_info to dic_cmnd do Dim.Stat.MsgPerSec[i]:=0;
    for i:=dis_info to dic_cmnd do Dim.Stat.TagPerSec[i]:=0;
    for i:=dis_info to dic_cmnd do Dim.Stat.ChrPerSec[i]:=0;
    Dim.Stat.LastTime:=msecnow;
   end;
  end;
 end;
 {
 Read string line from standard input.
 }
 function StdIn_Readln(var s:string):boolean;
 begin
  StdIn_Readln:=false;
  if not IoError then 
  if not eof then begin
   readln(s);
   if not IoError then StdIn_Readln:=true;
  end;
 end;
 {
 Analyse data coming from standard input.
 Messages:
  ##i - update service which contains tag i(integer as decimal string)
  ##s - update service with nickname s(string)
 Example:
  b:=devmsg('&DimSrv ##'+str(tagButton));
  b:=devmsg('&DimSrv ##dic_cmnd_test');
 }
 procedure StdIn_Process(s:string);
 var i,j,p,ref,kind:Integer; cmd,arg:String;
 begin
  if Length(s)>0 then begin
   if Length(s)>1 then
   if (s[1]='#') and (s[2]='#') then begin
    p:=Pos('=',s);
    if p>0 then begin
     cmd:=Copy(s,3,p-3);
     arg:=mime_decode(Copy(s,p+1,MaxLeng));
    end else begin
     cmd:=Copy(s,3,MaxLeng);
     arg:='';
    end;
    ref:=val(cmd);
    if typetag(ref)>0 then begin
     for i:=1 to Dim.Count do begin
      kind:=Dim.Serv[i].Kind;
      if (kind=dis_info) or (kind=dic_cmnd) then
      for j:=1 to Dim.Serv[i].TagCount do
      if ref=Dim.Tags.Ref[Dim.Serv[i].TagIndex+j-1] then begin
       if Length(arg)>0 then
       case typetag(ref) of
        0: ;
        1: if Length(arg)>=SizeOfInteger then b:=iSetTag(ref,dump2i(arg));
        2: if Length(arg)>=SizeOfReal    then b:=rSetTag(ref,dump2r(arg));
        3: if Length(arg)>=SizeOfChar    then b:=sSetTag(ref,arg);
       end;
       Dim_Update(i,'');
      end;
     end;
    end else begin
     for i:=1 to Dim.Count do begin
      kind:=Dim.Serv[i].Kind;
      if (kind=dis_info) or (kind=dic_cmnd) then
      if IsSameText(cmd,Dim.Serv[i].Nick)
      then Dim_Update(i,arg);
     end;
    end;
    s:='';
   end;
  end;
  if Length(s)>0 then Dim_Send(s);
  cmd:='';
  arg:='';
 end;
 {
 Clear all strings
 }
 procedure ClearStrings;
 begin
  StdIn_Line:='';
  winConsole:='';
  Dim_Clear(0,false);
  if runcount=1 then fixmaxavail:=maxavail;
  if isinf(runcount) then
  if maxavail<>fixmaxavail then Trouble('String Manager Leak = '+str(fixmaxavail-maxavail));
 end;
 {
 Initialize and check tag
 }      
 procedure InitTag(var tag:integer; name:string; typ:integer);
 begin
  tag:=findtag(name);
  if (typ>0) and (typetag(tag)<>typ) then errors:=errors+1;
 end;
begin
 {
 Initialization actions on Start...
 }
 if runcount=1 then begin
  {
  Initialize errors...
  }
  errors:=0;
  errorcode:=registererr(devname);
  errorserv:=registererr(devname+': Server die.');
  errorterm:=registererr(devname+': terminated.');
  SizeOfChar:=Length('a');
  SizeOfReal:=Length(dump(pi));
  SizeOfInteger:=Length(dump(1));
  {
  Clear and initialize variables...
  }
  ClearStrings;
  Success('Initialization:');
  DebugFlags:=val(ReadIni('DebugFlags'));
  Dim_Init;
  {
  Check available data space
  }
  if MaxAvail<512
  then Trouble('MaxAvail='+Str(MaxAvail))
  else Success('MaxAvail='+Str(MaxAvail));
  if StackAvail<512
  then Trouble('StackAvail='+Str(StackAvail))
  else Success('StackAvail='+Str(StackAvail));
  {
  Open console window...
  }
  if val(ReadIni('OpenConsole'))>0 then begin
   winConsole:=ParamStr('Console '+devname);
   b:=winshow(winConsole);
   b:=windraw(winConsole+'|top=0|left=170|Width=600|Height=317');
   b:=winselect(winConsole);
   if val(ReadIni('OpenConsole'))>1 then b:=winhide(winConsole);
  end;
  {
  Is it Ok?
  }
  if errors=0 then Success('Start Ok.') else Trouble('Start Fails.');
  if errors<>0 then b:=fixerror(errorcode);
  Ok:=(errors=0);
 end else
 {
 Finalization actions on Stop...
 }
 if isinf(runcount) then begin
  Dim_Free;
  ClearStrings;
  Success('Stop.');
 end else
 {
 Actions on Poll
 }
 if Ok then begin
  {
  Check standard I/O errors...
  }
  if ioresult<>0 then b:=fixerror(errorcode);
  {
  Process standard input...
  }
  while StdIn_Readln(StdIn_Line) do StdIn_Process(StdIn_Line);
  {
  If DIM server is not still running,
  try to start DIM server periodically.
  }
  if Dim.Tid=0 then
  if tm_event(Dim.Timer) then Dim_Start;
  {
  Communicate with DIM server if one still running...
  }
  if Dim.Tid>0 then
  if task_wait(Dim.Tid,0) then begin
   {
   If has data coming from Task StdOut, analyse it...
   }
   if task_rxcount(Dim.Tid)>0 then
   while Dim_Readln(Dim.Line) do Dim_Process(Dim.Line);
   {
   DIM timer actions...
   }
   if tm_event(Dim.Timer) then begin
    Dim_Send('@memory');
    Dim_Send('@errors=0');
   end;
   {
   Update services, if needed.
   }
   Dim_Poll;
   Dim_Stat;
  end else begin
   HostTerm('DimSrv terminated, exit code = '+str(task_result(Dim.Tid)));
   Dim_Stop;
  end;
 end;
end.
