Free Pascal program to make Lazarus portable (based off the earlier batch script but more versatile)

apputils.pas

unit AppUtils;

{$mode objfpc}{$H+}

interface

uses
  SysUtils;

function CheckDir(path:string):Boolean;
function GetFirstSubdir(path:string): string;
procedure WriteToFile(outputf, text: string);

implementation

function CheckDir(path:string):Boolean;
var
  lazfile: string;
begin
  lazfile := ConcatPaths([path, 'lazarus.exe']);
  Result := DirectoryExists(path) and FileExists(lazfile);
end;

function GetFirstSubdir(path:string): string;
var
  InitialDirectory: string;
  SearchResult: TSearchRec;
begin
  InitialDirectory:=GetCurrentDir; Result := '';
  SetCurrentDir(path);
  if FindFirst('*', faDirectory, SearchResult) = 0 then
  begin
    repeat
      if (LeftStr(SearchResult.Name, 1) <> '.') // filter '.' and '..'
         and ((SearchResult.Attr and faDirectory) = faDirectory) then
      begin
        Result := SearchResult.Name;
        Break;
      end;
    until FindNext(SearchResult) <> 0;
    FindClose(SearchResult);
  end;
  SetCurrentDir(InitialDirectory);
end;

procedure WriteToFile(outputf, text: string);
var
  OutFile: TextFile;
begin
  AssignFile(OutFile, outputf);
  Rewrite(OutFile);
  Write(OutFile, text);
  CloseFile(OutFile);
end;

end.

lazarusportable.lpr

program lazarusportable;

uses sysutils, process, AppUtils;

function GetLazarusDir: string;
var
  Current: string;
begin
  // check current directory first
  Current := GetCurrentDir;
  if CheckDir(Current) then begin
    Result := Current; Exit;
  end;
  // check subdir 'lazarus' (i.e. lazarus/lazarus.exe)
  Current := ConcatPaths([Current, 'lazarus']);
  if CheckDir(Current) then begin
    Result := Current; Exit;
  end;
  // standard PortableApps format (App/lazarus/lazarus.exe)
  // this may need to be moved first for performance
  Current := ConcatPaths([GetCurrentDir, 'App', 'lazarus']);
  if CheckDir(Current) then begin
    Result := Current; Exit;
  end;
  Result := '';
end;

function GetFpcDir(lazPath:string): string;
var
  Current: string;
begin
  Current := ConcatPaths([lazPath, 'fpc']);
  Result := ConcatPaths([Current, GetFirstSubdir(Current)]);
end;

function GetFpcBinDir(fpcPath:string): string;
var
  Current: string;
begin
  Current := ConcatPaths([fpcPath, 'bin']);
  Result := ConcatPaths([Current, GetFirstSubdir(Current)]);
end;

function MakeFpcConfig(fpcPath, fpcBinPath: string): string;
var
  Mkcfg, ProgramOutput: string;
begin
  ProgramOutput:='';
  Mkcfg:=ConcatPaths([fpcBinPath, 'fpcmkcfg']);
  RunCommand(Mkcfg, ['-d', 'basepath=' + fpcPath], ProgramOutput);
  Result := ProgramOutput;
end;

procedure ConfigureFpc(lazPath: string);
var
  fpcPath, fpcBinPath: string;
  fpcConfig: string;
begin
  fpcPath:=GetFpcDir(lazPath);
  fpcBinPath:=GetFpcBinDir(fpcPath);
  fpcConfig:=MakeFpcConfig(fpcPath, fpcBinPath);

  WriteToFile(ConcatPaths([fpcBinPath, 'fpc.cfg']), fpcConfig);
  //Writeln(fpcConfig);
end;

procedure StartLazarus(lazPath: string);
var
  lazExe, cfgDir, CmdLine: string;
begin
  lazExe:=ConcatPaths([lazPath, 'lazarus']);
  cfgDir:=ConcatPaths([lazPath, 'config']);
  CmdLine:='--primary-config-path='+cfgDir+' --lazarusdir='+lazPath;
  ExecuteProcess(lazExe, CmdLine);
end;

var
  lazPath: string;
begin
  lazPath := GetLazarusDir;
  if lazPath = '' then Abort;

  ConfigureFpc(lazPath);
  StartLazarus(lazPath);

//  Readln;
end.