freepascal.ru

-в событии oncreate проверять список запущенных программ (например через tprocess запускать утилиту ps и анализировать ее вывод)

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

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.

в самой программе предусмотреть мониторинг появления файл-флага (ну например через ttimer) и если он появился, то загружать из него плей-лист

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

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.


Конечно есть: http://wiki.lazarus.freepascal.org/UniqueInstance

coyot.rush писал(а):Из FIFO файла (Linux)

А не будет ли достаточным проверять, не создан ли FIFO-файл? Без отдельного lock-файла?

Зачем заменить? там же есть named pipes... Правда, как оно там работает — понятия не имею.

Ну и на сокетах данный механизм можно реализовать... Тогда сразу можно будет и с другой машины подавать плейлист/команды

coyot.rush писал(а):Имелось ввиду аналог
named pipes http://msdn.microsoft.com/en-us/library/aa365590.aspx

В смысле — аналог для других систем?

minoshi писал(а):Простите если я сморозю глупость (просто со сферой пайпов я вообще пока не сталкивался), но я так понял, что кроссплатформенного решения нет?

Odyssey писал(а):Конечно есть: http://wiki.lazarus.freepascal.org/UniqueInstance

Конечно есть: http://wiki.lazarus.freepascal.org/UniqueInstance

minoshi писал(а):Простите если я сморозю глупость (просто со сферой пайпов я вообще пока не сталкивался), но я так понял, что кроссплатформенного решения нет?