vclclxcvt.pas

East make Tray Icon in delphi

            if GetNextToken(Parser, Token, Context) then
            begin
              { Replace '\' by '/' in the filename }
              if Token.Kind = tkString then
              begin
                Changed := False;
                for i := 1 to Length(Token.Value) do
                  if Token.Value[i] = '\' then
                  begin
                    Token.Value[i] := '/';
                    Changed := True;
                  end;
                if Changed then
                  Parser.ReplaceParseNext(Token, Token, Token.Value);
              end;
            end;
            Continue;
          end;
          if SameText(Token.Value, 'type') or SameText(Token.Value, 'const') or
             SameText(Token.Value, 'resourcestring') or SameText(Token.Value, 'var') or
             SameText(Token.Value, 'function') or SameText(Token.Value, 'procedure') or
             SameText(Token.Value, 'implementation') or SameText(Token.Value, 'begin') then
          begin
            FStatistics.AddError('Wrong condition blocks in ' + Token.Parser.Filename);
            Parser.Index := Token.StartIndex; // reparse this token
            Break; // there is something wrong with the Condition-Blocks.
          end;

          FUsesUnits.Add(Token.Value);
          if not IsProtectedByConditions then
          begin
            // replace unit names, because we are outside a VCL/VisualCLX condition
            if not IsUnitIgnored(Token.Value) then
            begin
              {  asn: not required anymore.
              if SameText(Token.Value, 'Windows') then
                InsertTypesUnitStartIndex := Token.StartIndex;
              if (InsertTypesUnitStartIndex = -1) and SameText(Token.Value, 'Graphics') then
                InsertTypesUnitStartIndex := Token.StartIndex;
              }
              ReplaceUnitName(Token);
            end;
          end;
        end;
    end;
  end;
  {
  if (InsertTypesUnitStartIndex > 0) and Context.InInterfaceSection and
     (FUsesUnits.IndexOf('Types') = -1) then
  begin
    Parser.Insert(InsertTypesUnitStartIndex, 'Types, ');
    Parser.IndexNoClear := Parser.Index + 7;
  end;
  }
end;

procedure TVCLConverter.CheckFileHead(Token: PTokenInfo; var Context: TParseContext);
var
  Parser: TPascalParser;
  NewFilename, Filename, Ext: string;
begin
  if SameText(Token.Value, 'unit') then
    Ext := '.pas'
  else if SameText(Token.Value, 'package') then
    Ext := '.dpk'
  else
    Ext := '.dpr';

  Filename := '';
  Parser := Token.Parser;
  while GetNextToken(Parser, Token, Context) do
  begin
    if Token.Kind = tkIdent then
    begin
      // unit/program/library/package name
      if Filename = '' then // only the first identifier is the unit name, others are syntax errors
      begin
        FUsesUnits.Add(Token.Value);
        Filename := Token.Value + Ext;
        NewFilename := ChangeFileName(Filename);
        if NewFilename <> Filename then
        begin
          Filename := ChangeFileExt(ExtractFileName(NewFilename), '');
          Parser.ReplaceParseNext(Token, Token, Filename);
        end;
      end;
    end
    else
    if (Token.Kind = tkSymbol) and (Token.Value = ';') then
      Break; // finished
  end;
end;

procedure TVCLConverter.CheckFunction(Token: PTokenInfo; var Context: TParseContext);
var
  Parser: TPascalParser;
  LockedUnitStartCount: Integer;
  BeginBlockCount: Integer;
  InParams: Boolean;
  LastTokenValue: string;
begin
  Parser := Token.Parser;
  LockedUnitStartCount := FLockedUsesUnits.Count;
  try
   // procedure/function header
    InParams := False;
    while GetNextToken(Parser, Token, Context) do
    begin
      if not InParams then
      begin
        if Token.Kind = tkSymbol then
        begin
          if Token.Value = ';' then
            InParams := True; // no parameters
          if Token.Value = '(' then
            InParams := True;
        end;
      end
      else
      begin
        case Token.Kind of
          tkIdent:
            begin
              if (LastTokenValue <> ':') and IsUsesUnit(Token.Value) then
                FLockedUsesUnits.Add(Token.Value) // this unit name is redeclared as parameter
              else
              begin
                CaseParseContext(Token, Context);
                if SameText(Token.Value, 'external') or
                   SameText(Token.Value, 'forward') then
                  Exit; // this is only a procedure head
                if SameText(Token.Value, 'begin') or
                   SameText(Token.Value, 'var') or
                   SameText(Token.Value, 'const') or
                   SameText(Token.Value, 'type') or
                   SameText(Token.Value, 'resourcestring') then
                  Break;
                if SameText(Token.Value, 'end') then
                begin
                  FStatistics.AddError('"end" found but "begin", "var", "const", "type" or "resourcestring" expected.');
                  Exit; // something very strange happend
                end;
              end;
            end;
        else
          CaseParseContext(Token, Context);
        end;
      end;
      LastTokenValue := Token.Value;
    end;

    if Token = nil then
      Exit;

    if not SameText(Token.Value, 'begin') then
      CheckFunctionVarDecls(Token, Context);

    BeginBlockCount := 1;
    while GetNextToken(Parser, Token, Context) do
    begin
      if Token.Kind = tkIdent then
      begin
        if SameText(Token.Value, 'begin') then
          Inc(BeginBlockCount)
        else
        if SameText(Token.Value, 'end') then
        begin
          Dec(BeginBlockCount);
          if BeginBlockCount = 0 then
            Break; // function end
        end;
      end;
      CaseParseContext(Token, Context);
    end;
  finally
    // we leave the function so remove the locked local "unit name" variables
    while FLockedUsesUnits.Count > LockedUnitStartCount do
      FLockedUsesUnits.Delete(FLockedUsesUnits.Count - 1);
  end;
end;

procedure TVCLConverter.CheckFunctionVarDecls(Token: PTokenInfo;
  var Context: TParseContext);
var
  Parser: TPascalParser;
  LastTokenValue: string;
begin
  Parser := Token.Parser;
  while GetNextToken(Parser, Token, Context) do
  begin
    case Token.Kind of
      tkIdent:
        begin
          if (LastTokenValue <> ':') and IsUsesUnit(Token.Value) then
            FLockedUsesUnits.Add(Token.Value) // this unit name is redeclared as variable/const/resstring
          else
          begin
            if not CaseParseContext(Token, Context) then // meight find records, ...
            begin
              if SameText(Token.Value, 'begin') then
                Break;
              if SameText(Token.Value, 'end') then
              begin
                FStatistics.AddError('"end" found but "begin", "var", "const", "type" or "resourcestring" expected.');
                Exit; // something very strange happend
              end;
            end;
          end;
        end;
    else
      CaseParseContext(Token, Context);
    end;
    LastTokenValue := Token.Value;
  end;
end;

procedure TVCLConverter.BeforeSave(const Filename: string; Lines: TStrings);
begin
  // do nothing
end;

{
  Calls CheckDfmLine with parameter Control=
   * ClassName e.g. 'TListView'
   * ClassName.Property for Collections e.g: 'TListView.Columns'
   * ClassName.Property:item for Collection items: e.g. 'TListView.Columns:item'
}
procedure TVCLConverter.ParseDfmFile(const Filename: string);
var
  Lines: TStrings;
  i, ps: Integer;
  S, TrimS: string;
  Controls: TStringList;
begin
  Controls := TStringList.Create;
  Lines := TStringList.Create;
  try
    Lines.LoadFromFile(Filename);
    if Lines.Count > 0 then
    begin
      if (Lines[0] <> '') and (Lines[0][1] < #32) or (Lines[0][2] < #32) then
      begin
        FStatistics.AddError(ExtractFileName(Filename) + ' is binary. Converting to text.');
        ConvertBinDfmToText(Filename);
        Lines.LoadFromFile(Filename);
      end;

      i := 0;
      while i < Lines.Count do
      begin
        S := Lines[i];
        TrimS := Trim(S);
        if TrimS <> '' then
        begin
          if TrimS = 'DesignSize = (' then
          begin
            Lines.Delete(i);
            Lines.Delete(i);
            Lines.Delete(i);
            Continue;
          end
          else
          begin
            if AnsiStartsText('object ', TrimS) then
            begin
              ps := Pos(':', TrimS);
              if ps > 0 then
                Controls.Add(Trim(Copy(TrimS, ps + 1, MaxInt)));
            end
            else
            if SameText(TrimS, 'end') and (Controls.Count > 0) then
              Controls.Delete(Controls.Count - 1)
            else
            if Controls.Count > 0 then
            begin
              if AnsiEndsText('= <', TrimS) then
              begin
                // collection
                Controls.Add(Controls[Controls.Count - 1] + '.' + Trim(Copy(TrimS, 1, Pos('=', TrimS) - 1)));
              end
              else
              if SameText(TrimS, 'end>') then
              begin
                Controls.Delete(Controls.Count - 1);
                Controls.Delete(Controls.Count - 1);
              end
              else if SameText(TrimS, 'item') then
                Controls.Add(Controls[Controls.Count - 1] + ':item')
              else
                CheckDfmLine(S, Controls[Controls.Count - 1], Controls);
              Lines[i] := S;
            end;
          end;
        end;
        Inc(i);
      end;

      WriteFile(Lines,
        FOutDirectory + PathDelim + ChangeFileName(ExtractFileName(Filename)),
        False);
    end
    else
      FStatistics.AddError(ExtractFileName(Filename) + ' is empty.');
  finally
    Lines.Free;
    Controls.Free;
  end;
end;

procedure TVCLConverter.CheckDfmLine(var Line: string; const Control: string; Controls: TStrings);
var
  S, OrgS: string;
begin
  Line := TrimRight(Line);
  if Line <> '' then
  begin
    S := TrimLeft(Line);
    OrgS := S;
    ChangeDfmLine(S, Control, Controls);
    if S <> OrgS then
      Line := StringReplace(Line, OrgS, S, []);
  end;
end;

procedure TVCLConverter.ChangeDfmLine(var Line: string; const Control: string; Controls: TStrings);
begin
  if (Controls.Count = 1) and AnsiStartsText('BorderStyle = ', Line) then
    Line := StringReplace(Line, ' bs', ' fbs', [rfIgnoreCase]);
  if AnsiStartsText('Ctl3D = ', Line) or
     AnsiStartsText('ParentCtl3D = ', Line) then
    Line := '';
  if AnsiStartsText('IsControl = True', Line) or
     AnsiStartsText('PageSize = 0', Line) or
     AnsiStartsText('DefaultMonitor = ', Line) or
     AnsiStartsText('RightClickSelect = True', Line) then
    Line := '';
  if (Control = 'TProgressBar') and AnsiStartsText('TabOrder = ', Line) then
    Line := '';
  if (Control = 'TComboBox') and (AnsiStartsText('AutoDropDown = ', Line) or 
                                  AnsiStartsText('AutoCloseUp = ', Line)) then
    Line := '';
  if (Control = 'TListView') then
  begin
    if AnsiStartsText('SmallImages = ', Line) then
      Line := StringReplace(Line, 'SmallImages = ', 'Images = ', [rfIgnoreCase])
    else if AnsiStartsText('OnCompare = ', Line) then
      Line := ''
    else if AnsiStartsText('SortType = ', Line) then
    begin
      if Pos('= stNone', Line) = 0 then
        Line := 'Sorted = True'
      else
        Line := ''
    end;
  end;
end;

function TVCLConverter.IsProtectedByConditions: Boolean;
var
  i: Integer;
begin
  Result := True;
  for i := 0 to ConvertProtected.Count - 1 do
    if FConditionStack.IsIn(ConvertProtected[i]) <> 0 then
      Exit;
  Result := False;
end;

function TVCLConverter.GetNextToken(Parser: TPascalParser;
  var Token: PTokenInfo; var Context: TParseContext): Boolean;
begin
  Context.LastToken := Context.CurToken;
  while Parser.GetToken(Token) and (Token.Kind = tkComment) do
  begin
    if Token.ExKind = tekOption then
      CheckOption(Token);
  end;
  Result := Token <> nil;
  if Result then
    Context.CurToken := Token^;
end;

end.