freepascal.ru

Код: Выделить всё

program xelplayer;
{$ifdef FPC}{$mode objfpc}{$h+}{$endif}
{$ifdef FPC}
 {$ifdef mswindows}{$apptype gui}{$endif}
{$endif}
uses
 {$ifdef FPC}{$ifdef linux}cthreads,{$endif}{$endif}msegui,mseforms,main, openunit;
begin
 //Проверка на запуск второй копии
 application.createform(tmainfo,mainfo);
 application.createform(topenunitfo,openunitfo);  
 application.run;
end.

Код: Выделить всё

unit LogPFPC;
//Небольшой локальный клиент-север для отладки
{$ifdef FPC}{$mode objfpc}{$h+}{$endif}
{$WEAKPACKAGEUNIT OFF}
interface

uses
  Classes, SysUtils, libc;

const
  LevelLigth  = 'L';
  LevelNormal = 'N';
  LevelMax    = 'M';

type

  { TLogDPFPC }

  TLogDPFPC = class(TObject)
    constructor Create();
    destructor Destroy; override;
    procedure AddInLog(Text: string; DebugLevel: char = LevelNormal;
      DebugFlag: boolean = True);
  private
    HP:   integer;
    Path: string;
    PApplicationName: string;
  end;

  { TLogRPFPC }

  TLogRPFPC = class(TObject)
    Path: string;
    constructor Create(ApplicationName: string);
    destructor Destroy; override;
    function ReadLog(DebugLevel: char): string;
  private
    HP: integer;
  end;

const
  a = 0400;
  MarkerCr = #10;
  MarkerDebugFlag = #10;

var
  LogDP: TLogDPFPC;

implementation


//const

constructor TLogDPFPC.Create();
begin
  PApplicationName := ExtractFileName(ParamStr(0));
  Path := GetEnvironmentVariable('HOME') + '/.' + 'debug.pipes.' + PApplicationName;
  if libc.mkfifo(PChar(Path), a) = 0 then
    writeln('Create Pipes');
  Writeln('Open Pipes ' + Path);
  HP := Open(PChar(Path), O_RDWR);
  //insert some code
end;

destructor TLogDPFPC.Destroy;
begin
  libc.__close(HP);
  inherited Destroy;
end;


procedure TLogDPFPC.AddInLog(Text: string; DebugLevel: char = LevelNormal;
  DebugFlag: boolean = True);
var
  buf:  array of char;
  l, i: integer;
begin
  if DebugFlag = True then
  begin
    L := Length(Text);
    SetLength(buf, L);
    for I := 0 to L - 1 do
    begin
      if Text[ i + 1]=#13 then Text[i + 1]:='_';
      buf[i] := Text[i + 1];
    end;
    libc.__write(HP, buf[0], L);
    SetLength(buf, 2);
    buf[0] := DebugLevel;
    Buf[1] := MarkerCr;
    libc.__write(HP, buf[0], 2);
  end;
end;



{ TLogRPFPC }

constructor TLogRPFPC.Create(ApplicationName: string);
begin
  Path := GetEnvironmentVariable('HOME') + '/.' + 'debug.pipes.' + ApplicationName;
  writeln('Open Pipes ' + Path);
  HP := Open(PChar(Path), O_RDWR);
end;

destructor TLogRPFPC.Destroy;
begin
  libc.__close(HP);
  inherited Destroy;
end;

function TLogRPFPC.ReadLog(DebugLevel: char): string;
var
  c:      char;
  tmpstr: string;
begin
  DebugLevel := 'N';
  tmpstr     := '';
  while c <> MarkerCr do
  begin
    if libc.__read(HP, c, 1) > 0 then
    begin
      tmpstr := tmpstr + c;
    end;
  end;
  Result     := Copy(tmpstr, 1, Length(tmpstr) - 2);
  DebugLevel :=Copy(tmpstr, Length(tmpstr), Length(tmpstr))[1];
end;



end.