freepascal.compiler/fcl/os2/eventlog.inc

{
    This file is part of the Free Pascal run time library.
    Copyright (c) 2003 by the Free Pascal development team

    OS/2 event logging facility.

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}

{$R-}

const
  EventLogAvailable: boolean = false;

  No_Handle = cardinal ($FFFFFFFF);

  EventLogHandle: cardinal = No_Handle;

  sis_MMIOAddr = 0;
  sis_MEC_Table = 1;
  sis_Sys_Log = 2;

  lf_LogEnable = 1;     { Logging enabled }
  lf_LogAvailable = 2;  { Logging available }

  ErrLog_Service = 1;
  ErrLog_Version = 1;

  lf_Bit_ProcName = 1;    {used to indicate whether the current error log}
                          {entry packet contains space in which the error}
                          {logging facility can place a long process name}
                          {("on" indicates YES, "off" indicates NO)      }
  lf_Bit_Origin_256 = 2;  {used to indicate whether the current error log }
                          {entry packet contains an 8 byte originator name}
                          {or a 256 byte originator name ("on" indicates  }
                          {a 256 byte originator name, "off" indicates an }
                          {8 byte originator name)                        }
  lf_Bit_DateTime = 4;    {used to indicate that the caller has placed time}
                          {and date values in the Error Log entry packet   }
                          {and does not wish to have those values modified }
                          {during the logging process ("on" indicates that }
                          {the error log entry packet already contains time}
                          {and date values, "off" indicates the packet does}
                          {not already contain time and date values)       }
  lf_Bit_Suspend = 8;
  lf_Bit_Resume = 16;
  lf_Bit_Redirect = 32;
  lf_Bit_GetStatus = 64;
  lf_Bit_Register = 128;
  lf_Bit_Remote_Fail = 256;

  MaxDataSize = 3400;

type
  Str3 = string [3];

  TLogRecord = record
    Len: word;          { length of this record (including the Len field) }
    Rec_ID: word;       { record ID }
    Status: cardinal;   { record status bits (see lf_Bit_* constants) }
    Qualifier: array [1..4] of char;    { qualifier tag }
    Reserved: cardinal;
    Time: cardinal;     { hours, minutes, seconds, hundreds }
    Date: cardinal;     { day, month, year (stored as word) }
    case byte of
     0: (Data: array [1..MaxDataSize] of char);
     1: (Originator256: array [0..255] of char;
         ProcessName_O256: array [1..260] of char;
         FormatDLLName_O256_ProcName: array [1..12] of char;
         Data_O256_ProcName: array [1..MaxDataSize] of char);
     2: (Originator256b: array [0..255] of char;
         FormatDLLName_O256: array [1..12] of char;
         Data_O256: array [1..MaxDataSize] of char);
     3: (Originator8: array [0..7] of char;
         ProcessName_O8: array [1..260] of char;
         FormatDLLName_O8_ProcName: array [1..12] of char;
         Data_O8_ProcName: array [1..MaxDataSize] of char);
     4: (Originator8b: array [0..7] of char;
         FormatDLLName_O8: array [1..12] of char;
         Data_O8: array [1..MaxDataSize] of char);
  end;
  LogRecord = TLogRecord;
  PLogRecord = ^TLogRecord;

  TLogEntryRec = record
    Version: word;                      {this version is 1}
    Count: word;                        {number of log records in this buffer}
    LogRec: array [0..0] of TLogRecord; {repeated count times}
  end;
  LogEntryRec = TLogEntryRec;
  PLogEntryRec = ^TLogEntryRec;


function DosQueryRASInfo (Index: cardinal; var PBuffer: pointer): longint;
                                          cdecl; external 'DOSCALLS' index 112;

function LogOpen (var Handle: cardinal): longint; cdecl;
                                                 external 'DOSCALLS' index 430;

function LogClose (Handle: cardinal): longint; cdecl;
                                                 external 'DOSCALLS' index 431;

function LogAddEntries (Handle: cardinal; Service: cardinal;
      LogEntries: PLogEntryRec): longint; cdecl; external 'DOSCALLS' index 432;

function LogAddEntries (Handle: cardinal; Service: cardinal;
  var LogEntries: TLogEntryRec): longint; cdecl; external 'DOSCALLS' index 432;


function TEventLog.DefaultFileName: string;

begin
  Result := GetEnvironmentVariable ('TEMP');
  if Result = '' then
    begin
      Result := GetEnvironmentVariable ('TMP');
      if Result = '' then Result := ExpandFileName ('.');
    end;
  Result := Result + DirectorySeparator +
                        ChangeFileExt (ExtractFileName (ParamStr (0)), '.log');
end;


Resourcestring
  SErrNoSysLog = 'Could not open system log (error %d)';
  SErrLogFailed = 'Failed to log entry (error %d)';


procedure TEventLog.ActivateSystemLog;

var
  P: PWord;

begin
  CheckIdentification;
  DosQueryRASInfo (sis_Sys_Log, P);
  EventLogAvailable := P^ and (lf_LogAvailable or lf_LogEnable)
                                           = (lf_LogAvailable or lf_LogEnable);
  if not (EventLogAvailable) then
    ActivateFileLog
  else
    if EventLogHandle = No_Handle then
      LogOpen (EventLogHandle);
end;


procedure TEventLog.DeactivateSystemLog;

begin
  if EventLogAvailable then
    if EventLogHandle <> No_Handle then
      begin
        LogClose (EventLogHandle);
        EventLogHandle := No_Handle;
      end
  else
    DeactivateFileLog;
end;


procedure TEventLog.WriteSystemLog (EventType: TEventType; Msg: string);

const
  WinET: array [TEventType] of Str3 = ('USR', 'INF', 'WRN', 'ERR', 'DBG');

var
  P: PLogEntryRec;
  S: string;
  Cnt, TSize, DSize: cardinal;
  W: word;

begin
  if not (EventLogAvailable) then
    WriteFileLog (EventType, Msg)
  else
    begin
      S := Copy (Identification, 1, 256);
      TSize := Length (Msg);
      Cnt := Succ (Pred (TSize) div MaxDataSize);
      if Cnt > high (word) then
        begin
          Cnt := high (word);
          TSize := Cnt * MaxDataSize;
        end;
      DSize := TSize + 4 + Cnt * (24 + 256 + 260 + 12);
      GetMem (P, DSize);
      FillChar (P^, DSize, #0);
      with P^ do
        begin
          Version := ErrLog_Version;
          Count := Cnt;
          for W := 0 to Pred (Cnt) do
            with LogRec [W] do
              begin
                if (W = Pred (Cnt)) and (TSize mod MaxDataSize <> 0) then
                  begin
                    Len := 24 + 256 + 260 + 12 + TSize mod MaxDataSize;
                    Move (Msg [Succ (W * MaxDataSize)],
                                Data_O256_ProcName [1], TSize mod MaxDataSize);
                  end
                else
                  begin
                    Len := 24 + 256 + 260 + 12 + MaxDataSize;
                    Move (Msg [Succ (W * MaxDataSize)],
                                          Data_O256_ProcName [1], MaxDataSize);
                  end;
                Rec_ID := $4650; { FP }
                Status := lf_Bit_ProcName or lf_Bit_Origin_256;
                Move (WinET [EventType] [1], Qualifier,
                                                   Length (WinET [EventType]));
                Move (S [1], Originator256 [0], Length (S));
              end;
        end;
      LogAddEntries (EventLogHandle, ErrLog_Service, P);
      FreeMem (P, DSize);
    end;
end;

Function TEventLog.RegisterMessageFile(AFileName : String) : Boolean;

begin
  Result:=True;
end;

function TEventLog.MapTypeToCategory(EventType: TEventType): Word;
begin
  Result:=0;
  If (EventType=ETCustom) then
    DoGetCustomEventCategory(Result);
end;

function TEventLog.MapTypeToEventID(EventType: TEventType): DWord;

begin
  Result:=0;
  If (EventType=ETCustom) then
    DoGetCustomEventID(Result);
end;

function TEventLog.MapTypeToEvent(EventType: TEventType): DWord;

begin
  If EventType=etCustom Then
    begin
    Result:=CustomLogType;
    DoGetCustomEvent(Result);
    end
  else
    Result := ord (EventType);
end;