unit ULScriptu;{ Descendant of IfPasScript for use in CHROMuLAN }
{
  (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,
  ifspas, ifs_var, ifs_utl, ifs_obj,
  ULObjUsru, ULObju, TypInfo, PropUtl,
  {/v0.47 ifspas,}
  UlanGlob{v0.50}, ExeLogu, ULScriptType{/v0.50};

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}
  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;
  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
    SeqPrgToDev(p.CurPrg, p.Channel, ADeviceAlias, AParam)
  {v0.51pi}
  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('Error in '+ ErrorModule + '('+IntToStr(ErrorPos)+') '+ErrorToString(ErrorCode, ErrorString));
    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}
{/TULScript.}

end.
