Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Free Pascal program to make Lazarus portable (based off the earlier batch script but more versatile)
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.
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.
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment