unit VisCheckBox;

interface

uses
  DesignIntf, DesignEditors,
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, stdctrls, uPSComponent, uPSCompiler, uPSRuntime,
  VisControl;

type
  TCanClickEvent = procedure(Sender: TObject; var Can: boolean) of object;

  TVisCheckBox = class(TVisControl)
    procedure PSScriptCompile(Sender: TPSScript);
    procedure PSScriptCompImport(Sender: TObject; x: TPSPascalCompiler);
    procedure PSScriptExecImport(Sender: TObject; se: TPSExec; x: TPSRuntimeClassImporter);
    procedure PSScriptExecute(Sender: TPSScript);
  private
    FCanClickEvent: TCanClickEvent;
    FCheckBox: TCheckBox;
    FAutoUpdateApply: boolean;
    FApplying: boolean;

    FCheckQuery: string;
    FUncheckQuery: string;

  protected
    procedure OnControlMouseUp(Sender: TObject; Button: TMouseButton;
        Shift: TShiftState; X, Y: Integer);

    procedure CheckBoxEnter(Sender: TObject);

    procedure ScriptProcess(ForceExecute: boolean);

    procedure onTagStatusChanged(good: Boolean); override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure Init; override;
    procedure Process; override;
    function IsApplying: boolean;

    procedure setcolors(AFontColor: integer; ABackColor: integer);

    function CompileScript(var Messages: string): boolean; override;
    procedure ExecuteScript; override;

    procedure DoApply;
    procedure DoUpdate;

  published
    property OnCanClick: TCanClickEvent read FCanClickEvent write FCanClickEvent;
    property AutoUpdateApply: boolean read FAutoUpdateApply write FAutoUpdateApply;
    property objCheckBox: TCheckBox read FCheckBox;

    property QueryCheck: string read FCheckQuery write FCheckQuery;
    property QueryUncheck: string read FUncheckQuery write FUncheckQuery;

    property Align;
    property Anchors;
    property Enabled;
    property Visible;
  end;




procedure Register;

implementation
uses
  infodlg,
  uPSR_std,
  uPSC_std,
  uPSR_stdctrls,
  uPSC_stdctrls,
  uPSR_extctrls,
  uPSC_extctrls,
  uPSR_forms,
  uPSC_forms,
  uPSC_graphics,
  uPSC_controls,
  uPSC_classes,
  uPSR_graphics,
  uPSR_controls,
  uPSR_classes,
  uPSR_visscada,
  uPSC_visscada,
  RpVisualGlobal,
  RpVisualUtils,
  TagStorage,
  numbers,
  VisControlScriptEdit,
  hyperstr,
  Users;

var
  PSScript: TPSScript;
  PSScript_refcount: integer;
  PSVisCheckBox: TVisCheckBox;

  tmp_compile_src, tmp_compile_out: string;

procedure Register;
begin
  RegisterComponents('Scada', [TVisCheckBox]);
  RegisterComponentEditor(TVisCheckBox, TVisControlEditor);
end;

{ TVisualDevice }

constructor TVisCheckBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ShowHint := true;

  // Создание метки
  FCheckBox := TCheckBox.Create(Self);
  FCheckBox.Name := 'objCheckBox';
  FCheckBox.Caption := '';
  FCheckBox.Parent := self;
  FCheckBox.Visible := true;
  FCheckBox.SetSubComponent(true);
  FCheckBox.OnMouseUp := OnControlMouseUp;
  FCheckBox.OnEnter := CheckBoxEnter;

  FCheckBox.Anchors := [akLeft, akTop, akRight, akBottom];

  Width := FCheckBox.Width;
  Height := FCheckBox.Height;

  FAutoUpdateApply := true;

  if PSScript = nil then begin
    PSScript := TPSScript.Create(nil);
    PSScript.OnCompile := PSScriptCompile;
    PSScript.OnCompImport := PSScriptCompImport;
    PSScript.OnExecImport := PSScriptExecImport;
    PSScript.OnExecute := PSScriptExecute;
    inc(PSScript_refcount);
  end;

  FCheckBox.OnMouseMove := OnMouseMove;
end;


// INIT
procedure TVisCheckBox.Init;
var
  s, _tags: string;
  i,k: integer;
begin
  inherited init;
  _tags := '';
  TagRoot := trim(TagRoot);
  TagIdRoot := trim(TagIdRoot);
  TagPath := trim(TagPath);

  SetLength(Tags, FTagNames.Count);

  IsConnectionBad := false;
  for i:=0 to FTagNames.Count-1 do begin

    s:=FTagNames[i];

    if length(TagRoot)>0 then begin
      k:=pos(TagIdRoot, s);
      if k>0 then begin
        delete(s, k, length(TagIdRoot));
        insert(TagRoot, s, k);
      end;
    end;

    if length(TagPath)>0 then begin
      s := TagPath + '.' + s;
    end;

    _tags := _tags + s + ' ';
    Tags[i].idx := GetTagIndex(s);
    Tags[i].value := 0;


    if Tags[i].idx < 0 then
      _tags := _tags + s + '- NOT FOUND! ';

    IsConnectionBad := (IsConnectionBad) or (Tags[i].idx < 0);
  end;

  CompileScript(s);
  for i:=0 to length(Tags)-1 do begin
    Tags[i].value := -1;
  end;

  if FHint = '' then FHint := trim(Hint);
  if not(FHint='') then begin
    if debugTagNotFoundHint then
      Hint := FHint + #13 + 'Теги: ' + _tags
    else
      Hint := FHint;
  end;

  FCheckQuery := replaceAllMarkers(FCheckQuery);
  FUncheckQuery := replaceAllMarkers(FUncheckQuery);
  FCheckBox.Caption := replaceAllMarkers(FCheckBox.Caption);

  //  FCheckQuery := ReplaceStr(FCheckQuery, TagIdRoot, TagRoot);
//  FUncheckQuery := ReplaceStr(FUncheckQuery, TagIdRoot, TagRoot);
//
//  FCheckQuery := ReplaceStr(FCheckQuery, HINT_MARKER, hint);
//  FUncheckQuery := ReplaceStr(FUncheckQuery, HINT_MARKER, hint);

end;


// PROCESS HANDLER
procedure TVisCheckBox.Process;
begin
  if FAutoUpdateApply then begin
    FApplying := false;
    ScriptProcess(false);
    ExecuteProcessEvent;
  end;
end;

procedure TVisCheckBox.DoApply;
begin
  FApplying := true;
  ScriptProcess(true);
end;

procedure TVisCheckBox.DoUpdate;
begin
  FApplying := false;
  ScriptProcess(true);
end;

function TVisCheckBox.IsApplying: boolean;
begin
  result := FApplying;
end;

procedure TVisCheckBox.ScriptProcess(ForceExecute: boolean);
var
  fl: boolean;
begin
  IsValueBad := false;
  fl := updateTags();

  if (fl) or (not FExecuteOnTagChange) or (FApplying) or (ForceExecute) then begin

    if FScriptDefEnabled then
    begin
      // Обработчик по умолчанию (вместо скрипта)
      if FApplying then begin
        if objCheckBox.Checked then
          SetTagVal(0, 1)
        else
          SetTagVal(0, 0);
      end else begin
        objCheckBox.Checked := gettagval(0) > 0;
      end;
    end;

    if FScriptEnabled then
      ExecuteScript;
  end;
end;


procedure TVisCheckBox.OnControlMouseUp(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  can: boolean;
begin
  if Assigned(OnCanClick) then begin
    can := true;
    OnCanClick(self, can);
    if not can then begin
      objCheckBox.Checked := not objCheckBox.Checked;
      exit;
    end;
  end;

  if not CheckAccess(PREVILEG_ZAPRET_CHECKBOX, true, true) then exit;

  can := true;
  if (FCheckQuery <> '') and (objCheckBox.Checked) then
    can := showInfoDlg(FCheckQuery, mtConfirmation, [mbYes, mbNo], 0) = mrYes;

  if (FUncheckQuery <> '') and (not objCheckBox.Checked) then
    can := showInfoDlg(FUncheckQuery, mtConfirmation, [mbYes, mbNo], 0) = mrYes;

  if can then begin
    if FAutoUpdateApply then DoApply;
    OnDeviceClick(sender);
  end else
    ScriptProcess(True);
end;

procedure TVisCheckBox.CheckBoxEnter(Sender: TObject);
begin
  if not CheckAccess(PREVILEG_ZAPRET_CHECKBOX, false, true) then
    begin
     (Sender as TCheckBox).Enabled := NOT  (Sender as TCheckBox).Enabled;
     (Sender as TCheckBox).Enabled := NOT  (Sender as TCheckBox).Enabled;
   end;
end;


procedure TVisCheckBox.setcolors(AFontColor: integer; ABackColor: integer);
begin
  objCheckBox.Font.Color := AFontColor;
end;


procedure TVisCheckBox.onTagStatusChanged(good: Boolean);
begin
  if (not FBadColorsEnabled) or (not rvgLogIn) then  exit;
  
  if good then begin
    objCheckBox.Font.Color := FGoodColorFont;
    objCheckBox.Color := FGoodColorBack1;
  end else begin
    putColorGood( objCheckBox.Font.Color, objCheckBox.Color, 0);
    objCheckBox.Font.Color := FBadColorFont;
    objCheckBox.Color := FBadColorBack;
  end;
end;



//==============================================================================
procedure TVisCheckBox.PSScriptCompImport(Sender: TObject; x: TPSPascalCompiler);
begin
  SIRegister_Std(x);
  SIRegister_Classes(x, true);
  SIRegister_Graphics(x, true);
  SIRegister_Controls(x);
  SIRegister_stdctrls(x);
  SIRegister_extctrls(x);
  SIRegister_Forms(x);
  SIRegister_visscada(x);
end;

procedure TVisCheckBox.PSScriptExecImport(Sender: TObject; se: TPSExec;
  x: TPSRuntimeClassImporter);
begin
  RIRegister_Std(x);
  RIRegister_Classes(x, True);
  RIRegister_Graphics(x, True);
  RIRegister_Controls(x);
  RIRegister_stdctrls(x);
  RIRegister_extctrls(x);
  RIRegister_Forms(x);
  RIRegister_visscada(x);
end;

procedure TVisCheckBox.PSScriptCompile(Sender: TPSScript);
begin
  Sender.AddRegisteredPTRVariable('self', 'TVisCheckBox');
end;

procedure TVisCheckBox.PSScriptExecute(Sender: TPSScript);
begin
  Sender.SetPointerToData('self', @PSVisCheckBox, sender.FindNamedType('TVisCheckBox'));
end;

function TVisCheckBox.CompileScript(var Messages: string): boolean;
var
  i: integer;
begin
  if SameText(tmp_compile_src, Script.Text) then begin
    CompiledScript := tmp_compile_out;
    IsCompileScriptOk := true;
  end else begin
    PSVisCheckBox := self;
    PSScript.Script.Text := Script.Text;
    IsCompileScriptOk := PSScript.Compile;

    if IsCompileScriptOk then begin
      PSScript.GetCompiled(CompiledScript);
      tmp_compile_src := Script.Text;
      tmp_compile_out := CompiledScript;
    end;

    Messages := '';
    for i:=0 to PSScript.CompilerMessageCount-1 do
      Messages := Messages + PSScript.CompilerMessages[i].MessageToString + #13#10;
  end;

  if IsCompileScriptOk then
    Messages := Messages + 'Successfully compiled!'#13#10;

  result := true;  
end;

procedure TVisCheckBox.ExecuteScript;
begin
  if IsCompileScriptOk then begin
    PSVisCheckBox := self;
    PSScript.SetCompiled(CompiledScript);
    PSScript.Execute;
  end;
end;



initialization
  PSScript := nil;
  PSScript_refcount := 0;

  tmp_compile_src := '*';
  tmp_compile_out := '';

finalization
  dec(PSScript_refcount);
  if PSScript_refcount = 0 then begin
    PSScript.Free;
    PSScript := nil;
  end;

end.
