home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 November / Chip_2002-11_cd1.bin / zkuste / delphi / unity / d56 / MJOURNAL.ZIP / MiTeC_Journal.pas next >
Pascal/Delphi Source File  |  2002-08-12  |  15KB  |  509 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {             MiTeC Journal Object                      }
  5. {           version 1.0 for Delphi 5,6                  }
  6. {                                                       }
  7. {           Copyright ⌐ 2002 Michal Mutl                }
  8. {                                                       }
  9. {*******************************************************}
  10.  
  11. unit MiTeC_Journal;
  12.  
  13. interface
  14.  
  15. uses Windows, Classes, SysUtils;
  16.  
  17. type
  18.   TEventLevel = (elStart, elSystem, elBegin, elEnd, elInformation, elWarning,
  19.                  elError, elData, elAction);
  20.  
  21.   TJournalRecord = record
  22.     Level: TEventLevel;
  23.     Timestamp: TDateTime;
  24.     TimestampStr: string;
  25.     Message: string;
  26.   end;
  27.  
  28.   TJournalBuffer = array of TJournalRecord;
  29.  
  30.   TJournal = class
  31.   private
  32.     FProcessHandle: THandle;
  33.     FFile: TFileStream;
  34.     FBuffer: TJournalBuffer;
  35.     FInternalSave: Boolean;
  36.     FFilename, FMachine, FUser: string;
  37.     FOverwrite: Boolean;
  38.     FStartTime,FStopTime: comp;
  39.     FInternalTime: array of Comp;
  40.     FModuleName: string;
  41.     FModuleVersion: string;
  42.     function GetRecord(Index: DWORD): TJournalRecord;
  43.     function GetRecordCount: DWORD;
  44.     procedure SetRecord(Index: DWORD; const Value: TJournalRecord);
  45.     procedure AddRecord(ATimestamp: TDateTime; AMessage: string; ALevel: TEventLevel); overload;
  46.     procedure AddRecord(ATimestamp: string; AMessage: string; ALevel: TEventLevel); overload;
  47.     procedure AddRecord(ARecord: TJournalRecord); overload;
  48.     procedure CreateFile;
  49.     procedure PushTime(Time: comp);
  50.     function PopTime: comp;
  51.   public
  52.     constructor Create(ADir,AFileNamePrefix: string; AInternalSave,AOverwrite,AReadOnly: boolean);
  53.     destructor Destroy; override;
  54.  
  55.     procedure WriteEvent(AMessage: string; ALevel: TEventLevel);
  56.     procedure WriteSpace;
  57.     procedure WriteEventFmt(const AFormat: string; const AArgs: array of const; ALevel: TEventLevel);
  58.     procedure LoadFromFile(AFilename: string);
  59.     procedure SaveToFile(AFilename: string);
  60.     procedure Clear;
  61.     procedure StartTimer;
  62.     function StopTimer: Comp;
  63.  
  64.     property FileName: string read FFilename;
  65.     property InternalSave: Boolean read FInternalSave write FInternalSave;
  66.     property Overwrite: Boolean read FOverwrite write FOverwrite;
  67.     property Records[Index: DWORD]: TJournalRecord read GetRecord write SetRecord;
  68.     property RecordCount: DWORD read GetRecordCount;
  69.  
  70.     property ModuleName: string read FModuleName;
  71.     property ModuleVersion: string read FModuleVersion;
  72.   end;
  73.  
  74. function FormatTimer(ATime: Comp): string;
  75.  
  76. const
  77.   EventLevels: array[TEventLevel] of string = ('Start  ',
  78.                                                'System ',
  79.                                                'Begin  ',
  80.                                                'End    ',
  81.                                                'Info   ',
  82.                                                'Warning',
  83.                                                'Error  ',
  84.                                                'Data   ',
  85.                                                'Action ');
  86.   extMJF = '.mjf';
  87.  
  88. resourcestring
  89.   rsJournalStartedInEXE = 'Process "%s" version "%s" running on "%s\%s"';
  90.   rsJournalFinishedInEXE = 'Process terminated with exit code %d';
  91.   rsJournalStartedInModule = 'Module "%s" version "%s" was called from "%s" version "%s" running on "%s\%s"';
  92.   rsJournalFinishedInModule = 'Module removed from memory';
  93.  
  94. implementation
  95.  
  96. uses StrUtils, Registry;
  97.  
  98. type
  99.   TVersionInfo = record
  100.     FileName,
  101.     Version,
  102.     ProductName,
  103.     CompanyName,
  104.     Description,
  105.     Comments,
  106.     Copyright: string;
  107.     Major,
  108.     Minor,
  109.     Release,
  110.     Build: DWORD;
  111.   end;
  112.  
  113. function FormatTimer;
  114. begin
  115.   ATime:=ATime/1000;
  116.   Result:=Format('%2.2d:%2.2d:%2.2d',[Round(ATime) div 3600,
  117.                                       Round(ATime) div 60,
  118.                                       Round(ATime) mod 60]);
  119. end;
  120.  
  121. function GetFileVerInfo(const fn :string; var VI:TVersionInfo): Boolean;
  122. var
  123.   VersionHandle,VersionSize :dword;
  124.   PItem,PVersionInfo :pointer;
  125.   FixedFileInfo :PVSFixedFileInfo;
  126.   il :uint;
  127.   p :array [0..MAX_PATH - 1] of char;
  128.   translation: string;
  129. begin
  130.   if fn<>'' then begin
  131.     VI.FileName:=fn;
  132.     strpcopy(p,fn);
  133.     versionsize:=getfileversioninfosize(p,versionhandle);
  134.     Result:=False;
  135.     if versionsize=0 then
  136.       exit;
  137.     getMem(pversioninfo,versionsize);
  138.     try
  139.       if getfileversioninfo(p,versionhandle,versionsize,pversioninfo) then begin
  140.         Result:=True;
  141.         if verqueryvalue(pversioninfo,'\',pointer(fixedfileinfo),il) then begin
  142.           VI.version:=inttostr(hiword(fixedfileinfo^.dwfileversionms))+
  143.                    '.'+inttostr(loword(fixedfileinfo^.dwfileversionms))+
  144.                    '.'+inttostr(hiword(fixedfileinfo^.dwfileversionls))+
  145.                    '.'+inttostr(loword(fixedfileinfo^.dwfileversionls));
  146.           VI.Major:=hiword(fixedfileinfo^.dwfileversionms);
  147.           VI.Minor:=loword(fixedfileinfo^.dwfileversionms);
  148.           VI.Release:=hiword(fixedfileinfo^.dwfileversionls);
  149.           VI.Build:=loword(fixedfileinfo^.dwfileversionls);
  150.  
  151.           if verqueryvalue(pversioninfo,pchar('\VarFileInfo\Translation'),pitem,il) then begin
  152.             translation:=IntToHex(PDWORD(pitem)^,8);
  153.             translation:=Copy(translation,5,4)+Copy(translation,1,4);
  154.           end;
  155.           if verqueryvalue(pversioninfo,pchar('\StringFileInfo\'+translation+'\FileDescription'),pitem,il) then
  156.             VI.description:=pchar(pitem);
  157.  
  158.           if verqueryvalue(pversioninfo,pchar('\StringFileInfo\'+translation+'\LegalCopyright'),pitem,il) then
  159.             VI.Copyright:=pchar(pitem);
  160.  
  161.           if verqueryvalue(pversioninfo,pchar('\StringFileInfo\'+translation+'\Comments'),pitem,il) then
  162.             VI.Comments:=pchar(pitem);
  163.  
  164.           if verqueryvalue(pversioninfo,pchar('\StringFileInfo\'+translation+'\ProductName'),pitem,il) then
  165.             VI.ProductName:=pchar(pitem);
  166.  
  167.           if verqueryvalue(pversioninfo,pchar('\StringFileInfo\'+translation+'\CompanyName'),pitem,il) then
  168.             VI.CompanyName:=pchar(pitem);
  169.  
  170.         end;
  171.       end;
  172.     finally
  173.       freeMem(pversioninfo,versionsize);
  174.     end;
  175.   end;
  176. end;
  177.  
  178. function GetUserAndDomainName(hProcess :THandle; var UserName, DomainName :string) :boolean;
  179. const
  180.   RTN_OK = 0;
  181.   RTN_ERROR = 13;
  182.   MY_BUFSIZE = 512;
  183. var
  184.   hToken :THandle;
  185.   InfoBuffer :array[0..MY_BUFSIZE] of byte;
  186.   snu :SID_NAME_USE;
  187.   cchUserName,cchDomainName :dword;
  188.   cbInfoBuffer :DWORD;
  189. begin
  190.   cbInfoBuffer:=MY_BUFSIZE;
  191.   result:=false;
  192.   if OpenProcessToken(hProcess,TOKEN_QUERY,hToken) then begin
  193.     if GetTokenInformation(hToken,TokenUser,@InfoBuffer,cbInfoBuffer,cbInfoBuffer) then
  194.       result:=LookupAccountSid(nil,PSID(@InfoBuffer),@UserName,
  195.                           cchUserName,@DomainName,cchDomainName,snu);
  196.     CloseHandle(hToken);
  197.   end;
  198. end;
  199.  
  200. function GetMachine :string;
  201. var
  202.   n :dword;
  203.   buf :pchar;
  204. const
  205.   rkMachine = {HKEY_LOCAL_MACHINE}'\SYSTEM\CurrentControlSet\Control\ComputerName\ComputerName';
  206.     rvMachine = 'ComputerName';
  207. begin
  208.   n:=255;
  209.   buf:=stralloc(n);
  210.   GetComputerName(buf,n);
  211.   result:=buf;
  212.   strdispose(buf);
  213.   with TRegistry.Create do begin
  214.     rootkey:=HKEY_LOCAL_MACHINE;
  215.     if OpenKeyReadOnly(rkMachine) then begin
  216.       if ValueExists(rvMachine) then
  217.         result:=ReadString(rvMachine);
  218.       closekey;
  219.     end;
  220.     free;
  221.   end;
  222. end;
  223.  
  224. function GetUser :string;
  225. var
  226.   n :dword;
  227.   buf :pchar;
  228. begin
  229.   n:=255;
  230.   buf:=stralloc(n);
  231.   GetUserName(buf,n);
  232.   result:=buf;
  233.   strdispose(buf);
  234. end;
  235.  
  236. { TJournal }
  237.  
  238. procedure TJournal.AddRecord(ATimestamp: TDateTime; AMessage: string;
  239.   ALevel: TEventLevel);
  240. begin
  241.   SetLength(FBuffer,Length(FBuffer)+1);
  242.   with FBuffer[High(FBuffer)] do begin
  243.     Level:=ALevel;
  244.     Timestamp:=ATimestamp;
  245.     TimestampStr:=FormatDateTime('yyy-mm-dd hh:mm:ss',ATimestamp);
  246.     Message:=AMessage;
  247.   end;
  248. end;
  249.  
  250. procedure TJournal.AddRecord(ATimestamp: string; AMessage: string;
  251.   ALevel: TEventLevel);
  252. begin
  253.   SetLength(FBuffer,Length(FBuffer)+1);
  254.   with FBuffer[High(FBuffer)] do begin
  255.     Level:=ALevel;
  256.     Timestamp:=0;
  257.     TimeStampStr:=ATimestamp;
  258.     Message:=AMessage;
  259.   end;
  260. end;
  261.  
  262. procedure TJournal.AddRecord(ARecord: TJournalRecord); 
  263. begin
  264.   SetLength(FBuffer,Length(FBuffer)+1);
  265.   FBuffer[High(FBuffer)]:=ARecord;
  266. end;
  267.  
  268. procedure TJournal.Clear;
  269. begin
  270.   SetLength(FBuffer,0);
  271.   if Assigned(FFile) then begin
  272.     FlushFileBuffers(FFile.Handle);
  273.     FFile.Free;
  274.   end;
  275.   DeleteFile(FFilename);
  276.   CreateFile;
  277. end;
  278.  
  279. constructor TJournal.Create;
  280. var
  281.   p: PChar;
  282.   VIM: TVersionInfo;
  283. begin
  284.   FMachine:=GetMachine;
  285.   FUser:=GetUser;
  286.   GetUserAndDomainName(GetCurrentProcess,FUser,FMachine);
  287.   p:=Allocmem(256);
  288.   GetModuleFileName(hInstance,p,255);
  289.   FModulename:=p;
  290.   GetFileVerInfo(p,VIM);
  291.   FModuleVersion:=VIM.Version;
  292.   FreeMem(p);
  293.   FInternalSave:=AInternalSave;
  294.   FOverwrite:=AOverwrite;
  295.   SetLength(FBuffer,0);
  296.   if not AReadOnly then begin
  297.     AFileNamePrefix:=Trim(ChangeFileExt(ExtractFilename(AFileNamePrefix),''));
  298.     if AFileNamePrefix<>'' then
  299.       AFileNamePrefix:=AFilenamePrefix+'_';
  300.     FFilename:=IncludeTrailingBackslash(ADir)+AFilenamePrefix+FormatDateTime('yyyy-mm-dd',Date)+extMJF;
  301.     CreateFile;
  302.   end;
  303. end;
  304.  
  305. procedure TJournal.CreateFile;
  306. var
  307.   VIM,VIP: TVersionInfo;
  308.   p: PChar;
  309. begin
  310.   if Assigned(FFile) then begin
  311.     FlushFileBuffers(FFile.Handle);
  312.     FFile.Free;
  313.   end;
  314.   try
  315.     if FOverwrite or not FileExists(FFilename) then begin
  316.       FFile:=TFileStream.Create(FFileName,fmCreate or fmShareDenyWrite);
  317.       FFile.Free;
  318.     end;
  319.     FFile:=TFileStream.Create(FFileName,fmOpenWrite or fmShareDenyWrite);
  320.     if FFile.Size>0 then begin
  321.       FFile.Position:=FFile.Size;
  322.       WriteSpace;
  323.     end;
  324.     FProcessHandle:=GetModuleHandle(nil);
  325.     GetFileVerInfo(ParamStr(0),VIP);
  326.     if FProcessHandle<>hInstance then begin
  327.       p:=Allocmem(256);
  328.       GetModuleFileName(hInstance,p,255);
  329.       GetFileVerInfo(p,VIM);
  330.       WriteEvent(Format(rsJournalStartedInModule,[string(p),VIM.Version,ParamStr(0),VIP.Version,FMachine,FUser]),elStart);
  331.       Freemem(p);
  332.     end else
  333.       WriteEvent(Format(rsJournalStartedInEXE,[ParamStr(0),VIP.Version,FMachine,FUser]),elStart);
  334.   except
  335.     on e: Exception do begin
  336.       FFile:=nil;
  337.       FFilename:='';
  338.     end;
  339.   end;
  340. end;
  341.  
  342. destructor TJournal.Destroy;
  343. var
  344.   i: Integer;
  345. begin
  346.   for i:=0 to High(FInternalTime) do
  347.     WriteEvent('Freeing internal timer leak',elEnd);
  348.   if FProcessHandle<>hInstance then
  349.     WriteEvent(rsJournalFinishedInModule,elSystem)
  350.   else
  351.     WriteEventFmt(rsJournalFinishedInEXE,[ExitCode],elSystem);
  352.   SetLength(FBuffer,0);
  353.   if Assigned(FFile) then begin
  354.     FlushFileBuffers(FFile.Handle);
  355.     FFile.Free;
  356.   end;
  357.   inherited;
  358. end;
  359.  
  360. function TJournal.GetRecord(Index: DWORD): TJournalRecord;
  361. begin
  362.   try
  363.     Result:=FBuffer[Index];
  364.   except
  365.     ZeroMemory(@Result,SizeOf(TJournalRecord));
  366.   end;
  367. end;
  368.  
  369. function TJournal.GetRecordCount: DWORD;
  370. begin
  371.   Result:=Length(FBuffer);
  372. end;
  373.  
  374. procedure TJournal.LoadFromFile(AFilename: string);
  375. var
  376.   fs: TFileStream;
  377.   sl: TStringList;
  378.   i,p: Integer;
  379.   j: TEventLevel;
  380.   s,v: string;
  381.   r: TJournalRecord;
  382. begin
  383.  
  384.     Clear;
  385.     sl:=TStringList.Create;
  386.     try
  387.       fs:=TFileStream.Create(AFileName,fmOpenRead or fmShareDenyNone);
  388.       sl.LoadFromStream(fs);
  389.       for i:=0 to sl.Count-1 do begin
  390.         s:=sl[i];
  391.         if Pos('[',s)=1 then begin
  392.           p:=Pos(']',s);
  393.           r.TimestampStr:=Copy(s,2,p-2);
  394.           Delete(s,1,p);
  395.           p:=Pos(']',s);
  396.           v:=Trim(Copy(s,2,p-2));
  397.           r.Level:=elError;
  398.           for j:=Low(EventLevels) to High(EventLevels) do
  399.             if CompareText(v,Trim(EventLevels[j]))=0 then begin
  400.               r.Level:=j;
  401.               Break;
  402.             end;
  403.           Delete(s,1,p+1);
  404.           r.Message:=s;
  405.           AddRecord(r);
  406.         end;
  407.       end;
  408.     finally
  409.       fs.Free;
  410.       sl.Free;
  411.     end;
  412. end;
  413.  
  414. function TJournal.PopTime: comp;
  415. begin
  416.   Result:=FInternalTime[High(FInternalTime)];
  417.   SetLength(FInternalTime,High(FInternalTime));
  418. end;
  419.  
  420. procedure TJournal.PushTime(Time: comp);
  421. begin
  422.   SetLength(FInternalTime,Length(FInternalTime)+1);
  423.   FInternalTime[High(FInternalTime)]:=Time;
  424. end;
  425.  
  426. procedure TJournal.SaveToFile(AFilename: string);
  427. var
  428.   i: Integer;
  429.   sl: TStringList;
  430. begin
  431.   sl:=TStringList.Create;
  432.   try
  433.     for i:=0 to High(FBuffer) do
  434.       with FBuffer[i] do
  435.         sl.Add(Format('[%s][%s] %s',[TimestampStr,EventLevels[Level],Message]));
  436.     sl.SaveToFile(AFilename);
  437.   finally
  438.     sl.Free;
  439.   end;
  440. end;
  441.  
  442. procedure TJournal.SetRecord(Index: DWORD; const Value: TJournalRecord);
  443. begin
  444.   FBuffer[Index]:=Value;
  445. end;
  446.  
  447. procedure TJournal.StartTimer;
  448. begin
  449.   FStartTime:=GetTickCount;
  450.   FStopTime:=FStartTime;
  451. end;
  452.  
  453. function TJournal.StopTimer: Comp;
  454. begin
  455.   FStopTime:=GetTickCount;
  456.   Result:=FStopTime-FStartTime;
  457. end;
  458.  
  459. procedure TJournal.WriteEvent(AMessage: string; ALevel: TEventLevel);
  460. var
  461.   s: string;
  462.   dt: TDateTime;
  463.   t: comp;
  464. begin
  465.   AMessage:=StringReplace(AMessage,#10#13,' ',[rfReplaceAll,rfIgnoreCase]);
  466.   AMessage:=StringReplace(AMessage,#13#10,' ',[rfReplaceAll,rfIgnoreCase]);
  467.   AMessage:=StringReplace(AMessage,#10,' ',[rfReplaceAll,rfIgnoreCase]);
  468.   AMessage:=StringReplace(AMessage,#13,' ',[rfReplaceAll,rfIgnoreCase]);
  469.   if ALevel=elBegin then
  470.     PushTime(GetTickCount);
  471.   if ALevel=elEnd then begin
  472.     t:=GetTickCount-PopTime;
  473.     if AMessage='' then
  474.       AMessage:=AMessage+'Elapsed time: '+FormatTimer(t)
  475.     else
  476.       AMessage:=AMessage+' - Elapsed time: '+FormatTimer(t);
  477.   end;
  478.   dt:=Now;
  479.   if Assigned(FFile) then begin
  480.     s:=Format('[%s][%s] %s',[FormatDateTime('yyyy-mm-dd hh:mm:ss',dt),EventLevels[ALevel],AMessage])+#13#10;
  481.     FFile.WriteBuffer(PChar(s)^,Length(s));
  482.     FlushFileBuffers(FFile.Handle);
  483.   end;
  484.   if FInternalSave then
  485.     AddRecord(dt,AMessage,ALevel);
  486. end;
  487.  
  488. procedure TJournal.WriteEventFmt(const AFormat: string;
  489.   const AArgs: array of const; ALevel: TEventLevel);
  490. var
  491.   s: string;
  492. begin
  493.   s:=Format(AFormat,AArgs);
  494.   WriteEvent(s,ALevel);
  495. end;
  496.  
  497. procedure TJournal.WriteSpace;
  498. var
  499.   s: string;
  500. begin
  501.   if Assigned(FFile) then begin
  502.     s:=#13#10;
  503.     FFile.WriteBuffer(PChar(s)^,Length(s));
  504.     FlushFileBuffers(FFile.Handle);
  505.   end;
  506. end;
  507.  
  508. end.
  509.