svn/view/chain.pas

unit chain;

{$IFDEF FPC}
  {$MODE DELPHI}{$H+}
{$ENDIF}

interface

implementation
uses
      SysUtils, Forms, Process,
      listcoll,base,base0,variabl,struct,express,
      helpctex,texthand,control,sconsts,statemen;


function ShellExec(s1,s2:string; opWaitFor:boolean):boolean;
var
   AProcess: TProcess;
begin
   result:=false;
   AProcess := TProcess.Create(nil);
   AProcess.CommandLine :=s1 + ' ' +s2;
   if opWaitFor then
     AProcess.Options := AProcess.Options + [poWaitOnExit];
   try
   try
      AProcess.Execute;
      result:=true;
   finally
      AProcess.Free;
   end;
   except
   end;
end;

type
  TEXECUTE=class(TStatement)
     exp1:TPrincipal;
     params:TListCollection;
     opWaitFor:boolean;
     ChainSt:boolean;

    constructor create(prev,eld:TStatement; opWaitFor0:boolean);
    //procedure exec;override;
    destructor destroy;override;
    function Code:ansistring;override;
  end;


constructor TEXECUTE.create(prev,eld:TStatement; opWaitFor0:boolean);
begin
    inherited create(prev,eld);
    opWaitFor:=opWaitFor0;
    if token='NOWAIT' then
                      begin opWaitFor:=false; gettoken end;
    exp1:=SExpression;
    params:=TListCollection.create;
    if token='WITH' then
       begin
          gettoken;
          check('(',IDH_CHAIN);
          repeat
             params.insert(article);
          until test(',')=false;
          check(')',IDH_CHAIN);
       end;
end;

destructor TEXECUTE.destroy;
begin
   exp1.free;
   params.free;
   inherited destroy;
end;
(*
procedure TEXECUTE.exec;
var
   s1,s2,s:AnsiString;
   i:integer;
   ToChain:boolean;
begin
   ToChain:=Chainst;
   s1:=exp1.evalS;
   s2:='';
   if not FileExists(s1) and (ExtractFileExt(s1)='') then
                  s1:=s1 + BASExt;
   if not FileExists(s1)  then
      begin
        s:=ExtractFilePath(Application.ExeName)+s1;
        if FileExists(s) then
           s1:=s
        else
           s1:=FileSearch(s1,GetEnvironmentVariable('PATH'))
           ;
      end;
   if (s1<>'') and FileExists(s1) then
        begin
            if (ExtractFileExt(s1)=BASExt) then
               begin
                   s2:=s1;
                   s1:=Application.ExeName;
               end
          else
             ToChain:=false;
            i:=0;
         if ToChain then
            begin
               ChainFile:=s2;
               with params do
                 while i<count do
                   begin
                     ChainParams.Add(TPrincipal(items[i]).str);
                     inc(i)
                   end;
            end
          else
            begin
              if s2<>'' then
                 s2:=AnsiQuotedStr(s2,'"')+' ';
              with params do
                while i<count do
                  begin
                     s2:=s2 + TPrincipal(items[i]).str2 +' ' ;
                     inc(i)
                  end;
              s2:=TrimRight(s2);
              if ShellExec(PChar(s1),PChar(s2),opWaitFor) then
              else
                 setexception(10005);
            end;
      end
   else
      setexception(10005);
end;
*)
function EXECUTEst(prev,eld:TStatement):TStatement;
begin
    EXECUTEst:=TEXECUTE.CREATE(prev,eld, true);
end;

type
    TCHAIN=class(TEXECUTE)
      constructor create(prev,eld:TStatement);
      //procedure exec;override;
    end;

function CHAINst(prev,eld:TStatement):TStatement;
begin
    CHAINst:=TCHAIN.CREATE(prev,eld);
end;

constructor TCHAIN.create(prev,eld:TStatement);
begin
   inherited create(prev,eld,false);
   Chainst:=true;
end;
(*
procedure TCHAIN.exec;
begin
   inherited exec ;
   raise EStop.create;
end;
*)
function TExecute.Code:ansistring;
var
  i:integer;
  s2:string;
begin
  s2:='';
  with  params do
  for i:=0 to Count-1 do
    begin
       if i>0 then s2:=s2+',';
       s2:=s2+TPrincipal(items[i]).code
    end;
  result:='ShellExec('+exp1.code+',['+s2+']'+','+TruthLiteral(opWaitfor) +');';
  if chainst then
    result:=result+'raise ESTOP.create;';
end;

type
  TPlay=Class(TExecute)
    function code:ansistring;override;
  end;

  function TPlay.code:ansistring;
  begin
     result:='Play(' + exp1.code + ',' +  TruthLiteral(opWaitfor) +');';
  end;

function PLAYst(prev,eld:TStatement):TStatement;far;
begin
    PLAYst:=TPlay.CREATE(prev,eld,true);
end;


{*********}
{PLAYSOUND}
{*********}
{$IFDEF WINDOWS}
type
  TPlaySound=class(TStatement)
     exp1:TPrincipal;
     Async:boolean;
    constructor create(prev,eld:TStatement);
    destructor destroy;override;
    function Code:ansistring;override;
  end;

constructor TPlaySound.create(prev,eld:TStatement);
begin
  inherited create(prev, eld);
  exp1:=SExpression;
  if test(',') then
     begin
        CheckToken('ASYNC',IDH_EXTENSION_MS);
        Async:=true
     end;
end;

destructor TPlaySound.destroy;
begin
   exp1.Free;
   inherited destroy;
end;


function TPlaySound.Code:ansistring;
begin
   result:='PlaySound('+ exp1.code +',' +TruthLiteral(async) +');'
end;

function PLAYSOUNDst(prev,eld:TStatement):TStatement;far;
begin
    PLAYSoundst:=TPLAYSOUND.CREATE(prev,eld);
end;
{$ENDIF}

{*************}
{registeration}
{*************}

procedure statementTableinit;
begin
   StatementTableInitImperative('CHAIN',CHAINst);
   StatementTableInitImperative('EXECUTE',EXECUTEst);
{$IFDEF WINDOWS}
   StatementTableInitImperative('PLAY',PLAYst);
   StatementTableInitImperative('PLAYSOUND',PLAYSOUNDst);
   //StatementTableInitImperative('ASSOC',ASSOCPRINTst);
{$ENDIF}
end;

procedure functiontableInit;
begin
end;


begin
   tableInitProcs.accept(statementTableinit);
   tableInitProcs.accept(FunctionTableInit);
end.