jvqsal.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: JvSAL.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: JvQSAL.pas,v 1.16 2004/09/07 23:11:35 asnepvangers Exp $

unit JvQSAL;

{$I jvcl.inc}

interface

uses
  SysUtils, Classes, QWindows, QMessages, QGraphics, QControls, QForms, QDialogs,
  JvQSALHashList, JvQStrings, JvQComponent;

const
  StackLimit = 256;
  // message are processed every 250 milliseconds
  // use the stop procedure to stop a locked script
  TimeOut = 250;

type
  TOnGetUnitEvent = procedure(Sender: TObject; AUnit: string;
    var AValue: string; var Handled: Boolean) of object;

  TJvAtom = class(TObject)
  private
    FValue: Variant;
    FActor: TJvSALProc;
    procedure SetActor(const Value: TJvSALProc);
    procedure SetValue(const AValue: Variant);
  public
    property Value: Variant read FValue write SetValue;
    property Actor: TJvSALProc read FActor write SetActor;
  end;

  TJvSALProcAtom = class(TObject)
  private
    FParser: TJvSALProc;
    FActor: TJvSALProc;
    procedure SetActor(const Value: TJvSALProc);
    procedure SetParser(const Value: TJvSALProc);
  public
    property Actor: TJvSALProc read FActor write SetActor;
    property Parser: TJvSALProc read FParser write SetParser;
  end;

  TJvAtoms = class(TStringList)
  public
    procedure ClearAll;
    destructor Destroy; override;
  end;

  TJvSAL = class(TJvComponent)
  private
    FStop: Boolean;
    FCaption: string;
    FSP: Integer;
    FRSP: Integer;
    FBSP: Integer;
    FStack: array [0..StackLimit] of Variant;
    FBStack: array [0..StackLimit] of Boolean;
    FRStack: array [0..StackLimit] of Integer;
    FProcs: TJvSALHashList;
    FScript: string;
    FUnits: TStringList;
    FTicks: cardinal;
    FOnGetUnit: TOnGetUnitEvent;
    FVariableName: string;
    FVariable: TJvAtom;
    FSelection: Variant;
    FUseDirective: string;
    FBeginOfComment: string;
    FEndOfComment: string;
    FStringDelimiter: string;
    FPC: Integer;
    FAtoms: TJvAtoms;
    FPCProc: Integer;
    FToken: string;
    procedure SetScript(const Value: string);
    procedure SetGetUnit(const Value: TOnGetUnitEvent);
    procedure SetVariable(const Value: TJvAtom);
    procedure SetVariableName(const Value: string);
    procedure SetSelection(const Value: Variant);
    procedure SetUseDirective(const Value: string);
    procedure SetBeginOfComment(const Value: string);
    procedure SetEndOfComment(const Value: string);
    procedure SetStringDelimiter(const Value: string);
    procedure SetPC(const Value: Integer);
    procedure SetToken(const Value: string);
    procedure SetCaption(const Value: string);
  protected
    procedure ParseScript;
    // return FStack methods
    // SAL language
    procedure xBoSub;
    procedure xEoSub;
    procedure xValue;
    procedure xDefVariable;
    procedure xVariable;
    procedure xProc;
    procedure xNoParser;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ClearProcedures;
    procedure AddProcedure(AName: string; AProcedure, AParser: TJvSALProc);
    function APO(Op: string; AProc: TJvSALProc): Integer;
    procedure Push(AValue: Variant);
    function Pop: Variant;
    procedure RPush(AValue: Integer);
    function RPop: Integer;
    procedure BoolPush(AValue: Boolean);
    function BoolPop: Boolean;
    procedure LoadFromFile(FileName: string);
    procedure Execute;
    procedure Stop;
    property PC: Integer read FPC write SetPC;
    property Atoms: TJvAtoms read FAtoms;
    property PCProc: Integer read FPCProc;
    property Token: string read FToken write SetToken;
    property Script: string read FScript write SetScript;
    property Caption: string read FCaption write SetCaption;
    property Variable: TJvAtom read FVariable write SetVariable;
    property VariableName: string read FVariableName write SetVariableName;
    property TheSelect: Variant read FSelection write SetSelection;
    property UseDirective: string read FUseDirective write SetUseDirective;
    property BeginOfComment: string read FBeginOfComment write SetBeginOfComment;
    property EndOfComment: string read FEndOfComment write SetEndOfComment;
    property StringDelim: string read FStringDelimiter write SetStringDelimiter;
  published
    property OnGetUnit: TOnGetUnitEvent read FOnGetUnit write SetGetUnit;
  end;

implementation

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

const
  // do not localize these strings
  cSAL = 'SAL';
  cUse = 'use::';
  cLiteral = 'literal';
  cProc = 'proc-';
  cEndProc = 'end-proc';
  cVar = 'var-';

//=== { TJvSAL } =============================================================

constructor TJvSAL.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FAtoms := TJvAtoms.Create;
  FProcs := TJvSALHashList.Create(ITinyHash, HashSecondaryOne, SameText);
  FUnits := TStringList.Create;
  FCaption := cSAL;
  FUseDirective := cUse;
  FBeginOfComment := '{';
  FEndOfComment := '}';
  FStringDelimiter := '"';
end;

destructor TJvSAL.Destroy;
begin
  FAtoms.Free;
  FProcs.Free;
  FUnits.Free;
  inherited Destroy;
end;

function TJvSAL.BoolPop: Boolean;
begin
  Dec(FBSP);
  if FBSP < 0 then
    raise EJVCLException.CreateRes(@RsEBooleanStackUnderflow);
  Result := FBStack[FBSP];
end;

procedure TJvSAL.BoolPush(AValue: Boolean);
begin
  FBStack[FBSP] := AValue;
  Inc(FBSP);
  if FBSP > StackLimit then
    raise EJVCLException.CreateRes(@RsEBooleanStackOverflow);
end;

procedure TJvSAL.Execute;
var
  A: TJvAtom;
  C: Integer;
begin
  PC := 0;
  FSP := 0;
  FRSP := 0;
  FBSP := 0;
  C := Atoms.Count;
  FStop := False;
  FTicks := GetTickCount;
  if C = 0 then
    Exit;
  repeat
    A := TJvAtom(Atoms.Objects[PC]);
    FPCProc := PC;
    Inc(FPC);
    A.Actor;
    if (GetTickCount - FTicks) > TimeOut then
    begin
      FTicks := GetTickCount;
      Application.ProcessMessages;
    end;
    if FStop then
      raise EJVCLException.CreateRes(@RsEProgramStopped);
  until PC >= C;
end;

procedure TJvSAL.ParseScript;
var
  S: string;
  //  iprocs: Integer;
  haveproc: Boolean;
  AActor: TJvSALProc;
  AParser: TJvSALProc;
  I, P, P2: Integer;
  fv: Double;
  A: TJvAtom;
  fn, TheUnit: string;
  Handled: Boolean;

  function CharFrom(From: Integer; AChar: Char; AText: string): Integer;
  var
    C: Integer;
  begin
    Result := 0;
    C := Length(AText);
    repeat
      if AText[From] = AChar then
      begin
        Result := From;
        Exit;
      end;
      Inc(From);
    until From > C;
  end;

begin
  PC := 1;
  S := FScript;
  FUnits.Clear;
  // process any includes
  repeat
    P := Pos(FUseDirective, S); // default use::
    if P > 0 then
    begin
      P2 := CharFrom(P, ' ', S);
      if P2 = 0 then
        raise EJVCLException.CreateResFmt(@RsEUnterminatedIncludeDirectiveNears, [Copy(S, P, 50)]);
      fn := Trim(Copy(S, P + Length(FUseDirective), P2 - P - Length(FUseDirective)));
      if not Assigned(FOnGetUnit) then
        raise EJVCLException.CreateRes(@RsEOngetUnitEventHandlerIsNotAssigned);
      Handled := False;
      fn := LowerCase(fn);
      if FUnits.IndexOf(fn) = -1 then
      begin
        OnGetUnit(Self, fn, TheUnit, Handled);
        if not Handled then
          raise EJVCLException.CreateResFmt(@RsECouldNotIncludeUnits, [fn]);
        TheUnit := StringReplace(TheUnit, Cr, ' ', [rfReplaceAll]);
        Delete(S, P, P2 - P);
        Insert(TheUnit, S, P);
        FUnits.Append(fn);
      end;
    end;
  until P = 0;

  while S <> '' do
  begin
    if Pos(FBeginOfComment, S) = 1 then
    begin // default= {
      P := Pos(FEndOfComment, S); // default= }
      if P = 0 then
        raise EJVCLException.CreateResFmt(@RsEUnterminatedCommentNears, [S]);
      Delete(S, 1, P + Length(FEndOfComment) - 1);
      S := Trim(S);
    end
    else
    if Pos(FStringDelimiter, S) = 1 then
    begin // default = "
      Delete(S, 1, Length(FStringDelimiter));
      P := Pos(FStringDelimiter, S);
      if P = 0 then
        raise EJVCLException.CreateResFmt(@RsEUnterminatedStringNears, [S]);
      Token := Copy(S, 1, P - 1);
      Delete(S, 1, P + Length(FStringDelimiter) - 1);
      S := Trim(S);
      A := TJvAtom.Create;
      A.Value := Token;
      A.Actor := xValue;
      Atoms.AddObject(cLiteral, A);
    end
    else
    begin
      P := Pos(' ', S);
      if P = 0 then
      begin
        Token := S;
        S := '';
      end
      else
      begin