unit ULScriptu;
{ Descendant of IfPasScript for use in CHROMuLAN. Sample scripts are at the
  end of this file. }
{
  (C) 2000 - 2001 Jindrich Jindrich, Pavel Pisa, PiKRON Ltd.

  Originators of the CHROMuLAN project:

  Jindrich Jindrich - http://www.jindrich.com
                      http://orgchem.natur.cuni.cz/Chromulan
                      software developer, project coordinator
  Pavel Pisa        - http://cmp.felk.cvut.cz/~pisa
                      embeded software developer
  PiKRON Ltd.       - http://www.pikron.com
                      project initiator, sponsor, instrument developer

  The CHROMuLAN project is distributed under the GNU General Public Licence.
  See file COPYING for details.

  Originators reserve the right to use and publish sources
  under different conditions too. If third party contributors
  do not accept this condition, they can delete this statement
  and only GNU license will apply.
}
{
  used Chromulan specific scripts:
  data\scripts\devset.ifs
  data\scripts\ShowState.ifs
}
interface
uses
  SysUtils, Classes, {v0.47}Windows, Graphics, Controls, Forms, Dialogs,
  StdCtrls, TypInfo,
  ifspas, ifs_var, ifs_utl, ifs_obj,

  PropUtl, ExeLogu, ULObjUsru, ULObju,

  UlanGlob, ULScriptType;

const
  EEmptyCommand = 100;
  ELoadFromFileFailed = 101;
type
  TLogProc = procedure(s: string);

  TULScript = class(TCs2PascalScript)
  private
    {FLogMemo: TMemo;}
    FLogProc: TLogProc;
    FUsr: TObject;{can be TULObjUsr, TPersistent, ..., the user of the script }
    FAborted: boolean;
    {FScriptPath: string;}
    {FFileName: string;}
    FCommandLine: string;
    function GetScriptsDirList: string;
    {EXPORT}
    function GetParamCount: integer;
    function GetParamStr(i:integer): string;
    {/EXPORT}
    function GetNextParam(var ACommandLine: string; var AParam: string): boolean;
    procedure RegisterMethods;
    {v0.50}
    function ULObjFindPropInfo(const AObjPath: string; const APropName: string; var AObject: TObject; var APropInfo: PPropInfo): boolean;
    {/v0.50}
    {v0.53}
    function DevSetStrX(const ADeviceAlias: string; const ADeviceProp: string; const AValue: string; InUserUnits: boolean): boolean;
      { set value to device property in internal/user units }
    function DevGetStrX(const ADeviceAlias: string; const ADeviceProp: string; InUserUnits: boolean): string;
      { get value of device property in internal/user units }
    {/v0.53}
    function GetErrorMsg: string;
  public
    constructor Create(id: Pointer; AUsr: TObject);reintroduce;
    procedure Abort;
    {EXPORT}
    function ObjSetStr(const AObjPath: string; const APropName: string; const AValue: string): boolean;
    function ObjGetStr(const AObjPath: string; const APropName: string): string;
    {/EXPORT}
    {v0.50}
    function FindChannel(var AChannel: TObject): boolean;
    function FindProcessor(var AProcessor: TObject): boolean;
    {v0.51pi}
    function FindSeqPrg(var ASeqPrg: TObject): boolean;
    {/v0.51pi}


    {EXPORT}
    function DevSetStr(const ADeviceAlias: string; const ADeviceProp: string; const AValue: string): boolean;
      { set value to device property in internal units }
    function DevGetStr(const ADeviceAlias: string; const ADeviceProp: string): string;
      { get value of device property in internal units }
    function GetDevicePath(const ADeviceAlias: string): string;
    function GetCurPath(const AULObjAliasPath: string): string;
    {v0.51}
    procedure PrgToDev(const ADeviceAlias: string; const AParam: string);
    {seqprgtodevu}
    {/v0.51}
    {v0.53}
    function DevSetStrU(const ADeviceAlias: string; const ADeviceProp: string; const AValue: string): boolean;
      { set value to device property in user units }
    function DevGetStrU(const ADeviceAlias: string; const ADeviceProp: string): string;
      { get value of device property in user units }
    {/v0.53}
    {/EXPORT}
    procedure RunCommandLine(const ACommandLine: string);
    procedure LoadFromCommandLine;
    procedure LoadFromFile(const AFileName: string);
    procedure Log(const Msg: string);
    {/v0.50}

    property LogProc: TLogProc read FLogProc write FLogProc;
    property Usr: TObject read FUsr write FUsr;
    property Aborted: boolean read FAborted;
    property ScriptsDirList: string read GetScriptsDirList;
    property CommandLine: string read FCommandLine write FCommandLine;
    property ErrorMsg: string read GetErrorMsg;
  end;

const
  IFSExt = '.IFS';

function ScriptsDir: string;
{getarraylength}

implementation
{v0.47}
uses
  ULScriptPaintFrm, ifpslib, ifsdfrm, ifsctrlstd, ifpscom, ifpstrans,
  ifpsdll, ifpsdelphi {v0.50}, ULDPType, Channelsu, ULIType, ULIObju,
  SeqPrgu, Processoru{/v0.50}{v0.51}, SeqPrgToDevu{/v0.51};
{/v0.47}

const
  FScriptsDir: string = '';

function ScriptsDir: string;
begin
  if FScriptsDir = '' then
    Result := DataDir + 'Scripts\'
  else
    Result := FScriptsDir;
end;

{v0.47}
function OnRunLine(id: Pointer; Sender: TIfPasScript; Position: Longint): TCs2Error;
begin
  Application.ProcessMessages;
  if (Sender is TULScript) and TULScript(Sender).Aborted{ULScriptForm.Tag = 2} then
    Result := EExitCommand
  else
    Result := Sender.ErrorCode;
end;

function RegProc(Sender: TIfPasScript; ScriptID: Pointer; proc: PProcedure; Params: PVariableManager; res: PIfVariant): TIfPasScriptError;
begin
  if proc^.Name = 'WRITELN' then begin
    if Sender is TULScript then with Sender as TULScript do begin
      {v0.50}
      Log(GetString(Vm_Get(Params, 0)));
      {/v0.50
      if Assigned(FLogProc) then
        FLogProc();}
    end;
  end else if proc^.Name = 'READLN' then begin
    GetVarLink(Vm_Get(Params, 0))^.Cv_Str := InputBox('Demo', 'Readln:', '');
  end else if proc^.Name = 'RANDOM' then begin
    SetInteger(res, random(GetInteger(Vm_Get(Params, 0))));
  end else if proc^.Name = 'PARAMCOUNT' then begin
    if Sender is TULScript then with Sender as TULScript do begin
      SetInteger(res, GetParamCount);
    end else begin
      SetInteger(res, 0);
    end;
  end else if proc^.Name = 'PARAMSTR' then begin
    if Sender is TULScript then with Sender as TULScript do begin
      SetString(res, GetParamStr(GetInteger(Vm_Get(Params, 0))));
    end else begin
      SetString(res ,'');
    end;
  end{v0.53} else if proc^.Name = 'STRTOFLOAT' then begin
    SetReal(res, StrToFloat(GetString(Vm_Get(Params, 0))));
  end
  {/v0.53};
  Result := ENoError;
end;

function PaintRegProc(Sender: TIfPasScript; ScriptID: Pointer; proc: PProcedure; Params: PVariableManager; res: PIfVariant): TIfPasScriptError;
var
  I: Integer;
  r: TRect;
begin
  if proc^.Name = 'SHOWPAINTWINDOW' then begin
    PaintForm.ClientWidth := GetInteger(GetVarLink(Vm_Get(Params, 0)));
    PaintForm.ClientHeight := GetInteger(GetVarLink(Vm_Get(Params, 1)));
    PaintForm.Bitmap.Width := PaintForm.ClientWidth;
    PaintForm.Bitmap.Height := PaintForm.ClientHeight;
    PaintForm.Show;
    PaintForm.DoUpdate;
  end else if proc^.Name = 'HIDEPAINTWINDOW' then
    PaintForm.Hide
  else if proc^.Name = 'UPDATE' then begin
    PaintForm.DoUpdate;
    Application.ProcessMessages;
  end else if proc^.Name = 'CLEAR' then begin
    PaintForm.Bitmap.Canvas.Brush.Style := bsSolid;
    PaintForm.Bitmap.Canvas.Brush.Color := GetInteger(GetVarLink(Vm_Get(Params, 0)));
    PaintForm.Bitmap.Canvas.FillRect(Rect(0, 0, PaintForm.ClientWidth, PaintForm.ClientHeight));
  end else if proc^.Name = 'LINE' then begin
    PaintForm.Bitmap.Canvas.Pen.Color := GetInteger(GetVarLink(Vm_Get(Params, 4)));
    PaintForm.Bitmap.Canvas.MoveTo(GetInteger(GetVarLink(Vm_Get(Params, 0))), GetInteger(GetVarLink(Vm_Get(Params, 1))));
    PaintForm.Bitmap.Canvas.LineTo(GetInteger(GetVarLink(Vm_Get(Params, 2))), GetInteger(GetVarLink(Vm_Get(Params, 3))));
  end else if proc^.Name = 'CIRCLE' then begin
    PaintForm.Bitmap.Canvas.Pen.Color := GetInteger(GetVarLink(Vm_Get(Params, 3)));
    PaintForm.Bitmap.Canvas.Brush.Style := bsClear;
    I := GetInteger(GetVarLink(Vm_Get(Params, 2)));
    PaintForm.Bitmap.Canvas.Ellipse(GetInteger(GetVarLink(Vm_Get(Params, 0))) - I, GetInteger(GetVarLink(Vm_Get(Params, 1))) - I, GetInteger(GetVarLink(Vm_Get(Params, 0))) + I, GetInteger(GetVarLink(Vm_Get(Params, 1))) + I);
    ;
  end else if proc^.Name = 'RECTANGLE' then begin
    PaintForm.Bitmap.Canvas.Pen.Color := GetInteger(GetVarLink(Vm_Get(Params, 4)));
    PaintForm.Bitmap.Canvas.Rectangle(GetInteger(GetVarLink(Vm_Get(Params, 0))), GetInteger(GetVarLink(Vm_Get(Params, 1))), GetInteger(GetVarLink(Vm_Get(Params, 2))), GetInteger(GetVarLink(Vm_Get(Params, 3))));
  end else if proc^.Name = 'FILLEDRECTANGLE' then begin
    PaintForm.Bitmap.Canvas.Brush.Style := bsSolid;
    PaintForm.Bitmap.Canvas.Brush.Color := GetInteger(GetVarLink(Vm_Get(Params, 4)));
    r := Rect(GetInteger(GetVarLink(Vm_Get(Params, 0))), GetInteger(GetVarLink(Vm_Get(Params, 1))), GetInteger(GetVarLink(Vm_Get(Params, 2))), GetInteger(GetVarLink(Vm_Get(Params, 3))));
    PaintForm.Bitmap.Canvas.FillRect(r);
  end;
  Result := ENoError;
end;

function ImportTest(S1: string; s2: Longint; s3: Byte; s4: word; var s5: string): string;
begin
  Result := s1 + ' ' + IntToStr(s2) + ' ' + IntToStr(s3) + ' ' + IntToStr(s4) + ' - OK!';
  S5 := result + ' - OK2!';
end;

function OnUses(id: Pointer; Sender: TIfPasScript; Name: string): TCs2Error;
var
  f: TIFPasScript;
  n: TFileStream;
  s: string;
  {v0.47}
  fn: string;
  {/v0.47}
begin
  if Name = 'SYSTEM' then begin
    RegisterStdLib(Sender, False);
    RegisterTIfStringList(Sender);
    RegisterComLibrary(Sender);
    RegisterTransLibrary(Sender);
    RegisterFormsLibrary(Sender);
    RegisterStdControlsLibrary(Sender);
    RegisterDllCallLibrary(Sender);
    RegisterDelphiFunction(Sender, 'function ImportTest(S1:string;s2:Longint;s3:Byte;s4:Word;var s5:string):string;', @importTest);
    Sender.AddFunction(@RegProc, 'procedure Writeln(s: string)', nil);
    Sender.AddFunction(@RegProc, 'procedure Readln(var s: string)', nil);
    Sender.AddFunction(@RegProc, 'function Random(I: Longint): Longint', nil);
    {v0.47}
    Sender.AddFunction(@RegProc, 'function ParamCount: integer', nil);
    Sender.AddFunction(@RegProc, 'function ParamStr(i: integer): string', nil);
    if Sender is TULScript then with Sender as TULScript do
      RegisterMethods;
    {/v0.47}
    {v0.53}
    Sender.AddFunction(@RegProc, 'function StrToFloat(s: string): extended', nil);
    {/v0.53}
    Result := ENoError;
  end else if Name = 'GRAPH' then begin
    Sender.AddFunction(@PaintRegProc, 'procedure ShowPaintWindow(x,y : integer)', nil);
    Sender.AddFunction(@PaintRegProc, 'procedure Clear(Color: Integer);', nil);
    Sender.AddFunction(@PaintRegProc, 'procedure Update;', nil);
    Sender.AddFunction(@PaintRegProc, 'procedure Line(x1,y1,x2,y2,color: Integer);', nil);
    Sender.AddFunction(@PaintRegProc, 'procedure Circle(x,y,r,color: Integer);', nil);
    Sender.AddFunction(@PaintRegProc, 'procedure Rectangle(x1,y1,x2,y2,color: Integer);', nil);
    Sender.AddFunction(@PaintRegProc, 'procedure FilledRectangle(x1,y1,x2,y2,color: Integer);', nil);
    Sender.AddFunction(@PaintRegProc, 'procedure HidePaintWindow;', nil);
    Result := ENoError;
  end else
  begin
    F := TIFPasScript.Create(nil);
    try
      if Sender is TULScript then with Sender as TULScript do begin
        fn := FileSearch(ScriptsDirList, Name + IFSExt);
      end else begin
        fn := Name + IFSExt;
      end;
      n := TFileStream.Create({v0.47}fn{/v0.47 Name+ IFSExt}, FMOpenRead or FMShareDenyWrite);
      SetLength(s, n.Size);
      n.Read(s[1], Length(S));
      n.Free;
    except
      Result := EUnitNotFound;
      exit;
    end;
    f.OnUses := ULScriptu.OnUses;
    f.SetText(s);
    if f.ErrorCode <> ENoError then
    begin
      Sender.RunError2(f, f.ErrorCode, f.ErrorString);
      f.Free;
      Result := EUnitNotFound;
    end else
    begin
      if not Sender.Attach(F) then
      begin
        f.Free;
        Result := ECustomError;
      end else
        Result := ENoError;
    end;
  end;
end;
{/v0.47}

constructor TULScript.Create(id: Pointer; AUsr: TObject);
begin
  inherited Create(id);
  OnRunLine := ULScriptu.OnRunLine;
  OnUses := ULScriptu.OnUses;
  MaxBeginNesting := 1000;
  FUsr := AUsr;
end;

procedure TULScript.Abort;
begin
  FAborted := true;
end;

function TULScript.GetScriptsDirList: string;
begin
  Result := ScriptsDir;
end;

procedure StripQuotes(var AttrValue: string);{from attrib}
begin
  if (AttrValue <> '') and (AttrValue[length(AttrValue)] = '"') then
    SetLength(AttrValue, length(AttrValue) - 1);
  if (AttrValue <> '') and (AttrValue[1] = '"') then begin
    AttrValue := copy(AttrValue, 2, length(AttrValue));
  end;
end;

function TULScript.GetNextParam(var ACommandLine: string; var AParam: string): boolean;
var
  p: integer;
{  t: string;}
  isInQuotes:boolean;
begin
  Result := false;
  AParam := '';
  ACommandLine := trim(ACommandLine);
  if ACommandLine = '' then
    exit;
  isInQuotes := false;
  p := 1;
  while (p <= length(ACommandLine)) do begin
    if (ACommandLine[p] = ' ') and (not isInQuotes) then
      break;
    if ACommandLine[p] = '"' then
      isInQuotes := not isInQuotes;
    inc(p);
  end;
  AParam := copy(ACommandLine, 1, p - 1);
  ACommandLine := copy(ACommandLine, p + 1, length(CommandLine));
  StripQuotes(AParam);
  Result := AParam <> '';
end;

function TULScript.GetParamCount: integer;
var
  s: string;
  p: string;
begin
  Result := 0;
  s := CommandLine;
  while GetNextParam(s, p) do inc(Result);
  if Result > 0 then
    Dec(Result);
end;

function TULScript.GetParamStr(i:integer): string;
var
  j: integer;
  s: string;
  p: string;
begin
  Result := '';
  s := CommandLine;
  j := 0;
  while GetNextParam(s, p) do begin
    if j = i then begin
      Result := p;
      exit;
    end;
    inc(j);
  end;
end;


function RegMethodsProc(Sender: TULScript{TIfPasScript}; ScriptID: Pointer; proc: PProcedure; Params: PVariableManager; res: PIfVariant): TIfPasScriptError;
begin
  if proc^.Name = 'OBJSETSTR' then begin
    SetBoolean(res, Sender.ObjSetStr(
       GetString(Vm_Get(Params, 0)),
       GetString(Vm_Get(Params, 1)),
       GetString(Vm_Get(Params, 2))
     ));
  end else if proc^.Name = 'OBJGETSTR' then begin
    SetString(res, Sender.ObjGetStr
      (
        GetString(Vm_Get(Params, 0)),
        GetString(Vm_Get(Params, 1))
      )
    );
  end;
  {v0.50}
  if proc^.Name = 'DEVSETSTR' then begin
    SetBoolean(res, Sender.DevSetStr(
       GetString(Vm_Get(Params, 0)),
       GetString(Vm_Get(Params, 1)),
       GetString(Vm_Get(Params, 2))
     ));
  end else if proc^.Name = 'DEVGETSTR' then begin
    SetString(res, Sender.DevGetStr
      (
        GetString(Vm_Get(Params, 0)),
        GetString(Vm_Get(Params, 1))
      )
    );
  end else if proc^.Name = 'GETCURPATH' then begin
    SetString(res, Sender.GetCurPath(
      GetString(Vm_Get(Params, 0))
    ));
  end else if proc^.Name = 'GETDEVICEPATH' then begin
    SetString(res, Sender.GetDevicePath(
      GetString(Vm_Get(Params, 0))
    ));
  end {v0.51} else if proc^.Name = 'PRGTODEV' then begin
    Sender.PrgToDev(
      GetString(Vm_Get(Params, 0)),
      GetString(Vm_Get(Params, 1))
    );
  end{/v0.51}
  {v0.53}
  else if proc^.Name = 'DEVSETSTRU' then begin
    SetBoolean(res, Sender.DevSetStrU(
       GetString(Vm_Get(Params, 0)),
       GetString(Vm_Get(Params, 1)),
       GetString(Vm_Get(Params, 2))
     ));
  end else if proc^.Name = 'DEVGETSTRU' then begin
    SetString(res, Sender.DevGetStrU
      (
        GetString(Vm_Get(Params, 0)),
        GetString(Vm_Get(Params, 1))
      )
    );
  end
  {/v0.53};
  {/v0.50}
  Result := ENoError;
end;

procedure TULScript.RegisterMethods;
begin
  AddFunction(@RegMethodsProc, 'function ObjSetStr(AObjPath: string; APropName: string; AValue: string): boolean', nil);
  AddFunction(@RegMethodsProc, 'function ObjGetStr(AObjPath: string; APropName: string): string', nil);
  {v0.50}
  AddFunction(@RegMethodsProc, 'function DevSetStr(ADeviceAlias: string; ADeviceProp: string; AValue: string): boolean', nil);
  AddFunction(@RegMethodsProc, 'function DevGetStr(ADeviceAlias: string; ADeviceProp: string): string', nil);
  AddFunction(@RegMethodsProc, 'function GetCurPath(AObjAliasPath: string): string', nil);
  AddFunction(@RegMethodsProc, 'function GetDevicePath(ADeviceAlias: string): string', nil);
  {/v0.50}
  {v0.51}
  AddFunction(@RegMethodsProc, 'procedure PrgToDev(ADeviceAlias: string; AParam: string)', nil);
  {/v0.51}
  {v0.53}
  AddFunction(@RegMethodsProc, 'function DevSetStrU(ADeviceAlias: string; ADeviceProp: string; AValue: string): boolean', nil);
  AddFunction(@RegMethodsProc, 'function DevGetStrU(ADeviceAlias: string; ADeviceProp: string): string', nil);
  {/v0.53}

end;



function {v0.50}TULScript.{/v0.50}ULObjFindPropInfo(const AObjPath: string; const APropName: string; var AObject: TObject; var APropInfo: PPropInfo): boolean;
var
  o: TULObj;
  f: TULObjField;
  ou: TObject;
begin
  Result := false;
  AObject := nil;
  APropInfo := nil;
  if not ULFKeeper.FindByULObjPath(AObjPath, 0, o) then begin
    {v0.50}
    Log('Obj with path ' + AObjPath + ' not found.');
    {/v0.50}
    exit;
  end;
  if o <> nil then begin
    if not o.HasField(APropName, f) then begin
      if not o.HasUsrWithProp(APropName, ou, APropInfo) then
      begin
        Log('Property with name ' + APropName + ' not found in object ' + AObjPath + ' or its users.');
        exit;
      end;
      AObject := ou;
      Result := true;
    end else begin
      AObject := o;
      APropInfo := f.FldDesc.PropInfo;
      Result := true;
    end;
  end;
end;


function TULScript.ObjSetStr(const AObjPath: string; const APropName: string; const AValue: string): boolean;
var
  o: TObject;
  pi: PPropInfo;
begin
  if ULObjFindPropInfo(AObjPath, APropName, o, pi) then begin
    Result := ClassSetPropStr(o, pi, AValue) > 0;{proputl}
    if not Result then begin
      Log('Failed to SetPropStr to ' + AObjPath + ' ' + APropName + ' ' + AValue);
    end;
  end else begin
    Result := false;
  end;
end;
{ulobjctrl}


function TULScript.ObjGetStr(const AObjPath: string; const APropName: string): string;
var
  o: TObject;
  pi: PPropInfo;
begin
  Result := '';
  if ULObjFindPropInfo(AObjPath, APropName, o, pi) then
    Result := ClassGetPropStr(o, pi);
end;

{v0.50}
function TULScript.FindProcessor(var AProcessor: TObject): boolean;
begin
  Result := false;
  if FUsr is TProcessor then begin
    AProcessor := TProcessor(FUsr);
    Result := true;
  end;
end;

function TULScript.FindChannel(var AChannel: TObject): boolean;
var o: TULObj;
begin
  Result := false;
  if FUsr is TChannel then begin
    AChannel := TChannel(FUsr);
    Result := true;
  end else if FUsr is TSeqPrg then begin
    o := TSeqPrg(FUsr).Obj;
    o := TULObj(o.Owner);
    {v0.51pi}
    if o=nil then
    begin
      Log('TULScript.FindChannel no SeqPrg owner');
      exit;
    end;
    {/v0.51pi}
    if o.RecID = ULIID then begin
      AChannel := Channels.FindChannel(TULIObj(o).ChannelName);
      Result := AChannel <> nil;
    end;
  end else if FUsr is TProcessor then begin
    AChannel := TProcessor(FUsr).Channel;
    Result := AChannel <> nil;
  end;
  if not Result then
    Log('No active channel found');
end;

{v0.51pi}
function TULScript.FindSeqPrg(var ASeqPrg: TObject): boolean;
begin
  Result := false;
  if FUsr is TSeqPrg then begin
    ASeqPrg := TSeqPrg(FUsr);
    Result := true;
  end;
  if not Result then
    Log('No sequence program found');
end;
{/v0.51pi}

{/v0.53}
function TULScript.DevSetStrX(const ADeviceAlias: string;
  const ADeviceProp: string; const AValue: string; InUserUnits:boolean): boolean;
var
  o: TObject;
  pi: PPropInfo;
  p: string;
  c: TObject;
begin
  Result := false;
  if FindChannel(c) then with c as TChannel do begin
    if DeviceAliasToULObjPath(ADeviceAlias, p) then begin
      if ULObjFindPropInfo(p + '.' + ADeviceProp, pnValueInPC, o, pi) then begin
        if not InUserUnits then begin
          if ClassSetPropStr(o, pi, AValue) > 0 then begin
            Result := true;
          end else begin
            Log('DeviceSetStr failed to ClassSetPropStr ' + ADeviceAlias + ' '+
              ADeviceProp + ' ' + AValue);
          end;
        end else begin
          if o is TULObj then begin
            with o as TULObj do begin
              FindField(pnValueInPC).AsUsrString := AValue;{ulobju}
            end;
          end else begin
            Log('DevSetStrU - object is not ULObj');
          end;
        end;
      end else begin
        Log('ULObjPropInfo not found: ' + p + '.' + ADeviceProp + ',' + pnValueInPC);
      end;
    end else begin
      Log('DeviceAlias not found: ' + ADeviceAlias);
    end;
  end;
end;

function TULScript.DevGetStrX(const ADeviceAlias: string;
  const ADeviceProp: string; InUserUnits: boolean): string;
var
  o: TObject;
  pi: PPropInfo;
  p: string;
  c: TObject;
begin
  Result := '';
  if FindChannel(c) then with c as TChannel do begin
    if DeviceAliasToULObjPath(ADeviceAlias, p) then begin
      if ULObjFindPropInfo(p + '.' + ADeviceProp, pnValueInPC, o, pi) then begin
        if not InUserUnits then begin
          Result := ClassGetPropStr(o, pi);
        end else begin
          if o is TULObj then with o as TULObj do begin
            Result := FindField(pnValueInPC).AsUsrString;
          end else begin
            Log('DevGetStrU - object is not ULObj');
          end;
        end;
      end else begin
        Log('DevGetStr - ULObjPropInfo not found: ' + p + '.' + ADeviceProp + ',' + pnValueInPC);
      end;
    end else begin
      Log('DeviceAlias not found: ' + ADeviceAlias);
    end;
  end;
end;

function TULScript.DevSetStrU(const ADeviceAlias: string;
  const ADeviceProp: string; const AValue: string): boolean;
  { set value to device property in user units }
begin
  Result := DevSetStrX(ADeviceAlias, ADeviceProp, AValue, true);
end;

function TULScript.DevGetStrU(const ADeviceAlias:
  string; const ADeviceProp: string): string;
  { get value of device property in user units }
begin
  Result := DevGetStrX(ADeviceAlias, ADeviceProp, true);
end;

function TULScript.DevSetStr(const ADeviceAlias: string;
  const ADeviceProp: string; const AValue: string): boolean;
  { set value to device property in internal units }
begin
  Result := DevSetStrX(ADeviceAlias, ADeviceProp, AValue, false);
end;

function TULScript.DevGetStr(const ADeviceAlias: string;
  const ADeviceProp: string): string;
  { get value of device property in internal units }
begin
  Result := DevGetStrX(ADeviceAlias, ADeviceProp, false);
end;

{/v0.53
function TULScript.DevSetStr(const ADeviceAlias: string;
  const ADeviceProp: string; const AValue: string): boolean;
var
  o: TObject;
  pi: PPropInfo;
  p: string;
  c: TObject;
begin
  Result := false;
  if FindChannel(c) then with c as TChannel do begin
    if DeviceAliasToULObjPath(ADeviceAlias, p) then begin
      if ULObjFindPropInfo(p + '.' + ADeviceProp, pnValueInPC, o, pi) then begin
        if ClassSetPropStr(o, pi, AValue) > 0 then begin
          Result := true;
        end else begin
          Log('DeviceSetStr failed to ClassSetPropStr ' + ADeviceAlias + ' '+
            ADeviceProp + ' ' + AValue);
        end;
      end else begin
        Log('ULObjPropInfo not found: ' + p + '.' + ADeviceProp + ',' + pnValueInPC);
      end;
    end else begin
      Log('DeviceAlias not found: ' + ADeviceAlias);
    end;
  end;
end;

function TULScript.DevGetStr(const ADeviceAlias: string; const ADeviceProp: string): string;
var
  o: TObject;
  pi: PPropInfo;
  p: string;
  c: TObject;
begin
  Result := '';
  if FindChannel(c) then with c as TChannel do begin
    if DeviceAliasToULObjPath(ADeviceAlias, p) then begin
      if ULObjFindPropInfo(p + '.' + ADeviceProp, pnValueInPC, o, pi) then
        Result := ClassGetPropStr(o, pi);
    end else begin
      Log('DeviceAlias not found: ' + ADeviceAlias);
    end;
  end;
end;
}


function TULScript.GetDevicePath(const ADeviceAlias: string): string;
var
  p: string;
  c: TChannel;
begin
  Result := '';
  if FindChannel(TObject(c)) then with c as TChannel do begin
    if DeviceAliasToULObjPath(ADeviceAlias, p) then
      Result := p
    else begin
      Log('DeviceAlias not found: ' + ADeviceAlias);
    end;
  end;
end;

function TULScript.GetCurPath(const AULObjAliasPath: string): string;
var
  r: string;

  procedure GetActiveChannelPath;
  var
    c: TChannel;
  begin
    if FindChannel(TObject(c)) then
      r := c.ULN.ULObjPath;
  end;

  procedure GetActiveSequencePath;
  var
    p: TProcessor;
  begin
    if FindProcessor(TObject(p)) and (p.Sequence <> nil) then
      r := p.Sequence.ULSQ.ULObjPath;
  end;

  procedure GetActiveSampleHeadPath;
  var
    p: TProcessor;
  begin
    if FindProcessor(TObject(p)) and (p.CurSample <> nil) then
      r := p.CurSample.ULSR.ULObjPath;
  end;

  procedure GetActiveSampleDataPath;
  var
    p: TProcessor;
  begin
    if FindProcessor(TObject(p)) and (p.CurData <> nil) then
      r := p.CurData.ULA.ULObjPath;
  end;

  procedure GetNextSampleHeadPath;
  var
    p: TProcessor;
  begin
    if FindProcessor(TObject(p)) and (p.NextSample <> nil) then
      r := p.NextSample.ULSR.ULObjPath;
  end;

  procedure GetActiveProgramPath;
  var
    p: TProcessor;
  begin
    if FindProcessor(TObject(p)) and (p.CurPrg is TSeqPrg) then
      r := TSeqPrg(p.CurPrg).USP.ULObjPath;
  end;

begin
  r := '';
  if AULObjAliasPath = paActiveChannel then
    GetActiveChannelPath
  else if AULObjAliasPath = paActiveSequence then
    GetActiveSequencePath
  else if AULObjAliasPath = paActiveSampleHead then
    GetActiveSampleHeadPath
  else if AULObjAliasPath = paActiveSampleData then
    GetActiveSampleDataPath
  else if AULObjAliasPath = paNextSampleHead then
    GetNextSampleHeadPath
  else if AULObjAliasPath = paActiveProgram then
    GetActiveProgramPath
  else
    Log('Unknown AULObjAliasPath ' + AULObjAliasPath);
  Result := r;
end;

{v0.51}
procedure TULScript.PrgToDev(const ADeviceAlias: string; const AParam: string);
var
  p: TProcessor;
  {v0.51pi}
  prg: TSeqPrg;
  chan: TChannel;
  {/v0.51pi}
begin
{seqprgtodevu}
  if FindProcessor(TObject(p)) then begin
    SeqPrgToDev(p.CurPrg, p.Channel, ADeviceAlias, AParam)
  {v0.51pi}
  end else if FindChannel(TObject(chan)) and FindSeqPrg(TObject(prg)) then
  begin
    SeqPrgToDev(prg, chan, ADeviceAlias, AParam);
  end;
  {/v0.51pi}
end;
{/v0.51}

procedure TULScript.RunCommandLine(const ACommandLine: string);
begin
  CommandLine := ACommandLine;
  LoadFromCommandLine;
  if ErrorCode = ENoError then begin
    Log('Script is running.');
    RunScript;
    if ErrorCode = ENoError then begin
      Log('Script finished, no errors.');
    end else begin
      Log(ErrorMsg);
    end;
  end;
end;

procedure TULScript.LoadFromCommandLine;
var
  n: string;
  i: integer;
{  fn: string;}
{  l: TStringList;}
begin
  RunError(Self, ENoError);
  n := CommandLine;
  if (n <> '') then begin
    i := pos(' ', n);
    if i > 0 then
      n := copy(n, 1, i - 1);
    LoadFromFile(n);
  end else begin
    RunError(Self, EEmptyCommand);
  end;
end;

procedure TULScript.LoadFromFile(const AFileName: string);
var
  fn: string;
  l: TStringList;
begin
  fn := ChangeFileExt(AFileName, IFSExt);
  if ExtractFilePath(AFileName) = '' then
    fn := FileSearch(fn, ScriptsDirList);
  l := TStringList.Create;
  try
    try
      l.LoadFromFile(fn);
      SetText(l.Text);{tstringlist}
    except
      RunError2(Self, ELoadFromFileFailed, fn);
    end;
  finally
    l.Free;
  end;
end;

procedure TULScript.Log(const msg: string);
begin
  if Assigned(FLogProc) then
    FLogProc(msg);
  ExeLog.Log('ULScript.'+ msg);
end;
{/v0.50}
function TULScript.GetErrorMsg: string;
begin
  Result := 'Error in '+ ErrorModule + '('+IntToStr(ErrorPos)+') '+ErrorToString(ErrorCode, ErrorString);
end;
{/TULScript.}


(*Scripts

CfgGradByFlow.ifs
Program CfgGradByFlow;' + nl +
var s:string;'
function Pump2_addr(alias:string):string;
begin
  Pump2_addr:='';
  if alias='' then alias:='pump2';
  Pump2_addr:=ObjGetStr(GetDevicePath(alias),'AddrStr');
end;

begin
  if paramstr(1)='' then s:='pump'
  else s:=paramstr(1);
  DevSetStr(s, 'GBFSLA',Pump2_addr(paramstr(2)));
  DevSetStr(s, 'GBFMODE','1');
  DevSetStr(s, 'ERRCLR','1');
end.

ColTemp.ifs
program ColTemp;

begin
 if paramstr(2)='' then begin
{  DevSetStr('temper','TEMP1', inttostr(strtoint(paramstr(1),0)*10));}
  DevSetStrU('temper','TEMP1', paramstr(1));
  DevSetStr('temper','TEMP_ON', '1');
 end
 else begin
{  DevSetStr(paramstr(2),'TEMP1', inttostr(strtoint(paramstr(1),0)*10));}
  DevSetStr(paramstr(2),'TEMP1',paramstr(1));
  DevSetStr(paramstr(2),'TEMP_ON', '1');
 end
end.

devset.ifs
program devset;
{ Set new value of device parameter in internal units (shown in sysop mode).

  paramstr(1) - device name
  paramstr(2) - parameter name
  paramstr(3) - new value of the parameter

  See Setup | Devices for list of devices and their parameters.
}

begin
  DevSetStr(paramstr(1), paramstr(2), paramstr(3));
end.

devsetu.ifs
program devsetu;
{ Set new value of device parameter in user units.

  paramstr(1) - device name
  paramstr(2) - parameter name
  paramstr(3) - new value of the parameter

  See Setup | Devices for list of devices and their parameters.
}

uses SysUtils;
begin
  DevSetStrU(paramstr(1), paramstr(2), paramstr(3));
end.

InjectSamp.ifs
Program InjectSamp;

Begin
  DevSetStr('sampler','ASLOAD','1');
End.

LampHigh.ifs
program LampHigh;

begin
 if paramstr(1)='' then  DevSetStr('detector','LAMPC', '2')
 else DevSetStr(paramstr(1), 'LAMPC','2');
end.


LampLow.ifs
program LampLow;

begin
 if paramstr(1)='' then  DevSetStr('detector','LAMPC', '1')
 else DevSetStr(paramstr(1), 'LAMPC','1');
end.

LampOff.ifs
program LampOff;

begin
 if paramstr(1)='' then  DevSetStr('detector','LAMPC', '0')
 else DevSetStr(paramstr(1), 'LAMPC','0');
end.

LampVis.ifs
program LampVis;

begin
 if paramstr(1)='' then  DevSetStr('detector','LAMPC', '16')
 else DevSetStr(paramstr(1), 'LAMPC','16');
end.

LoadSamp.ifs
Program LoadSamp;

function GetChannelName:string;
begin
   GetChannelName:=ObjGetStr(GetCurPath('ActiveChannel'),'ChannelName');
end;

function GetVialNr:string;
var
   ActiveSampleHead:string;
begin
   ActiveSampleHead:=GetCurPath('ActiveSampleHead');
   writeln('ActiveSampleHead = '+ActiveSampleHead);
   GetVialNr:=ObjGetStr(ActiveSampleHead,'VialNr');
end;

var
    VialNr:string;

Begin
    VialNr:=GetVialNr;
    writeln('Active Vial Number ='+VialNr);
    if VialNr<>'' then begin
       if False then begin
          DevSetStr('sampler','PREPSAMP',VialNr);
       end else begin
          DevSetStr('sampler','SAMPNUM',VialNr);
          DevSetStr('sampler','ASLOAD','1');
       end
    end else
      writeln('Error Empty VialNr');
End.

MotorStart.ifs
program MotorStart;

begin
 if paramstr(1)='' then  DevSetStr('pump','START', '1')
 else DevSetStr(paramstr(1), 'START','1');
end.

MotorStop.ifs
program MotorStop;

begin
 if paramstr(1)='' then  DevSetStr('pump','STOP', '1')
 else DevSetStr(paramstr(1), 'STOP','1');
end.

None.ifs
program None;

begin

end.

PrgAndRunLCP.ifs
Program prgtolcp;
Begin
   DevSetStr('pump', 'PRGCLR', '1');
   PrgToDev('pump', 'LCP5020');
   DevSetStr('pump', 'PRGRUN', '1');
End.

PrgPrepLCP.ifs
Program PrgPrepLCP;
Begin
   DevSetStr('pump', 'PRGCLR', '1');
   PrgToDev('pump', 'LCP5020');
   DevSetStr('pump', 'PRGEND', '1');
End.

PrgRunLCP.ifs
Program PrgRunLCP;
Begin
   DevSetStr('pump', 'PRGRUN', '1');
End.

PrgToLCP.ifs
Program prgtolcp;
Begin
   DevSetStr('pump', 'PRGCLR', '1');
   PrgToDev('pump', 'LCP5020');
End.

ShowState.ifs
Program ShowState;

Begin
  writeln('ShowState begin');
  writeln('ActiveChannel=' + GetCurPath('ActiveChannel'));
  writeln('ActiveSequence=' + GetCurPath('ActiveSequence'));
  writeln('ActiveSampleHead=' + GetCurPath('ActiveSampleHead'));
  writeln('ActiveSampleData=' + GetCurPath('ActiveSampleData'));
  writeln('NextSampleHead=' + GetCurPath('NextSampleHead'));
  writeln('ActiveProgram=' + GetCurPath('ActiveProgram'));
  writeln('ShowState end');
End.

test.ifs
program test;
var
  s:string;
  e: extended;
begin
  writeln(FloatToStr(3.0));
  e := StrToFloat('3.456');

  writeln(FloatToStr(e));
  writeln(GetDevicePath('detector'));
{  DevSetStr(paramstr(1), paramstr(2), paramstr(3));}
end.

testalias.ifs
Program testalias;

Begin
   writeln(DevGetStr('sampler', 'STATUS'));
End.

WaitForMark.ifs
Program WaitForMark;
var
  prgPath: string;
Begin
   prgPath := GetCurPath('ActiveProgram');
   if prgPath = '' then begin
      Writeln('No active program');
   end else begin
       Writeln('Active program path=' + prgPath);
       if ObjSetStr(prgPath, 'WaitingFor', 'mark') then begin
          Writeln('Waiting for mark');
       end else begin
           Writeln('Failed to set "mark" WaitFor event to program ' + prgPath);
       end;
   end;
End.

WLen.ifs
program WLEN;

begin
 if paramstr(2)='' then  DevSetStr('detector','WLEN', paramstr(1))
 else DevSetStr(paramstr(2), 'WLEN', paramstr(1));
end.

X1.ifs
program test;
var s: string;
begin
  ObjSetStr('P1.FLOW', 'ValueInPC', paramstr(1));
end.

X2.ifs
Program IFSTest;
var
  i: integer;
  j: integer;
Begin
   i := paramcount;
   writeln(IntToStr(i));
  for j := 0 to i do begin
    writeln('paramstr['+IntToStr(j) +'] = ' + paramstr(j));
  end;
End.

Zero.ifs
program Zero;

begin
 if paramstr(1)='' then  DevSetStr('detector','ZERO', '1')
 else DevSetStr(paramstr(1), 'ZERO','1');
end.

/Scripts*)

end.
