generateutils.pas

East make Tray Icon in delphi

      if Assigned(Node.Properties.ItemNamed['NoLibSuffixprefix']) then
        GNoLibSuffixPrefix := Node.Properties.ItemNamed['NoLibSuffixprefix'].Value;
      if Assigned(Node.Properties.ItemNamed['clxprefix']) then
        GClxPrefix         := Node.Properties.ItemNamed['clxprefix'].Value;
      if Assigned(Node.Properties.ItemNamed['NoLibSuffixformat']) then
        GNoLibSuffixFormat := Node.Properties.ItemNamed['NoLibSuffixformat'].Value;
      if Assigned(Node.Properties.ItemNamed['clxformat']) then
        GClxFormat         := Node.Properties.ItemNamed['clxformat'].Value;


      // create the 'all' alias
      all := '';
      for i := 0 to TargetList.Count-1 do
      begin
        Target := TargetList.Items[i];
        all := all + Target.Name + ',';
        if Target.PName <> '' then
          all := all + Target.PName + ',';
      end;
      SetLength(all, Length(all) - 1);

      Node := TJvSimpleXmlElemClassic.Create(nil);
      try
        Node.Properties.Add('name', 'all');
        Node.Properties.Add('value', all);
        AliasList.Add(TAlias.Create(Node));
      finally
        Node.Free;
      end;
    finally
      xml.Free;
    end;
  except
    on E: Exception do
    begin
      Result := False;
      ErrMsg := E.Message;
    end;
  end;
end;

function GetPersoTarget(const Target : string) : string;
begin
  if TargetList[Target] <> nil then
    Result := TargetList[Target].PName
  else
    Result := Target;
end;

function GetNonPersoTarget(const PersoTarget : string) : string;
var
  i : integer;
  Target : TTarget;
begin
  Result := PersoTarget;
  for i := 0 to TargetList.Count - 1 do
  begin
    Target := TargetList.Items[i];
    if SameText(Target.PName, PersoTarget) then
    begin
      Result := Target.Name;
      Break;
    end;
  end;
end;

function DirToTarget(const dir : string) : string;
var
  i : integer;
  Target : TTarget;
begin
  Result := '';
  for i := 0 to TargetList.Count - 1 do
  begin
    Target := TargetList.Items[i];
    if Target.Dir = dir then
    begin
      Result := Target.Name;
      Break;
    end
    else if Target.PDir = dir then
    begin
      Result := Target.Name;
      Break;
    end;
  end;
end;

function TargetToDir(const target : string) : string;
begin
  if Assigned(TargetList[target]) then
    Result := TargetList[target].Dir
  else if Assigned(TargetList[GetNonPersoTarget(target)]) then
    Result := TargetList[GetNonPersoTarget(target)].PDir
  else
    raise Exception.CreateFmt('Target "%s" not found.', [target]);
end;

function ExpandPackageName(Name: string; const target : string) : string;
var
  Env   : string;
  Ver   : string;
  Typ   : string;
  Prefix: string;
begin

  Env := TargetList[GetNonPersoTarget(target)].Env;
  Ver := TargetList[GetNonPersoTarget(target)].Ver;
  Typ := Copy(Name, Length(Name), 1);

  if ((AnsiLowerCase(Env) = 'd') or (AnsiLowerCase(Env) = 'c')) and (Ver < '6') then
  begin
    Result := GNoLibSuffixFormat;
    Prefix := GNoLibSuffixPrefix;
  end
  else if (TargetList[GetNonPersoTarget(target)].IsCLX) then
  begin
    Result := GClxFormat;
    Prefix := GClxPrefix;
  end
  else
  begin
    Result := GFormat;
    Prefix := GPrefix;
  end;

  // If we find Prefix in the Name, then use it first, else, fall back
  // to GPrefix.
  if Pos(Prefix, Name) > 0 then
    Name := Copy(Name, Length(Prefix)+1, Pos('-', Name)-Length(Prefix)-1)
  else
    Name := Copy(Name, Length(GPrefix)+1, Pos('-', Name)-Length(GPrefix)-1);

  // Always use Prefix as the replacement string for %p
  MacroReplace(Result, '%',
    ['p', Prefix,
     'n', Name,
     'e', Env,
     'v', Ver,
     't', Typ]);
end;

function HasModelPrefix(Name : string; const target:string): Boolean;
var
  Env   : string;
  Ver   : string;
begin
  Env := TargetList[GetNonPersoTarget(target)].Env;
  Ver := TargetList[GetNonPersoTarget(target)].Ver;
  Result := False;

  // We first try a CLX prefix
  // If this failed, then we try a NoLibSuffix prefix
  // If this failed too, then we go back to the standard prefix.
  // This methods is employed mostly for CLX targets as this allows
  // to have a single xml source file for both CLX and non CLX
  // targets. For instance, in the JVCL, we would have a source file
  // called JvSystem-R.xml which requires JvCore-R. Using this method
  // when generating a CLX package which has a JvQ prefix, we still can
  // recognize JvCore-R has being one of the package names that needs
  // to be modified and thus will end up being JvQCoreD7R in the case
  // of the Delphi 7 CLX target while still being JvCoreD7R for a
  // regular Delphi 7 target (non CLX)

  if (TargetList[GetNonPersoTarget(target)].IsCLX) then
    Result := StartsWith(GClxPrefix, Name);

  if not Result and ((AnsiLowerCase(Env) = 'd') or (AnsiLowerCase(Env) = 'c')) and (Ver < '6') then
    Result := StartsWith(GNoLibSuffixPrefix, Name);

  if not Result then
    Result := StartsWith(GPrefix, Name);
end;

function BuildPackageName(xml: TRequiredPackage; const target : string) : string;
var
  Name : string;
begin
  Name := xml.Name;
  {TODO : CrossPlatform packages}
  if HasModelPrefix(Name, target) then
  begin
    Result := ExpandPackageName(Name, target);
  end
  else
  begin
    Result := Name;
  end;
end;

function IsNotInPerso(Item: TPackageXmlInfoItem; const target : string) : Boolean;
var
  persoTarget : string;
begin
  persoTarget := GetPersoTarget(target);
  if persoTarget = '' then
    Result := False
  else
  begin
    Result := not Item.IsIncluded(persoTarget) and
              Item.IsIncluded(target);
  end;
end;

function IsOnlyInPerso(Item: TPackageXmlInfoItem; const target : string) : Boolean;
var
  persoTarget : string;
begin
  persoTarget := GetPersoTarget(target);
  if persoTarget = '' then
    Result := False
  else
  begin
    Result := Item.IsIncluded(persoTarget) and
              not Item.IsIncluded(target);
  end;
end;

type
  TDefinesConditionParser = class (TConditionParser)
  protected
    FTarget: string;
    procedure MissingRightParenthesis; override;
    function GetIdentValue(const Ident: String): Boolean; override;
  public
    constructor Create(Target: string);
  end;

constructor TDefinesConditionParser.Create(Target: string);
begin
  inherited Create;
  FTarget := Target;
end;

procedure TDefinesConditionParser.MissingRightParenthesis;
begin
  raise Exception.Create('Missing ")" in conditional expression');
end;

function TDefinesConditionParser.GetIdentValue(const Ident: String): Boolean;
begin
  Result := DefinesList.IsDefined(Ident, FTarget);
end;

procedure EnsureCondition(lines: TStrings; Condition: string; const target : string);
var
  ConditionParser : TDefinesConditionParser;
begin
  // if there is a condition
  if (Condition <> '') then
  begin
    // Then parse it. If the result of the parsing says that
    // it is not True for the given target, then remove the content
    // of the lines.
    // Note: we used to enclose Delphi lines with IFDEFs, but because
    // the parser allows complex conditions, this is no longer possible.
    // Thus all platform behave the same: if the condition is True, the
    // line is left untouched, else it is cleared.
    ConditionParser := TDefinesConditionParser.Create(Target);
    try
      if not ConditionParser.Parse(Condition) then
        lines.Clear;
    finally
      ConditionParser.Free;
    end;
  end;
end;

function EnsurePFlagsCondition(const pflags, Target: string): string;
var
  PFlagsList : TStringList;
  I : Integer;
  CurPFlag : string;
  Condition : string;
  ParensPos : Integer;
begin
  // If any of the PFLAGS is followed by a string between parenthesis
  // then this is considered to be a condition.
  // If the condition is not in the Defines list, then the
  // corresponding PFLAG is discarded. This has been done mostly for
  // packages that have extended functionnality when USEJVCL is
  // activated and as such require the JCL dcp file.
  PFlagsList := TStringList.Create;
  Result := pflags;
  try
    StrToStrings(pflags, ' ', PFlagsList, False);
    for I := 0 to PFlagsList.Count-1 do
    begin
      CurPFlag := PFlagsList[I];
      ParensPos := Pos('(', CurPFlag);
      if ParensPos <> 0 then
      begin
        Condition := Copy(CurPFlag, ParensPos+1, Length(CurPFlag) - ParensPos -1);
        if not DefinesList.IsDefined(Condition, target)  then
          PFlagsList[I] := ''
        else
          PFlagsList[I] := Copy(CurPFlag, 1, ParensPos-1);
      end;
    end;
    Result := StringsToStr(PFlagsList, ' ', False);
  finally
    PFlagsList.Free;
  end;
end;

function GetUnitName(const FileName : string) : string;
begin
  Result := PathExtractFileNameNoExt(FileName);
end;

procedure EnsureProperSeparator(var Name : string; const target : string);
begin
  // ensure that the path separator stored in the xml file is
  // replaced by the one for the system we are targeting

  // first ensure we only have backslashes
  StrReplace(Name, '/', '\', [rfReplaceAll]);

  // and replace all them by the path separator for the target
  StrReplace(Name, '\', TargetList[GetNonPersoTarget(target)].PathSep, [rfReplaceAll]);
end;

procedure ApplyFormName(ContainedFile: TContainedFile; Lines : TStrings;
  const target : string);
var
  formName : string;
  formType : string;
  formNameAndType : string;
  incFileName : string;
  openPos : Integer;
  closePos : Integer;
  unitname : string;
  punitname : string;
  formpathname : string;
  S: string;
  ps: Integer;
begin
  formNameAndType := ContainedFile.FormName;
  incFileName := ContainedFile.Name;

  // Do the CLX filename replacements if the target is marked as
  // being a CLX target
  if TargetList[GetNonPersoTarget(target)].IsCLX then
    incFileName := ClxReplacementList.DoReplacement(incFileName);

  unitname := GetUnitName(incFileName);
  punitname := AnsiLowerCase(unitname);
  punitname[1] := CharUpper(punitname[1]);
  formpathname := StrEnsureSuffix(PathSeparator, ExtractFilePath(incFileName))+GetUnitName(incFileName);

  EnsureProperSeparator(formpathname, target);
  EnsureProperSeparator(incfilename, target);

  ps := Pos(':', formNameAndType);
  if ps = 0 then
  begin
    formName := formNameAndType;
    formType := '';
  end
  else
  begin
    formName := Copy(formNameAndType, 1, ps-1);
    formType := Copy(formNameAndType, ps+2, MaxInt);
  end;

  if (formType = '') or (formName = '') then
  begin
    S := Lines.Text;
    openPos := Pos('/*', S);
    if openPos > 0 then
    begin
      closePos := Pos('*/', S);
      Delete(S, openPos, closepos + 2 - openPos);
      Lines.Text := S;
    end;
  end;

  if formName = '' then
  begin
    S := Lines.Text;
    openPos := Pos('{', S);
    if openPos > 0 then
    begin
      closePos := Pos('}', S);
      Delete(S, openPos, closePos + 1 - openPos);
      Lines.Text := S;
    end;
    formName := '';
    formType := '';
    formNameAndType := '';
    formpathname := '';
  end;

  MacroReplaceLines(Lines, '%',
    ['FILENAME%', incFileName,
     'UNITNAME%', unitname,
     'Unitname%', punitname,

     'FORMNAME%', formName,
     'FORMTYPE%', formType,
     'FORMNAMEANDTYPE%', formNameAndType,
     'FORMPATHNAME%', formpathname]);
end;

procedure ExpandTargets(targets : TStrings);
var
  expandedTargets : TStringList;
  i : Integer;
  Alias : TAlias;
begin
  expandedTargets := TStringList.Create;
  try
    // ensure uniqueness in expanded list
    expandedTargets.Sorted := True;
// CaseSensitive doesn't exist in D5 and the default is False anyway
//    expandedTargets.CaseSensitive := False;
    expandedTargets.Duplicates := dupIgnore;

    for i := 0 to targets.Count - 1 do
    begin
      Alias := AliasList[targets[i]];
      if Assigned(Alias) then
        expandedTargets.AddStrings(Alias.ValueAsTStrings)
      else
        expandedTargets.Add(Trim(targets[i]));
    end;

    // assign the values back into the caller
    targets.Clear;
    targets.Assign(expandedTargets);
  finally
    expandedTargets.Free;
  end;
end;

procedure ExpandTargetsNoPerso(targets : TStrings);
var
  i : integer;
begin
  ExpandTargets(targets);
  // now remove "perso" targets
  for i := targets.Count - 1 downto 0 do
    if not Assigned(TargetList.ItemsByName[targets[i]]) then
      targets.Delete(i);
end;

function NowUTC : TDateTime;
var
  sysTime : TSystemTime;
  fileTime : TFileTime;
begin
  Windows.GetSystemTime(sysTime);
  Windows.SystemTimeToFileTime(sysTime, fileTime);
  Result := FileTimeToDateTime(fileTime);
end;

function FilesEqual(const FileName1, FileName2: string): Boolean;
const
  MaxBufSize = 65535;
var
  Stream1, Stream2: TFileStream;
  Buffer1, Buffer2: array[0..MaxBufSize - 1] of Byte;
  BufSize: Integer;
  Size: Integer;
begin
  Result := True;

  Stream1 := nil;
  Stream2 := nil;
  try
    Stream1 := TFileStream.Create(FileName1, fmOpenRead or fmShareDenyWrite);
    Stream2 := TFileStream.Create(FileName2, fmOpenRead or fmShareDenyWrite);

    Size := Stream1.Size;
    if Size <> Stream2.Size then
    begin
      Result := False;
      Exit;     // Note: the finally clause WILL be executed
    end;

    BufSize := MaxBufSize;
    while Size > 0 do
    begin
      if BufSize > Size then
        BufSize := Size;
      Dec(Size, BufSize);

      Stream1.Read(Buffer1[0], BufSize);
      Stream2.Read(Buffer2[0], BufSize);

      Result := CompareMem(@Buffer1[0], @Buffer2[0], BufSize);
      if not Result then
        Exit;    // Note: the finally clause WILL be executed
    end;
  finally
    Stream1.Free;
    Stream2.Free;
  end;
end;

function HasFileChanged(const OutFileName, TemplateFileName: string;
  OutLines: TStrings; TimeStampLine: Integer): Boolean;
var
  CurLines: TStrings;
begin
  Result := True;
  if not FileExists(OutFileName) then
    Exit;

  if OutLines.Count = 0 then
  begin
    // binary file -> compare files
    Result := not FilesEqual(OutFileName, TemplateFileName);
  end
  else
  begin
    // text file -> compare lines
    CurLines := TStringList.Create;
    try
      CurLines.LoadFromFile(OutFileName);