jvqforth.pas

East make Tray Icon in delphi

  xmldso := FXMLList.Xml(AName);
  if aMethod = 'set' then
  begin
    aPath := vpop;
    AValue := vpop;
    n := xmldso.ForceNamePathNode(aPath);
    n.Value := AValue;
  end
  else
  if aMethod = '@set' then
  begin
    aPath := vpop;
    atName := vpop;
    AValue := vpop;
    xmldso.ForceNamePathNodeAttribute(aPath, atName, AValue);
  end
  else
  if aMethod = 'get' then
  begin
    apath := vpop;
    n := xmldso.getNamePathNode(apath);
    if n = nil then
      AValue := ''
    else
      AValue := n.Value;
    vpush(AValue);
  end
  else
  if aMethod = 'Count' then
  begin
    apath := vpop;
    n := xmldso.getNamePathNode(apath);
    AValue := 0;
    cc := 0;
    if n <> nil then
    begin
      // now Count named node
      c := n.Nodes.Count;
      apath := vpop;
      if c > 0 then
      begin
        for i := 0 to c - 1 do
          if TJvXMLNode(n.nodes[i]).name = apath then
            Inc(cc);
      end;
      AValue := cc;
    end;
    vpush(AValue);
  end
  else
  if aMethod = '@get' then
  begin
    apath := vpop;
    atname := vpop;
    a := xmldso.getNamePathNodeAttribute(apath, atname);
    if n = nil then
      AValue := ''
    else
      AValue := a.Value;
    vpush(AValue);
  end
  else
  if aMethod = 'load' then
  begin
    aPath := vpop;
    aPath := StringReplace(aPath, '%', appldir, []);
    if not fileexists(aPath) then
      raise EJvJanScriptError.CreateResFmt(@RsEFilesDoesNotExist, [apath]);
    xmldso.LoadFromFile(apath);
  end
  else
  if aMethod = 'save' then
  begin
    apath := vpop;
    aPath := StringReplace(aPath, '%', appldir, []);
    try
      xmldso.SaveToFile(apath);
    except
      raise EJvJanScriptError.CreateResFmt(@RsECanNotSaveToFiles, [apath]);
    end
  end
  else
  if aMethod = 'astext' then
  begin
    AValue := xmldso.asText;
    vpush(AValue);
  end
  else
  if aMethod = 'Delete' then
  begin
    apath := vpop;
    xmldso.deleteNamePathNode(apath);
  end
  else
  if aMethod = '@Delete' then
  begin
    apath := vpop;
    atname := vpop;
    xmldso.deleteNamePathNodeAttribute(apath, atName);
  end
  else
  if aMethod = 'select' then
  begin
    apath := vpop;
    apath := StringReplace(apath, '''', '"', [rfreplaceall]);
    FXMLSelect.Clear;
    FXMLSelectRecord := -1;
    xmldso.selectNodes(apath, FXMLSelect);
    vpush(FXMLSelect.Count > 0);
  end
  else
  if aMethod = 'selectfirst' then
  begin
    b := FXMLSelect.Count <> 0;
    if b then
      FXMLSelectRecord := 0
    else
      FXMLSelectRecord := -1;
    AValue := b;
    vpush(AValue);
  end
  else
  if aMethod = 'selectnext' then
  begin
    b := FXMLSelect.Count <> 0;
    if b then
      Inc(FXMLSelectRecord)
    else
      FXMLSelectRecord := -1;
    if FXMLSelectRecord >= FXMLSelect.Count then
    begin
      b := False;
      FXMLSelectRecord := -1;
    end;
    AValue := b;
    vpush(AValue);
  end
  else
  if aMethod = 'selectget' then
  begin
    if FXMLSelect.Count = 0 then
      raise EJvJanScriptError.CreateRes(@RsEXMLSelectionIsEmpty);
    if FXMLSelectRecord = -1 then
      raise EJvJanScriptError.CreateRes(@RsENoXMLSelectionSelected);
    if FXMLSelectRecord >= FXMLSelect.Count then
      raise EJvJanScriptError.CreateRes(@RsEXMLSelectionOutOfRange);
    n := TJvXMLNode(FXMLSelect[FXMLSelectRecord]);
    AValue := n.Value;
    vpush(AValue);
  end
  else
  if aMethod = '@selectget' then
  begin
    if FXMLSelect.Count = 0 then
      raise EJvJanScriptError.CreateRes(@RsEXMLSelectionIsEmpty);
    if FXMLSelectRecord = -1 then
      raise EJvJanScriptError.CreateRes(@RsENoXMLSelectionSelected);
    if FXMLSelectRecord >= FXMLSelect.Count then
      raise EJvJanScriptError.CreateRes(@RsEXMLSelectionOutOfRange);
    n := TJvXMLNode(FXMLSelect[FXMLSelectRecord]);
    atname := vpop;
    AValue := n.GetAttributeValue(atname);
    vpush(AValue);
  end
  else
    raise EJvJanScriptError.CreateResFmt(@RsEInvalidXmlMethodSpecifiers, [aMethod]);
end;

procedure TJvForthScript.ProcVarDecTestZero;
var
  v: Variant;
  vo: TVariantObject;
begin
  vo := FvarsList.GetObject(FCurrentSymbol);
  if vo <> nil then
  begin
    v := vo.Value - 1;
    vo.Value := v;
    vpush(v = 0);
  end
  else
    raise EJvJanScriptError.CreateResFmt(@RsEVariablesNotDefined_, [FCurrentSymbol]);
end;

procedure TJvForthScript.ProcVarIncIndex;
var
  vo: TVariantObject;
  s, sidx: string;
  pb, pe: Integer;
  Index: Integer;
begin
  vo := FvarsList.GetObject(FCurrentSymbol);
  if vo <> nil then
  begin
    s := vo.Value;
    pb := lastposchar('[', s);
    if pb = 0 then
      raise EJvJanScriptError.CreateResFmt(@RsEIncrementIndexExpectedIns, [s]);
    pe := lastposchar(']', s);
    if pe = 0 then
      raise EJvJanScriptError.CreateResFmt(@RsEIncrementIndexExpectedIns_, [s]);
    sidx := Copy(s, pb + 1, pe - pb - 1);
    try
      Index := StrToInt(sidx);
      Inc(Index);
      s := Copy(s, 1, pb - 1) + '[' + inttostr(Index) + ']';
      vo.Value := s;
      vpush(s);
    except
      raise EJvJanScriptError.CreateResFmt(@RsEIncrementIndexExpectedIntegerBetwee, [s]);
    end;
  end
  else
    raise EJvJanScriptError.CreateResFmt(@RsEVariablesNotDefined_, [FCurrentSymbol]);
end;

procedure TJvForthScript.ProcCrLf;
begin
  vpush(sLineBreak);
end;

procedure TJvForthScript.ProcShellExecute;
var
  afile: string;
  appldir: string;
begin
  appldir := ExtractFilePath(paramstr(0));
  afile := vpop;
  afile := StringReplace(afile, '%', appldir, []);
  launch(afile);
end;

procedure TJvForthScript.ProcDateStr;
var
  s: string;
begin
  s := FormatDateTime('dd-mmm-yyyy', now);
  vpush(s);
end;

procedure TJvForthScript.ProcTimeStr;
var
  s: string;
begin
  s := FormatDateTime('hh:nn:ss', now);
  vpush(s);
end;

procedure TJvForthScript.ProcNow;
begin
  vpush(now);
end;

//=== { TAtom } ==============================================================

procedure TAtom.SetIsOperand(const Value: Boolean);
begin
  FIsOperand := Value;
end;

procedure TAtom.SetToken(const Value: TToken);
begin
  FToken := Value;
end;

procedure TAtom.SetProc(const Value: TProcVar);
begin
  FProc := Value;
end;

procedure TAtom.SetSymbol(const Value: string);
begin
  FSymbol := Value;
end;

procedure TAtom.SetValue(const Value: Variant);
begin
  FValue := Value;
end;

//=== { TAtomList } ==========================================================

procedure TAtomList.ClearObjects;
var
  i, c: Integer;
begin
  c := Count;
  if c = 0 then
    Exit;
  for i := 0 to c - 1 do
    TAtom(items[i]).Free;
  Clear;
end;

destructor TAtomList.Destroy;
begin
  ClearObjects;
  inherited Destroy;
end;

//=== { TVariantObject } =====================================================

procedure TVariantObject.SetValue(const Value: Variant);
begin
  FValue := Value;
end;

//=== { TVariantList } =======================================================

procedure TVariantList.ClearObjects;
var
  i, c: Integer;
begin
  c := Count;
  if c = 0 then
    Exit;
  for i := 0 to c - 1 do
    TVariantObject(Objects[i]).Free;
  Clear;
end;

destructor TVariantList.Destroy;
begin
  ClearObjects;
  inherited Destroy;
end;

function TVariantList.GetObject(const Symbol: string): TVariantObject;
var
  Index: Integer;
begin
  Result := nil;
  if Count = 0 then
    Exit;
  Index := IndexOf(Symbol);
  if Index = -1 then
    Exit;
  Result := TVariantObject(Objects[Index]);
end;

function TVariantList.GetVariable(const Symbol: string): Variant;
var
  Index: Integer;
begin
  Result := null;
  if Count = 0 then
    Exit;
  Index := IndexOf(Symbol);
  if Index = -1 then
    Exit;
  Result := TVariantObject(Objects[Index]).Value;
end;

procedure TVariantList.SetVariable(const Symbol: string; AValue: Variant);
var
  Index: Integer;
  obj: TVariantObject;
begin
  Index := IndexOf(Symbol);
  if Index = -1 then
  begin
    obj := TVariantObject.Create;
    obj.Value := AValue;
    AddObject(Symbol, obj);
  end
  else
  begin
    TVariantObject(Objects[Index]).Value := AValue;
  end;
end;

//=== { TJvJanDSOList } ======================================================

procedure TJvJanDSOList.ClearTables;
var
  i, c: Integer;
begin
  c := Count;
  if c <> 0 then
    for i := 0 to c - 1 do
      TJvJanDSO(Objects[i]).Free;
  Clear;
end;

destructor TJvJanDSOList.Destroy;
begin
  ClearTables;
  inherited Destroy;
end;

function TJvJanDSOList.Table(const AName: string): TJvJanDSO;
var
  Index: Integer;
  dso: TJvJanDSO;
begin
  Index := IndexOf(AName);
  if Index = -1 then
  begin
    dso := TJvJanDSO.Create;
    AddObject(AName, dso);
    Result := dso;
  end
  else
    Result := TJvJanDSO(Objects[Index]);
end;

//=== { TJvJanDSO } ==========================================================

function TJvJanDSO.GetValue(AKey: Variant; const AField: string): string;
var
  Index: Integer;
  key: string;
  strkey: Boolean;
begin
  key := AKey;
  strkey := False;
  Index := 0;
  try
    Index := StrToInt(key)
  except
    strkey := True;
  end;
  if not strkey then
  begin
    if Index >= Count then
      raise EJvJanScriptError.CreateResFmt(@RsEDSOIndexOutOfRanged, [Index])
    else
      Result := InternalGetValue(Index, AField);
  end
  else
  begin
    Index := indexofName(key);
    if Index = -1 then
      raise EJvJanScriptError.CreateResFmt(@RsEDSOUnknownKeys, [key]);
    Result := InternalGetValue(Index, AField);
  end
end;

function TJvJanDSO.InternalGetValue(Index: Integer; const AField: string): string;
var
  key, s: string;
  p: Integer;
begin
  s := Strings[Index];
  p := Pos('=', s);
  key := Copy(s, 1, p - 1);
  s := Copy(s, p + 1, Length(s));
  Result := GlobalGetValue(s, AField);
end;

procedure TJvJanDSO.InternalSetValue(Index: Integer; const AField, AValue: string);
var
  key, s: string;
  p: Integer;
begin
  s := Strings[Index];
  p := Pos('=', s);
  key := Copy(s, 1, p - 1);
  s := Copy(s, p + 1, Length(s));
  GlobalSetValue(s, AField, AValue);
  Strings[Index] := key + '=' + s;
end;

procedure TJvJanDSO.SetValue(AKey: Variant; const AField, AValue: string);
var
  Index: Integer;
  key: string;
  strkey: Boolean;
begin
  key := AKey;
  strkey := False;
  Index := 0;
  try
    Index := StrToInt(key)
  except
    strkey := True;
  end;
  if not strkey then
  begin
    if Index >= Count then
      raise EJvJanScriptError.CreateResFmt(@RsEDSOIndexOutOfRanged, [Index])
    else
      InternalSetValue(Index, AField, AValue);
  end
  else
  begin
    Index := indexofname(key);
    if Index = -1 then
      Index := Add(key + '=');
    InternalSetValue(Index, AField, AValue);
  end
end;

//=== { TJvJanXMLList } ======================================================

procedure TJvJanXMLList.ClearXMLS;
var
  i, c: Integer;
begin
  c := Count;
  if c <> 0 then
    for i := 0 to c - 1 do
      TJvXMLTree(Objects[i]).Free;
  Clear;
end;

destructor TJvJanXMLList.Destroy;
begin
  ClearXMLS;
  inherited Destroy;
end;

function TJvJanXMLList.Xml(const AName: string): TJvXMLTree;
var
  Index: Integer;
  xmldso: TJvXMLTree;
begin
  Index := IndexOf(AName);
  if Index = -1 then
  begin
    xmldso := TJvXMLTree.Create(AName, '', nil);
    AddObject(AName, xmldso);
    Result := xmldso;
  end
  else
    Result := TJvXMLTree(Objects[Index]);
end;

{$IFDEF UNITVERSIONING}
const
  UnitVersioning: TUnitVersionInfo = (
    RCSfile: '$RCSfile: JvQForth.pas,v $';
    Revision: '$Revision: 1.17 $';
    Date: '$Date: 2004/09/07 23:11:17 $';
    LogPath: 'JVCL\run'
  );

initialization
  RegisterUnitVersion(HInstance, UnitVersioning);

finalization
  UnregisterUnitVersion(HInstance);
{$ENDIF UNITVERSIONING}

end.