generateutils.pas

East make Tray Icon in delphi

unit GenerateUtils;

{$I jvcl.inc}

interface

uses
  Classes;

type
  TGenerateCallback = procedure (const msg : string);

// YOU MUST CALL THIS PROCEDURE BEFORE ANY OTHER IN THIS FILE
// AND EVERYTIME YOU CHANGE THE MODEL NAME
// (except Generate as it will call it automatically)
function LoadConfig(const XmlFileName : string; const ModelName : string; var ErrMsg : string) : Boolean;

function Generate(packages : TStrings;
                   targets : TStrings;
                   callback : TGenerateCallback;
                   const XmlFileName : string;
                   const ModelName : string;
                   var ErrMsg : string;
                   path : string = '';
                   prefix : string = '';
                   format : string = '';
                   incFileName : string = ''
                  ) : Boolean;

procedure EnumerateTargets(targets : TStrings);

procedure EnumeratePackages(const Path : string; packages : TStrings);

procedure ExpandTargets(targets : TStrings);

procedure ExpandTargetsNoPerso(targets : TStrings);

function PackagesLocation : string;

var
  StartupDir : string;

implementation

uses
  Windows, SysUtils, ShellApi, Contnrs, FileUtils,
  {$IFDEF NO_JCL}
  UtilsJcl,
  {$ELSE}
  JclDateTime, JclStrings, JclFileUtils, JclSysUtils, JclLogic,
  {$ENDIF NO_JCL}
  JvSimpleXml, PackageInformation, ConditionParser;


type
  TTarget = class (TObject)
  private
    FName   : string;
    FDir    : string;
    FPName  : string;
    FPDir   : string;
    FEnv    : string;
    FVer    : string;
    FDefines: TStringList;
    FPathSep: string;
    FIsCLX  : Boolean;
    function GetDir: string;
    function GetEnv: string;
    function GetPDir: string;
    function GetVer: string;
  public
    constructor Create(Node : TJvSimpleXmlElem); overload;
    destructor Destroy; override;

    property Name   : string      read FName;
    property Dir    : string      read GetDir;
    property PName  : string      read FPName;
    property PDir   : string      read GetPDir;
    property Env    : string      read GetEnv;
    property Ver    : string      read GetVer;
    property Defines: TStringList read FDefines;
    property PathSep: string      read FPathSep;
    property IsCLX  : Boolean     read FIsCLX;
  end;

  TTargetList = class (TObjectList)
  private
    function GetItemsByName(name: string): TTarget;
    function GetItems(index: integer): TTarget;
    procedure SetItems(index: integer; const Value: TTarget);
  public
    constructor Create(Node : TJvSimpleXmlElem); overload;

    property Items[index : integer] : TTarget read GetItems write SetItems;
    property ItemsByName[name : string] : TTarget read GetItemsByName; default;
  end;

  TAlias = class (TObject)
  private
    FValue: string;
    FName: string;
    FValueAsTStrings : TStringList;
    function GetValueAsTStrings: TStrings;
  public
    constructor Create(Node : TJvSimpleXmlElem); overload;
    destructor Destroy; override;

    property Name  : string read FName;
    property Value : string read FValue;
    property ValueAsTStrings : TStrings read GetValueAsTStrings;
  end;

  TAliasList = class (TObjectList)
  private
    function GetItemsByName(name: string): TAlias;
    function GetItems(index: integer): TAlias;
    procedure SetItems(index: integer; const Value: TAlias);
  public
    constructor Create(Node : TJvSimpleXmlElem); overload;

    property Items[index : integer] : TAlias read GetItems write SetItems;
    property ItemsByName[name : string] : TAlias read GetItemsByName; default;
  end;

  TDefine = class (TObject)
  private
    FName: string;
    FIfDefs: TStringList;
  public
    constructor Create(const Name : string; IfDefs : TStringList);
    destructor Destroy; override;

    property Name : string read FName write FName;
    property IfDefs : TStringList read FIfDefs;
  end;

  TDefinesList = class (TObjectList)
  private
    function GetItems(index: integer): TDefine;
    procedure SetItems(index: integer; const Value: TDefine);
  public
    constructor Create(incfile : TStringList); overload;
    function IsDefined(const Condition, Target : string; DefineLimit : Integer = -1): Boolean;

    property Items[index : integer] : TDefine read GetItems write SetItems; default;
  end;

  TClxReplacement = class (TObject)
  private
    FOriginal: string;
    FReplacement: string;
  public
    constructor Create(Node : TJvSimpleXmlElem); overload;
    function DoReplacement(const Filename: string): string;
    property Original  : string read FOriginal;
    property Replacement : string read FReplacement;
  end;

  TClxReplacementList = class (TObjectList)
  private
    IgnoredFiles: TStringList;

    function GetItems(index: integer): TClxReplacement;
    procedure SetItems(index: integer; const Value: TClxReplacement);
  public
    constructor Create(Node : TJvSimpleXmlElem); overload;
    destructor Destroy; override;

    function DoReplacement(const Filename: string): string;

    property Items[index : integer] : TClxReplacement read GetItems write SetItems;
  end;

var
  GCallBack          : TGenerateCallBack;
  GPackagesLocation  : string;
  GIncDefFileName    : string;
  GIncFileName       : string;
  GPrefix            : string;
  GNoLibSuffixPrefix : string;
  GClxPrefix         : string;
  GFormat            : string;
  GNoLibSuffixFormat : string;
  GClxFormat         : string;
  TargetList         : TTargetList;
  AliasList          : TAliasList;
  DefinesList        : TDefinesList;
  ClxReplacementList : TClxReplacementList;
  IsBinaryCache      : TStringList;

function PackagesLocation : string;
begin
  Result := GPackagesLocation;
end;

function IsTrimmedStartsWith(const SubStr, TrimStr: string): Boolean;
var
  l, r, Len, SLen, i: Integer;
begin
  Result := False;

  l := 1;
  r := Length(TrimStr);
  while (l < r) and (TrimStr[l] <= #32) do
    Inc(l);
  while (r > l) and (TrimStr[r] <= #32) do
    Dec(r);
  if r > l then
  begin
    Len := r - l + 1;
    SLen := Length(SubStr);
    if Len >= SLen then
    begin
      Dec(l);
      for i := 1 to SLen do
        if SubStr[i] <> TrimStr[l + i] then
          Exit;
      Result := True;
    end;
  end;
end;

function IsTrimmedString(const TrimStr, S: string): Boolean;
var
  l, r, Len, SLen, i: Integer;
begin
  Result := False;

  l := 1;
  r := Length(TrimStr);
  while (l < r) and (TrimStr[l] <= #32) do
    Inc(l);
  while (r > l) and (TrimStr[r] <= #32) do
    Dec(r);
  if r > l then
  begin
    Len := r - l + 1;
    SLen := Length(S);
    if Len = SLen then
    begin
      Dec(l);
      for i := 1 to SLen do
        if S[i] <> TrimStr[l + i] then
          Exit;
      Result := True;
    end;
  end;
end;

function StartsWith(const SubStr, S: string): Boolean;
var
  i, Len: Integer;
begin
  Result := False;
  len := Length(SubStr);
  if Len <= Length(S) then
  begin
    for i := 1 to Len do
      if SubStr[i] <> S[i] then
        Exit;
    Result := True;
  end;
end;

procedure StrReplaceLines(Lines: TStrings; const Search, Replace: AnsiString);
var
  i: Integer;
  S: string;
begin
  for i := 0 to Lines.Count - 1 do
  begin
    S := Lines[i];
    if Pos(Search, S) > 0 then
    begin
      StrReplace(S, Search, Replace, [rfReplaceAll]);
      Lines[i] := S;
    end;
  end;
end;

function MacroReplace(var Text: string; MacroChar: Char;
  const Macros: array of string; CaseSensitive: Boolean = True): Boolean;
const
  Delta = 1024;
var
  Index, i, Count, Len, SLen, MacroHigh: Integer;
  S: string;
  Found: Boolean;
  Cmp: function(const Str1, Str2: PChar; MaxLen: Cardinal): Integer;
begin
  Result := False;
  if CaseSensitive then
    Cmp := StrLComp
  else
    Cmp := StrLIComp;

  MacroHigh := Length(Macros) div 2 - 1;
  Len := Length(Text);
  i := 1;
  SetLength(S, Delta);
  SLen := 0;
  while i <= Len do
  begin
    Count := 0;
   // add normal chars in one step
    while (i <= Len) and (Text[i] <> MacroChar) do
    begin
      Inc(Count);
      Inc(i);
    end;
    if Count > 0 then
    begin
      if SLen + Count > Length(S) then
        SetLength(S, SLen + Count + Delta);
      Move(Text[i - Count], S[SLen + 1], Count);
      Inc(SLen, Count);
    end;

    if i <= Len then
    begin
     // replace macros
      Found := False;
      for Index := 0 to MacroHigh do
      begin
        Count := Length(Macros[Index * 2]);
        if Cmp(PChar(Pointer(Text)) + i, PChar(Macros[Index * 2]), Count) = 0 then
        begin
          Inc(i, Count);
          Count := Length(Macros[Index * 2 + 1]);
          if Count > 0 then
          begin
            if SLen + Count > Length(S) then
              SetLength(S, SLen + Count + Delta);
            Move(Macros[Index * 2 + 1][1], S[SLen + 1], Count);
            Inc(SLen, Count);
          end;
          Result := True;
          Found := True;
          Break;
        end;
      end;
      if not Found then
      begin
        // copy macro-text
        if Macros[0][Length(Macros[0])] = MacroChar then
        begin
          Count := 1;
          while (i + Count <= Len) and (Text[i + Count] <> MacroChar) do
            Inc(Count);
          Inc(Count);
          if SLen + Count > Length(S) then
            SetLength(S, SLen + Count + Delta);
          Move(Text[i], S[SLen + 1], Count);
          Inc(SLen, Count);
          Inc(i, Count - 1);
        end;
      end;
    end;
    Inc(i);
  end;
  SetLength(S, SLen);
  Text := S;
end;

procedure MacroReplaceLines(Lines: TStrings; MacroChar: Char;
  const Macros: array of string; CaseSensitive: Boolean = True);
var
  i: Integer;
  S: string;
begin
  for i := 0 to Lines.Count - 1 do
  begin
    S := Lines[i];
    if MacroReplace(S, MacroChar, Macros, CaseSensitive) then
      Lines[i] := S;
  end;
end;

procedure SendMsg(const Msg : string);
begin
  if Assigned(GCallBack) then
    GCallBack(Msg);
end;

function VerifyModelNode(Node : TJvSimpleXmlElem; var ErrMsg : string) : Boolean;
begin
  // a valid model node must exist
  if not Assigned(Node) then
  begin
    Result := False;
    ErrMsg := 'No ''model'' node found in the ''models'' node.';
    Exit;
  end;

  // it must have a Name property
  if not Assigned(Node.Properties.ItemNamed['name']) then
  begin
    Result := False;
    ErrMsg := 'A ''model'' node must have a ''name'' property.';
    Exit;
  end;

  // it must have a prefix property
  if not Assigned(Node.Properties.ItemNamed['prefix']) then
  begin
    Result := False;
    ErrMsg := 'A ''model'' node must have a ''prefix'' property.';
    Exit;
  end;

  // it must have a format property
  if not Assigned(Node.Properties.ItemNamed['format']) then
  begin
    Result := False;
    ErrMsg := 'A ''model'' node must have a ''format'' property.';
    Exit;
  end;

  // it must have a packages property
  if not Assigned(Node.Properties.ItemNamed['packages']) then
  begin
    Result := False;
    ErrMsg := 'A ''model'' node must have a ''packages'' property.';
    Exit;
  end;

  // it must have a incfile property
  if not Assigned(Node.Properties.ItemNamed['incfile']) then
  begin
    Result := False;
    ErrMsg := 'A ''model'' node must have a ''incfile'' property.';
    Exit;
  end;

  // it must contain Targets
  if not Assigned(Node.Items.ItemNamed['targets']) then
  begin
    Result := False;
    ErrMsg := 'A ''model'' node must contain a ''targets'' node.';
    Exit;
  end;

  // it must contain Aliases
  if not Assigned(Node.Items.ItemNamed['aliases']) then
  begin
    Result := False;
    ErrMsg := 'A ''model'' node must contain a ''aliases'' node.';
    Exit;
  end;

  // if all went ok, then the node is deemed to be valid
  Result := True;
end;

function LoadConfig(const XmlFileName : string; const ModelName : string;
  var ErrMsg : string) : Boolean;
var
  xml : TJvSimpleXml;
  Node : TJvSimpleXmlElem;
  i : integer;
  all : string;
  target : TTarget;
begin
  Result := true;
  FreeAndNil(TargetList);
  FreeAndNil(AliasList);

  // Ensure the xml file exists
  if not FileExists(XmlFileName) then
  begin
    ErrMsg := Format('%s does not exist.', [XmlFileName]);
    Result := False;
    Exit;
  end;

  try
    // read the xml config file
    xml := TJvSimpleXml.Create(nil);
    try
      xml.LoadFromFile(XmlFileName);

      // The xml file must contain the models node
      if not Assigned(xml.Root.Items.itemNamed['models']) then
      begin
        Result := False;
        ErrMsg := 'The root node of the xml file must contain '+
                  'a node called ''models''.';
        Exit;
      end;

      Node := xml.root.Items.itemNamed['models'].items[0];
      if not VerifyModelNode(Node, ErrMsg) then
      begin
        Result := False;
        Exit;
      end;

      for i := 0 to xml.root.Items.itemNamed['models'].items.count - 1 do
        if xml.root.Items.itemNamed['models'].items[i].Properties.ItemNamed['Name'].value = ModelName then
          Node := xml.root.Items.itemNamed['models'].items[i];

      if not VerifyModelNode(Node, ErrMsg) then
      begin
        Result := False;
        Exit;
      end;

      TargetList := TTargetList.Create(Node.Items.ItemNamed['targets']);
      AliasList  := TAliasList.Create(Node.Items.ItemNamed['aliases']);
      ClxReplacementList  := TClxReplacementList.Create(Node.Items.ItemNamed['ClxReplacements']);

      if Assigned(Node.Properties.ItemNamed['incdeffile']) then
        GIncDefFileName   := Node.Properties.ItemNamed['incdeffile'].Value;
      GIncFileName      := Node.Properties.ItemNamed['IncFile'].Value;
      GPackagesLocation := Node.Properties.ItemNamed['packages'].Value;
      GFormat           := Node.Properties.ItemNamed['format'].Value;
      GPrefix           := Node.Properties.ItemNamed['prefix'].Value;

      GNoLibSuffixPrefix  := GPrefix;
      GClxPrefix          := GPrefix;
      GNoLibSuffixFormat  := GFormat;
      GClxFormat          := GFormat;