jvqforth.pas

East make Tray Icon in delphi

{******************************************************************************}
{* WARNING:  JEDI VCL To CLX Converter generated unit.                        *}
{*           Manual modifications will be lost on next release.               *}
{******************************************************************************}

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html

Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.

The Original Code is: JvForth.PAS, released on 2002-06-15.

The Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]
Portions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.
All Rights Reserved.

Contributor(s): Robert Love [rlove att slcdug dott org].

You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.sourceforge.net

Known Issues:
-----------------------------------------------------------------------------}
// $Id: JvQForth.pas,v 1.17 2004/09/07 23:11:17 asnepvangers Exp $

unit JvQForth;

{$I jvcl.inc}
{$I crossplatform.inc}

interface

uses
  SysUtils, Classes,
  {$IFDEF MSWINDOWS}
  ShellAPI,
  {$ENDIF MSWINDOWS}
  QWindows, QMessages, QForms, QDialogs, QFileCtrls,
  {$IFDEF HAS_UNIT_VARIANTS}
  Variants,
  {$ENDIF HAS_UNIT_VARIANTS}
  JvQXMLTree, JvQComponent, JvQStrings, JvQTypes;

const
  StackMax = 1000;

type
  EJvJanScriptError = class(EJVCLException);

  TToken = (dfoError, dfonop,
    // flow actions
    dfoIf, dfoElse, dfoEndIf, dfoRepeat, dfoUntil,
    // sub routines
    dfosub, dfoEndSub, dfoCall,
    // stack operations
    dfodup, dfodrop, dfoswap,
    // conversion
    dfoCstr,
    // data source object, symbols starting with _
    dfoDSO, dfoSelDir, dfoDSOBase,
    // xmldso starts with ?
    dfoXML,
    // system io
    dfoSystem,
    // internal variables
    dfoIntVar,
    // external variables
    dfoExtVar,
    // direct action
    dfoInteger, dfoFloat, dfoSet, dfoString, dfoBoolean,
    dfoDate,
    // end direct action
    dfoEq, dfoNe, dfoGt, dfoLt, dfoGe, dfoLe, dfoLike, dfoUnlike,
    dfoNot, dfoAnd, dfoXor, dfoOr,
    dfoIn,
    dfoAdd, dfoSubtract, dfoMultiply, dfoDivide, dfoPower,
    dfoAbs,
    // some usefull constants
    dfocrlf,
    // some gonio functions
    dfosin, dfocos, dfopi, dfotan,
    dfoarcsin, dfoarccos, dfoarctan, dfoarctan2,

    dfonegate, dfosqr, dfosqrt,
    dfoleft, dforight,
    // windows api
    dfoshellexecute,
    // date and time
    dfonow, dfotime, dfodatestr, dfotimestr
   );

  TProcVar = procedure of object;

  TOnGetVariable = procedure(Sender: TObject; Symbol: string; var Value: Variant; var Handled: Boolean; var ErrorStr: string) of object;
  TOnSetVariable = procedure(Sender: TObject; Symbol: string; Value: Variant; var Handled: Boolean; var ErrorStr: string) of object;
  TOnGetSystem = procedure(Sender: TObject; Symbol, Prompt: string; var Value: Variant; var Handled: Boolean; var ErrorStr: string) of object;
  TOnSetSystem = procedure(Sender: TObject; Symbol: string; Value: Variant; var Handled: Boolean; var ErrorStr: string) of object;
  TOnInclude = procedure(Sender: TObject; IncludeFile: string; var Value: string; var Handled: Boolean; var ErrorStr: string) of object;

  TJvJanDSO = class(TStringList)
  private
    function InternalGetValue(Index: Integer; const AField: string): string;
    procedure InternalSetValue(Index: Integer; const AField, AValue: string);
  public
    // when a key is not found it will be added
    procedure SetValue(AKey: Variant; const AField, AValue: string);
    function GetValue(AKey: Variant; const AField: string): string;
  end;

  TJvJanDSOList = class(TStringList)
  public
    destructor Destroy; override;
    procedure ClearTables;
    function Table(const AName: string): TJvJanDSO;
  end;

  TJvJanXMLList = class(TStringList)
  public
    destructor Destroy; override;
    procedure ClearXMLS;
    function Xml(const AName: string): TJvXMLTree;
  end;

  TVariantObject = class(TObject)
  private
    FValue: Variant;
    procedure SetValue(const Value: Variant);
  public
    property Value: Variant read FValue write SetValue;
  end;

  TVariantList = class(TStringList)
  public
    destructor Destroy; override;
    procedure ClearObjects;
    procedure SetVariable(const Symbol: string; AValue: Variant);
    function GetVariable(const Symbol: string): Variant;
    function GetObject(const Symbol: string): TVariantObject; reintroduce;
  end;

  TAtom = class(TObject)
  private
    FToken: TToken;
    FSymbol: string;
    FValue: Variant;
    FProc: TProcVar;
    FIsOperand: Boolean;
    procedure SetToken(const Value: TToken);
    procedure SetSymbol(const Value: string);
    procedure SetValue(const Value: Variant);
    procedure SetProc(const Value: TProcVar);
    procedure SetIsOperand(const Value: Boolean);
  public
    property Token: TToken read FToken write SetToken;
    property Proc: TProcVar read FProc write SetProc;
    property Symbol: string read FSymbol write SetSymbol;
    property Value: Variant read FValue write SetValue;
    property IsOperand: Boolean read FIsOperand write SetIsOperand;
  end;

  TAtomList = class(TList)
  public
    destructor Destroy; override;
    procedure ClearObjects;
  end;

  TJvForthScript = class(TJvComponent)
  private
    FScript: string;
    FIncludes: TStringList;
    FInDevice: string;
    FOutDevice: string;
    FSubsList: TStringList;
    FVarsList: TVariantList;
    FDSOList: TJvJanDSOList;
    FXMLList: TJvJanXMLList;
    FXMLSelect: TList;
    FXMLSelectRecord: Integer;
    FDSOBase: string; // root directory for DSO tables
    FAtoms: TAtomList;
    // FRStack if the return stack for loop, sub etc.
    FRStack: array [0..StackMax] of Integer;
    FRSP: Integer;
    FVStack: array [0..StackMax] of Variant;
    FVSP: Integer;
    // ostack: array[0..StackMax] of TToken;
    // osp: Integer;
    FPStack: array [0..StackMax] of TToken;
    FPSP: Integer;
    FPC: Integer;
    FCurrentSymbol: string;
    FCurrentValue: Variant;
    FOnGetVariable: TOnGetVariable;
    FOnSetVariable: TOnSetVariable;
    FScriptTimeOut: Integer;
    FOnGetSystem: TOnGetSystem;
    FOnSetSystem: TOnSetSystem;
    FOnInclude: TOnInclude;
    // procedure ClearAtoms;
    procedure SetScript(const Value: string);
    procedure SetOnGetVariable(const Value: TOnGetVariable);
    procedure SetOnSetVariable(const Value: TOnSetVariable);
    // expresssion procedures

    // constants
    procedure ProcCrLf;
    // date and time
    procedure ProcNow;
    procedure ProcDateStr;
    procedure ProcTimeStr;
    // shell
    procedure ProcShellExecute;
    // xml variables
    procedure ProcXML;
    // data source variables
    procedure ProcDSO;
    procedure ProcSelDir;
    procedure ProcDSOBase;
    // external variables
    procedure ProcExtVar; // general dispatcher
    procedure ProcAssign;
    procedure ProcVariable;

    // internal variables
    procedure ProcIntVar; // general dispatcher
    procedure ProcVarGet;
    procedure ProcVarSet;
    procedure ProcVarInc;
    procedure ProcVarIncIndex;
    procedure ProcVarDec;
    procedure ProcVarDecTestZero;
    procedure ProcVarAdd;
    procedure ProcVarSub;
    procedure ProcVarMul;
    procedure ProcVarDiv;
    procedure ProcVarNeg;
    procedure ProcVarLoad;
    procedure ProcVarSave;
    // system io
    procedure ProcSystem; // general dispatcher
    procedure ProcSysGet;
    procedure ProcSysSet;
    // flow expressions
    procedure ProcIf;
    procedure ProcElse;
    procedure ProcEndif;
    procedure ProcUntil;
    procedure ProcRepeat;
    // end flow expressions

    // sub expressions
    procedure ProcSub;
    procedure ProcEndsub;
    procedure ProcCall;
    // conversion expressions
    procedure ProcCStr;
    procedure ProcNop;
    procedure ProcDup;
    procedure ProcDrop;
    procedure ProcSwap;
    procedure ProcInteger;
    procedure ProcFloat;
    procedure ProcSet;
    procedure ProcString;
    procedure ProcBoolean;
    procedure ProcDate;
    procedure ProcEq;
    procedure ProcNe;
    procedure ProcGt;
    procedure ProcLt;
    procedure ProcGe;
    procedure ProcLe;
    procedure ProcLike;
    procedure ProcUnlike;
    procedure ProcNot;
    procedure ProcAnd;
    procedure ProcXor;
    procedure ProcOr;
    procedure ProcIn;
    procedure ProcAdd;
    procedure ProcSubtract;
    procedure ProcMultiply;
    procedure ProcDivide;
    procedure ProcPower;
    procedure ProcAbs;
    // some gonio functions
    procedure Procpi;
    procedure ProcSin;
    procedure ProcCos;
    procedure ProcTan;
    procedure Procarcsin;
    procedure Procarccos;
    procedure Procarctan;
    procedure Procarctan2;

    procedure ProcNegate;
    procedure ProcSqr;
    procedure ProcSqrt;
    procedure ProcLeft;
    procedure ProcRight;
    function vpop: Variant;
    procedure vpush(AValue: Variant);
//    function opop: TToken;
//    procedure opush(AValue: TToken);
//    function ppop: TToken;
//    procedure ppush(AValue: TToken);
    function rpop: Integer;
    procedure rpush(AValue: Integer);
    procedure doproc;
    procedure doToken(aToken: TToken);
    procedure SetScriptTimeOut(const Value: Integer);
    procedure ParseScript;
    procedure SetonGetSystem(const Value: TOnGetSystem);
    procedure SetonSetSystem(const Value: TOnSetSystem);
    procedure SetonInclude(const Value: TOnInclude);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Execute: Variant;
    function popValue: Variant;
    function canPopValue: Boolean;
    procedure pushValue(AValue: Variant);
    function canPushValue: Boolean;
  published
    property Script: string read FScript write SetScript;
    property ScriptTimeOut: Integer read FScriptTimeOut write SetScriptTimeOut;
    property onGetVariable: TOnGetVariable read FOnGetVariable write SetOnGetVariable;
    property onSetVariable: TOnSetVariable read FOnSetVariable write SetOnSetVariable;
    property onSetSystem: TOnSetSystem read FOnSetSystem write SetonSetSystem;
    property onGetSystem: TOnGetSystem read FOnGetSystem write SetonGetSystem;
    property onInclude: TOnInclude read FOnInclude write SetonInclude;
  end;

// runs an external file or progam
procedure Launch(const AFile: string);

implementation

uses
  {$IFDEF UNITVERSIONING}
  JclUnitVersioning,
  {$ENDIF UNITVERSIONING}
  Math,
  JvQConsts, JvQResources;

{ some utility functions }

procedure Launch(const AFile: string);
var
  Command, Params, WorkDir: string;
begin
  Command := AFile;
  Params := #0;
  WorkDir := #0;  
  ShellExecute(0, 'open', PChar(Command),
    PChar(Params), PChar(WorkDir), SW_SHOWNORMAL); 
end;

procedure GlobalSetValue(var aText: string; const AName, AValue: string);
var
  p, p2, L: Integer;
begin
  l := Length(AName) + 2;
  if aText = '' then
  begin
    aText := AName + '="' + AValue + '"';
  end
  else
  begin
    p := PosText(AName + '="', aText);
    if p = 0 then
    begin
      aText := aText + ' ' + AName + '="' + AValue + '"';
    end
    else
    begin
      p2 := PosStr('"', aText, p + L);
      if p2 = 0 then
        Exit;
      Delete(aText, p + L, p2 - (p + L));
      Insert(AValue, aText, p + L);
    end;
  end;
end;

function GlobalGetValue(const aText, AName: string): string;
var
  p, p2, L: Integer;
begin
  Result := '';
  L := Length(AName) + 2;
  p := PosText(AName + '="', aText);
  if p = 0 then
    Exit;
  p2 := PosStr('"', aText, p + L);
  if p2 = 0 then
    Exit;
  Result := Copy(atext, p + L, p2 - (p + L));
  Result := StringReplace(Result, '~~', sLineBreak, [rfreplaceall]);
end;

// some special expression functions

// returns the Index of Integer v in aList

function IndexOfInteger(aList: TStringList; v: Variant): Integer;
var
  c, i, Index, p: Integer;
  s, s1, s2: string;
begin
  Result := -1;
  i := v;
  c := AList.Count;
  if c = 0 then
    Exit;
  for Index := 0 to c - 1 do
  begin
    try
      s := aList[Index];
      p := Pos('..', s);
      if p = 0 then
      begin
        if StrToInt(aList[Index]) = i then
        begin
          Result := Index;
          Exit;
        end;
      end
      else
      begin // have range
        s1 := trim(Copy(s, 1, p - 1));
        s2 := trim(Copy(s, p + 2, Length(s)));
        if (i >= StrToInt(s1)) and (i <= StrToInt(s2)) then
        begin
          Result := Index;
          Exit;
        end;
      end;
    except
      Exit;
    end;
  end;
end;

// returns the Index of float v (single or double)in aList

function IndexOfFloat(aList: TStringList; v: Variant): Integer;
var
  c, Index, p: Integer;
  f: extended;
  s, s1, s2: string;
begin
  Result := -1;
  f := v;
  c := AList.Count;
  if c = 0 then
    Exit;
  for Index := 0 to c - 1 do
  begin
    try
      s := aList[Index];
      p := Pos('..', s);
      if p = 0 then
      begin
        if strtofloat(s) = f then
        begin
          Result := Index;
          Exit;
        end;
      end
      else
      begin // have range
        s1 := trim(Copy(s, 1, p - 1));
        s2 := trim(Copy(s, p + 2, Length(s)));
        if (f >= strtofloat(s1)) and (f <= strtofloat(s2)) then
        begin
          Result := Index;
          Exit;
        end;
      end;
    except
      raise EJvJanScriptError.CreateResFmt(@RsEInvalidNumbers, [s]);
    end;
  end;
end;

// returns the Index of date v in aList

function IndexOfDate(aList: TStringList; v: Variant): Integer;
var
  c, Index, p: Integer;
  d: TDatetime;
  s, s1, s2: string;
begin
  Result := -1;
  d := v;
  c := AList.Count;
  if c = 0 then
    Exit;
  for Index := 0 to c - 1 do
  begin
    try
      s := aList[Index];
      p := Pos('..', s);
      if p = 0 then
      begin
        if strtodate(aList[Index]) = d then
        begin
          Result := Index;
          Exit;
        end;
      end
      else
      begin
        s1 := trim(Copy(s, 1, p - 1));
        s2 := trim(Copy(s, p + 2, Length(s)));
        if (d >= strtoDate(s1)) and (d <= strtoDate(s2)) then
        begin
          Result := Index;
          Exit;
        end;
      end;
    except
      Exit;
    end;
  end;
end;

// returns the Index of string v in aList

function IndexOfString(aList: TStringList; v: Variant): Integer;
var
  c, Index, p: Integer;
  sv: string;
  s, s1, s2: string;
begin
  Result := -1;
  sv := v;
  c := AList.Count;
  if c = 0 then
    Exit;
  for Index := 0 to c - 1 do
  begin
    try
      s := aList[Index];