unit uROIDEPrjWizard_laz;

{----------------------------------------------------------------------------}
{ RemObjects SDK Library - Delphi IDE Integration                            }
{                                                                            }
{ compiler: Delphi 5 and up                                                  }
{ platform: Win32                                                            }
{                                                                            }
{ (c)opyright RemObjects Software. all rights reserved.                      }
{                                                                            }
{ Using this code requires a valid license of the RemObjects SDK             }
{ which can be obtained at http://www.remobjects.com.                        }
{----------------------------------------------------------------------------}

{$IFNDEF MSWINDOWS}
{$I ../RemObjects.inc}
{$ELSE}
{$I ..\RemObjects.inc}
{$ENDIF}

interface

uses {$IFDEF MSWINDOWS}Windows,{$ENDIF}Forms, SysUtils, Graphics, ProjectIntf;

const
  IconName = 'Icon.ico';
  InfoName = 'Info.ini';

  sect_Information = 'Information';
  sect_ClassFactories = 'Class Factories';
  sect_ProjectGeneration = 'Project Generation';
  sect_ProjectFolderHistory = 'Project Folder History';

  id_Name = 'Name';
  id_Description = 'Description';
  id_MinVersion = 'MinimumVersion';
  id_MaxVersion = 'MaximumVersion';
  id_InvalidServers = 'InvalidServers';
  id_DefaultServer = 'DefaultServer';
  id_FixedChannel = 'FixedChannel';
  id_FixedServer = 'FixedServer';

  id_SvcLibName = 'SvcLibName';
  id_SvcName = 'SvcName';
  id_PrjName = 'PrjName';
  id_PrjDir = 'PrjDir';
  id_cbSvcInstantMode = 'cbSvcInstantMode';
  id_CreateClientAndGroup = 'CreateClientAndGroup';

  id_WizardType = 'Wizard';

  LazarusModules: array[0..6] of string =
      ('.lpk', '.pas', '.rodl', '.xml', '.lfm', '.lrs', '.pp');

type { TROIDEProjectOptions }
  TROIDEProjectOptions = record
    TemplateDir,
      ServiceLibraryName,
      ServiceName,
      ProjectDir,
      ProjectName,
      ServerClassName,
      ServerUnitName,
      ChannelClassName,
      ChannelUnitName,
      MessageClassName,
      MessageUnitName: string;
      CreateClientAndGroup: boolean;
      WizardEnabled: boolean;
  end;

  TROIDENewProjectInfo = record
    Wizard: string;
    ServerProject,ClientProject: TLazProject;
    ProjectOptions: TROIDEProjectOptions;
    TemplateFolder: string;
    TemplateName: string;
  end;
  TNewProjectEvent = procedure(aNewProjectInfo: TROIDENewProjectInfo);

  { TROProjectWizard }
  TROProjectWizard = class(TForm)
  private
    fTemplateDir,
    fComment,
    fName,
    fPage: string;
    procedure CreateProject(const someProjectOptions: TROIDEProjectOptions;
      const ScanExtensions: array of string);
    function ReplaceCtrlStrings(const someText: string;
      const someProjectOptions: TROIDEProjectOptions): string;

  protected
    { support for IOTAWizard }
    function GetIDString: string;
    procedure Execute;
    { support for IOTARepositoryWizard }
    function GetAuthor: string;
    function GetComment: string;
    function GetPage: string;
    function GetGlyph: Cardinal;
  public
    constructor Create(const aTemplateDir, aName, aComment: string; aCategory: string);
    destructor Destroy; override;
  end;

procedure Register;
procedure RunGuideWizard(aNewProjectInfo: TROIDENewProjectInfo);
procedure RegisterGuideWizard(aOnNewProject: TNewProjectEvent);
procedure UnregisterGuideWizard(aOnNewProject: TNewProjectEvent);

implementation

uses ComObj, Classes, Dialogs,  Controls, uRORes, uRODL, uRODLGenTools, INIFiles, fNewProjectForm,
  Menus, uROIDETools_laz, uROClasses, Registry, Contnrs;

procedure Register;
var
  dirinfo: TSearchRec;
  templdirname,
  templname,
  templcomment: string;
  ini: TIniFile;
  tmpcnt: integer;
  thisver, minver, maxver: integer;
  lTemplateDir: string;

  procedure ProcessTemplates(aTemplateFolder: string; aCategory: string);
  begin
    if (FindFirst(IncludeTrailingPathDelimiter(aTemplateFolder) + {$IFNDEF MSWINDOWS} '*'{$ELSE} '*.*'{$ENDIF}, faDirectory, dirinfo) = 0) then try
      repeat
        ini := nil;

        try
          if (dirinfo.Attr and faDirectory = 0) or
            (Pos('.', dirinfo.Name) = 1) or
            (Pos('_', dirinfo.Name) = 1) then Continue;

          templdirname := IncludeTrailingPathDelimiter(IncludeTrailingPathDelimiter(aTemplateFolder) + dirinfo.Name);
          if not FileExists(templdirname + InfoName) then Continue;

          ini := TIniFile.Create(templdirname + InfoName);
          minver := ini.ReadInteger(sect_Information, id_MinVersion, {$IFNDEF MSWINDOWS}10{$ELSE}5{$ENDIF});
          maxver := ini.ReadInteger(sect_Information, id_MaxVersion, 1000);
          templname := ini.ReadString(sect_Information, id_Name, '???');
          templcomment := ini.ReadString(sect_Information, id_Description, '???');

          if thisver < minver then Continue;
          if thisver > maxver then Continue;

          RegisterPackageWizard(TROProjectWizard.Create(templdirname, templname, templcomment, aCategory) as IOTAProjectWizard);
          Inc(tmpcnt);

        finally
          ini.Free;
        end;

      until (FindNext(dirinfo) <> 0);
    finally
      FindClose(dirinfo);
    end;
  end;

begin
  {$IFDEF DELPHI5}
  thisver := 5;
  {$ENDIF}
  {$IFDEF DELPHI6}
  thisver := 6;
  {$ENDIF}
  {$IFDEF DELPHI7}
  thisver := 7;
  {$ENDIF}
  {$IFDEF DELPHI9}
  thisver := 9;
  {$ENDIF}
  {$IFDEF DELPHI10}
  thisver := 10;
  {$ENDIF}

  lTemplateDir := IncludeTrailingPathDelimiter(GetTemplateDir);

  tmpcnt := 0;

  if DirectoryExists(lTemplateDir+'RO') then begin
    ProcessTemplates(lTemplateDir+'RO','RemObjects SDK');
  end;
  if DirectoryExists(lTemplateDir+'DA') then begin
    ProcessTemplates(lTemplateDir+'DA', 'RemObjects Data Abstract');
  end;

  // Status message just in case
  if (tmpcnt = 0) then
    MessageDlg('No RemObject server templates were found under ' + GetTemplateDir, mtWarning, [mbOK], 0)
end;

{ TROProjectWizard }


constructor TROProjectWizard.Create(const aTemplateDir, aName, aComment: string; aCategory: string);
begin
  inherited Create(nil);

  fName := aName;
  fTemplateDir := aTemplateDir;
  fComment := aComment;
  fPage := aCategory;
end;

destructor TROProjectWizard.Destroy;
begin
  inherited;
end;

procedure TROProjectWizard.Execute;
var
  prjopt: TROIDEProjectOptions;
  lNewProjectInfo: TROIDENewProjectInfo;
  i:integer;
  lServices: IOTAModuleServices;
  lProject: IOTAProject;
begin
  if PromptProjectOptions(fTemplateDir, prjopt) then begin
    CreateProject(prjopt, LazarusModules);

    with prjopt do begin
      if FileExists(ProjectDir + ProjectName + 'Group.bpg') and prjopt.CreateClientAndGroup then
        (BorlandIDEServices as IOTAActionServices).OpenProject(ProjectDir + ProjectName + 'Group.bpg', FALSE)

      else if FileExists(ProjectDir + ProjectName + '.dpr') then
        (BorlandIDEServices as IOTAActionServices).OpenProject(ProjectDir + ProjectName + '.dpr', FALSE)
      else
        raise Exception.Create('Cannot find RemObjects project');

      // find projects
      lServices := ModuleServices;
      if not assigned(lServices) then exit;
      for i := 0 to (lServices.ModuleCount - 1) do begin
        if lServices.Modules[i].QueryInterface(IOTAProject, lProject) = S_OK then begin
          if ChangeFileExt(ExtractFileName(lProject.FileName),'') = prjopt.ProjectName then begin
            lNewProjectInfo.ServerProject := lProject;
          end
          else if ChangeFileExt(ExtractFileName(lProject.FileName),'') = prjopt.ProjectName+'Client' then begin
            lNewProjectInfo.ClientProject := lProject;
          end;
        end;
      end;
      if not assigned(lNewProjectInfo.ServerProject) then exit;

      if WizardEnabled then begin
        with TMemIniFile.Create(IncludeTrailingPathDelimiter(prjopt.TemplateDir)+'Info.ini') do try
          lNewProjectInfo.Wizard := ReadString('Information', 'Wizard', '');
          if lNewProjectInfo.Wizard <> '' then begin
            lNewProjectInfo.TemplateFolder := fTemplateDir;
            lNewProjectInfo.TemplateName := ExtractFileName(ExcludeTrailingPathDelimiter(fTemplateDir));
            lNewProjectInfo.ProjectOptions := prjopt;
            RunGuideWizard(lNewProjectInfo);
          end;
        finally
          Free();
        end;
      end;

      {if (MessageDlg(
        'Your server project needs to be compiled in order to generate the additional units' + #13 +
        'required for remote invocation. Do you want to do that now?', mtInformation, [mbYes, mbNo], 0) = mrYes) then begin
        CompileProject;
      end;}
    end;
  end;
end;

procedure TROProjectWizard.CreateProject(const someProjectOptions: TROIDEProjectOptions; const ScanExtensions: array of string);
var
  lIgnoreAll: boolean;

  function CanWriteFile(const aFilename: string): boolean;
  begin
    result := (not FileExists(aFileName)) or lIgnoreAll;
    if not result then begin
      case MessageDlg(Format('File %s already exists. Overwrite?', [aFileName]), mtWarning, [mbYes, mbYesToAll, mbNo, mbCancel], 0) of
        mrYes: result := true;
        mrYesToAll: begin
            result := true;
            lIgnoreAll := true;
          end;
        mrCancel: Abort();
      end;
    end;
  end;

  function CopyTemplateFiles(const SourceDir: string):boolean;
  var
    s, d, templatedir: string;
    dirinfo: TSearchRec;
    sl: TStringList;
    i: integer;
    docopy: boolean;
  begin
    result := true;
    sl := TStringList.Create;
    templatedir := IncludeTrailingPathDelimiter(SourceDir);
    try

      if (FindFirst(templatedir + '*.*', faArchive, dirinfo) = 0) then try
        ForceDirectories(someProjectOptions.ProjectDir);
        repeat
          if (CompareText(dirinfo.Name, IconName) = 0) or
            (CompareText(dirinfo.Name, InfoName) = 0) then Continue;

          s := templatedir + dirinfo.Name;
          d := someProjectOptions.ProjectDir + ReplaceCtrlStrings(dirinfo.Name, someProjectOptions);

          docopy := TRUE;
          for i := 0 to High(ScanExtensions) do
            if (CompareText(ExtractFileExt(dirinfo.Name), ScanExtensions[i]) = 0) then begin

              if not CanWriteFile(d) then Continue;

              sl.LoadFromFile(s);
              sl.Text := ReplaceCtrlStrings(sl.Text, someProjectOptions);
              sl.SaveToFile(d);

              if SameText(ExtractFileExt(s),'.rodl') then result := false;

              docopy := FALSE;
              Break;
            end;

          if docopy then begin
            if CanWriteFile(d) then begin
              CopyFile(PChar(s), PChar(d), FALSE);
            { Make sure copied files are not readonly, which they might be
              if TEMPLATES folder is. }
              SetFileAttributes(PChar(d), FILE_ATTRIBUTE_ARCHIVE);
            end;
          end;

        until (FindNext(dirinfo) <> 0);
      finally
        FindClose(dirinfo);
      end;
    finally
      sl.Free;
    end;
  end;

var
  lNeedsRodl: boolean;
  lClientFolder: string;
begin
  lNeedsRodl := CopyTemplateFiles(someProjectOptions.TemplateDir);
  if lNeedsRodl then CopyTemplateFiles(GetTemplateDir);

  if someProjectOptions.CreateClientAndGroup then begin
    lClientFolder := IncludeTrailingPathDelimiter(someProjectOptions.TemplateDir)+'_CLIENT';
    if not DirectoryExists(lClientFolder) then
      lClientFolder := IncludeTrailingPathDelimiter(GetTemplateDir)+'_CLIENT';
    CopyTemplateFiles(lClientFolder);
  end;
end;

function GuidReplace(const S, OldPattern: string; Flags: TReplaceFlags): string;
var
  SearchStr, Patt, NewStr: string;
  Offset: Integer;
begin
  if rfIgnoreCase in Flags then begin
    SearchStr := UpperCase(S);
    Patt := UpperCase(OldPattern);
  end
  else begin
    SearchStr := S;
    Patt := OldPattern;
  end;
  NewStr := S;
  Result := '';
  while SearchStr <> '' do begin
    Offset := AnsiPos(Patt, SearchStr);
    if Offset = 0 then begin
      Result := Result + NewStr;
      Break;
    end;
    Result := Result + Copy(NewStr, 1, Offset - 1) + NewGuidAsString();
    NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt);
    if not (rfReplaceAll in Flags) then begin
      Result := Result + NewStr;
      Break;
    end;
    SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt);
  end;
end;

function TROProjectWizard.ReplaceCtrlStrings(const someText: string; const someProjectOptions: TROIDEProjectOptions): string;
var
  cs: string;
  lRoFolder, lDaFolder:string;
begin
  cs := UpperCase(someText);
  with TRegistry.Create do try
    RootKey := HKEY_CURRENT_USER;
    OpenKey('\Software\RemObjects\RemObjects SDK for Delphi',false);
    lRoFolder := ReadString('InstallDir');
    OpenKey('\Software\RemObjects\Data Abstract',false);
    lDaFolder := ReadString('InstallDir');
  finally
    Free();
  end;
  if lRoFolder = '' then lRoFolder := ExpandFileName(IncludeTrailingPathDelimiter(GetBinDir)+'..\');
  if lDaFolder = '' then lDaFolder := ExpandFileName(IncludeTrailingPathDelimiter(GetBinDir)+'..\..\Data Abstract\');
  lRoFolder := IncludeTrailingPathDelimiter(lRoFolder);
  lDaFolder := IncludeTrailingPathDelimiter(lDaFolder);

  result := StringReplace(someText, '$ROFOLDER', lRoFolder , [rfReplaceAll, rfIgnoreCase]);
  result := StringReplace(someText, '$DAFOLDER', lDaFolder , [rfReplaceAll, rfIgnoreCase]);
  result := StringReplace(result, '$PRJNAME', someProjectOptions.ProjectName, [rfReplaceAll, rfIgnoreCase]);
  result := StringReplace(result, '$SVCNAME', someProjectOptions.ServiceName, [rfReplaceAll, rfIgnoreCase]);
  result := StringReplace(result, '$SERVICENAME', someProjectOptions.ServiceName, [rfReplaceAll, rfIgnoreCase]);
  result := StringReplace(result, '$SVCLIBNAME', someProjectOptions.ServiceLibraryName, [rfReplaceAll, rfIgnoreCase]);
  result := StringReplace(result, '$LIBRARYNAME', someProjectOptions.ServiceLibraryName, [rfReplaceAll, rfIgnoreCase]);
  result := GuidReplace(result, '$NEWID', [rfReplaceAll, rfIgnoreCase]);
  result := StringReplace(result, '$MSGCLSNAME', someProjectOptions.MessageClassName, [rfReplaceAll, rfIgnoreCase]);
  result := StringReplace(result, '$MSGCLSNAME', someProjectOptions.MessageClassName, [rfReplaceAll, rfIgnoreCase]);
  result := StringReplace(result, '$SRVCLSNAME', someProjectOptions.ServerClassName, [rfReplaceAll, rfIgnoreCase]);
  result := StringReplace(result, '$CHNCLSNAME', someProjectOptions.ChannelClassName, [rfReplaceAll, rfIgnoreCase]);

  result := StringReplace(result, '$CHANNELUNIT', someProjectOptions.ChannelUnitName, [rfReplaceAll, rfIgnoreCase]);
  result := StringReplace(result, '$SERVERUNIT', someProjectOptions.ServerUnitName, [rfReplaceAll, rfIgnoreCase]);
  result := StringReplace(result, '$MESSAGEUNIT', someProjectOptions.MessageUnitName, [rfReplaceAll, rfIgnoreCase]);
end;

function TROProjectWizard.GetAuthor: string;
begin
  Result := str_Author;
end;

function TROProjectWizard.GetComment: string;
begin
  Result := fComment
end;

function TROProjectWizard.GetGlyph: Cardinal;
var
  icon: TIcon;
begin
  if FileExists(fTemplateDir + IconName) then begin
    icon := TIcon.Create;
    icon.LoadFromFile(fTemplateDir + IconName);
    result := icon.Handle;
  end
  else
    result := 0;
end;

function TROProjectWizard.GetIDString: string;
begin
  Result := GUIDToString(NewGUID)
end;

function TROProjectWizard.GetPage: string;
begin
  Result := fPage;
end;

var
  fGuideWizardList: TList;

procedure RunGuideWizard(aNewProjectInfo: TROIDENewProjectInfo);
var
  i: integer;
begin
  for i := 0 to fGuideWizardList.Count-1 do
    TNewProjectEvent(fGuideWizardList[i])(aNewProjectInfo);
end;

procedure RegisterGuideWizard(aOnNewProject: TNewProjectEvent);
begin
  fGuideWizardList.Add(@aOnNewProject);
end;

procedure UnregisterGuideWizard(aOnNewProject: TNewProjectEvent);
begin
  if assigned(fGuideWizardList) then
    fGuideWizardList.Remove(@aOnNewProject);
end;

initialization
  fGuideWizardList := TList.Create();
finalization
  FreeAndNil(fGuideWizardList);
end.