mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-11-04 00:19:39 +01:00
2028 lines
58 KiB
ObjectPascal
2028 lines
58 KiB
ObjectPascal
{
|
|
This file is part of the Free Pascal run time library.
|
|
Copyright (c) 1993-98 by Florian Klaempfl
|
|
member of the Free Pascal development team
|
|
|
|
This is the install program for the DOS and OS/2 versions of Free Pascal
|
|
|
|
See the file COPYING.FPC, included in this distribution,
|
|
for details about the copyright.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
|
|
|
**********************************************************************}
|
|
program install;
|
|
|
|
{ $DEFINE DLL} (* TH - if defined, UNZIP32.DLL library is used to unpack. *)
|
|
{ $DEFINE DOSSTUB} (* TH - should _not_ be defined unless creating a bound DOS and OS/2 installer!!! *)
|
|
(* Defining DOSSTUB causes adding a small piece of code *)
|
|
(* for starting the OS/2 part from the DOS part of a bound *)
|
|
(* application if running in OS/2 VDM (DOS) window. Used *)
|
|
(* only if compiling with TP/BP (see conditionals below). *)
|
|
|
|
{$IFDEF OS2}
|
|
{$DEFINE DLL}
|
|
{$ENDIF DLL}
|
|
|
|
{$IFDEF VER60}
|
|
{$DEFINE TP}
|
|
{$ENDIF}
|
|
|
|
{$IFDEF VER70}
|
|
{$DEFINE TP}
|
|
{$ENDIF}
|
|
|
|
{$IFNDEF TP}
|
|
{$UNDEF DOSSTUB}
|
|
{$ELSE}
|
|
{$IFDEF OS2}
|
|
{$UNDEF DOSSTUB}
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
|
|
{$IFDEF DPMI}
|
|
{$UNDEF DOSSTUB}
|
|
{$ENDIF}
|
|
|
|
{$ifdef go32v2}
|
|
{$define MAYBE_LFN}
|
|
{$endif}
|
|
|
|
{$ifdef debug}
|
|
{$ifdef win32}
|
|
{$define MAYBE_LFN}
|
|
{$endif win32}
|
|
{$endif debug}
|
|
|
|
{$ifdef TP}
|
|
{$define MAYBE_LFN}
|
|
{$endif}
|
|
|
|
|
|
|
|
uses
|
|
{$IFDEF OS2}
|
|
{$IFDEF FPC}
|
|
DosCalls,
|
|
{$ELSE FPC}
|
|
{$IFDEF VirtualPascal}
|
|
OS2Base,
|
|
{$ELSE VirtualPascal}
|
|
BseDos,
|
|
{$ENDIF VirtualPascal}
|
|
{$ENDIF FPC}
|
|
{$ENDIF OS2}
|
|
{$IFDEF GO32V2}
|
|
emu387,
|
|
{$ENDIF}
|
|
{$ifdef HEAPTRC}
|
|
heaptrc,
|
|
{$endif HEAPTRC}
|
|
strings,dos,objects,drivers,
|
|
{$IFNDEF FVISION}
|
|
commands,
|
|
HelpCtx,
|
|
{$ENDIF}
|
|
unzip,ziptypes,
|
|
{$IFDEF DLL}
|
|
unzipdll,
|
|
{$ENDIF}
|
|
app,dialogs,views,menus,msgbox,colortxt,tabs,scroll,
|
|
WHTMLScn,insthelp;
|
|
|
|
const
|
|
installerversion='2.1.2';
|
|
installercopyright='Copyright (c) 1993-2007 Florian Klaempfl';
|
|
|
|
|
|
maxpacks=30;
|
|
maxpackages=25;
|
|
maxdefcfgs=1024;
|
|
|
|
HTMLIndexExt = '.htx';
|
|
CfgExt = '.dat';
|
|
|
|
MaxStatusPos = 4;
|
|
StatusChars: string [MaxStatusPos] = '/-\|';
|
|
StatusPos: byte = 1;
|
|
{ this variable is set to true if an ide is installed }
|
|
haside : boolean = false;
|
|
hashtmlhelp : boolean = false;
|
|
|
|
{$ifdef Unix}
|
|
DirSep='/';
|
|
{$else}
|
|
DirSep='\';
|
|
{$endif}
|
|
|
|
type
|
|
tpackage=record
|
|
name : string[60];
|
|
zip : string[40]; { default zipname }
|
|
zipshort : string[12]; { 8.3 zipname }
|
|
diskspace : int64; { diskspace required }
|
|
end;
|
|
|
|
tpack=record
|
|
name : string[12];
|
|
binsub : string[40];
|
|
ppc386 : string[20];
|
|
targetname : string[40];
|
|
defidecfgfile,
|
|
defideinifile,
|
|
defcfgfile,
|
|
setpathfile : string[12];
|
|
include : boolean;
|
|
{ filechk : string[40]; Obsolete }
|
|
packages : longint;
|
|
package : array[1..maxpackages] of tpackage;
|
|
end;
|
|
|
|
tcfgarray = array[1..maxdefcfgs] of pstring;
|
|
|
|
cfgrec=record
|
|
title : string[80];
|
|
version : string[20];
|
|
helpidx,
|
|
docsub,
|
|
basepath : DirStr;
|
|
packs : word;
|
|
pack : array[1..maxpacks] of tpack;
|
|
defideinis,
|
|
defidecfgs,
|
|
defcfgs,
|
|
defsetpaths : longint;
|
|
defideini,
|
|
defidecfg,
|
|
defcfg,
|
|
defsetpath : tcfgarray;
|
|
end;
|
|
|
|
datarec=record
|
|
basepath : DirStr;
|
|
cfgval : word;
|
|
packmask : array[1..maxpacks] of sw_word;
|
|
end;
|
|
|
|
punzipdialog=^tunzipdialog;
|
|
tunzipdialog=object(tdialog)
|
|
filetext : pstatictext;
|
|
extractfiletext : pstatictext;
|
|
currentfile : string;
|
|
constructor Init(var Bounds: TRect; ATitle: TTitleStr);
|
|
procedure do_unzip(s,topath:string);
|
|
end;
|
|
|
|
penddialog = ^tenddialog;
|
|
tenddialog = object(tdialog)
|
|
constructor init;
|
|
end;
|
|
|
|
pinstalldialog = ^tinstalldialog;
|
|
tinstalldialog = object(tdialog)
|
|
constructor init;
|
|
procedure handleevent(var event : tevent);virtual;
|
|
end;
|
|
|
|
PFPHTMLFileLinkScanner = ^TFPHTMLFileLinkScanner;
|
|
TFPHTMLFileLinkScanner = object(THTMLFileLinkScanner)
|
|
function CheckURL(const URL: string): boolean; virtual;
|
|
function CheckText(const Text: string): boolean; virtual;
|
|
procedure ProcessDoc(Doc: PHTMLLinkScanFile); virtual;
|
|
end;
|
|
|
|
phtmlindexdialog = ^thtmlindexdialog;
|
|
thtmlindexdialog = object(tdialog)
|
|
text : pstatictext;
|
|
constructor init(var Bounds: TRect; ATitle: TTitleStr);
|
|
end;
|
|
|
|
tapp = object(tapplication)
|
|
procedure initmenubar;virtual;
|
|
procedure handleevent(var event : tevent);virtual;
|
|
procedure do_installdialog;
|
|
procedure readcfg(const fn:string);
|
|
procedure checkavailpack;
|
|
end;
|
|
|
|
PSpecialInputLine= ^TSpecialInputLine;
|
|
TSpecialInputLine = object (TInputLine)
|
|
procedure GetData(var Rec); virtual;
|
|
end;
|
|
|
|
{$IFDEF DOSSTUB}
|
|
PByte = ^byte;
|
|
PRunBlock = ^TRunBlock;
|
|
TRunBlock = record
|
|
Length: word;
|
|
Dependent: word;
|
|
Background: word;
|
|
TraceLevel: word;
|
|
PrgTitle: PChar;
|
|
PrgName: PChar;
|
|
Args: PChar;
|
|
TermQ: longint;
|
|
Environment: pointer;
|
|
Inheritance: word;
|
|
SesType: word;
|
|
Icon: pointer;
|
|
PgmHandle: longint;
|
|
PgmControl: word;
|
|
Column: word;
|
|
Row: word;
|
|
Width: word;
|
|
Height: word;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
var
|
|
installapp : tapp;
|
|
startpath : string;
|
|
successfull : boolean;
|
|
cfg : cfgrec;
|
|
data : datarec;
|
|
CfgName: NameStr;
|
|
DStr: DirStr;
|
|
EStr: ExtStr;
|
|
UnzDlg : punzipdialog;
|
|
log : text;
|
|
createlog : boolean;
|
|
|
|
{$IFNDEF DLL}
|
|
const
|
|
UnzipErr: longint = 0;
|
|
{$ENDIF}
|
|
{$ifdef MAYBE_LFN}
|
|
const
|
|
locallfnsupport : boolean = false;
|
|
{$endif MAYBE_LFN}
|
|
|
|
|
|
{*****************************************************************************
|
|
Helpers
|
|
*****************************************************************************}
|
|
|
|
procedure errorhalt;
|
|
begin
|
|
installapp.done;
|
|
if CreateLog then
|
|
begin
|
|
WriteLn (Log, 'Installation hasn''t been completed.');
|
|
Close (Log);
|
|
end;
|
|
halt(1);
|
|
end;
|
|
|
|
|
|
procedure WriteLog (const S: string);
|
|
begin
|
|
if CreateLog then
|
|
begin
|
|
WriteLn (Log, S);
|
|
Flush (Log);
|
|
end;
|
|
end;
|
|
|
|
function packagemask(i:longint):longint;
|
|
begin
|
|
packagemask:=1 shl (i-1);
|
|
end;
|
|
|
|
|
|
function upper(const s : string):string;
|
|
var
|
|
i : integer;
|
|
begin
|
|
for i:=1 to length(s) do
|
|
if s[i] in ['a'..'z'] then
|
|
upper[i]:=chr(ord(s[i])-32)
|
|
else
|
|
upper[i]:=s[i];
|
|
upper[0]:=s[0];
|
|
end;
|
|
|
|
|
|
procedure Replace(var s:string;const s1,s2:string);
|
|
var
|
|
i : longint;
|
|
begin
|
|
repeat
|
|
i:=pos(s1,s);
|
|
if i>0 then
|
|
begin
|
|
Delete(s,i,length(s1));
|
|
Insert(s2,s,i);
|
|
end;
|
|
until i=0;
|
|
end;
|
|
|
|
|
|
function DotStr(l:longint):string;
|
|
var
|
|
TmpStr : string[32];
|
|
i : longint;
|
|
begin
|
|
Str(l,TmpStr);
|
|
i:=Length(TmpStr);
|
|
while (i>3) do
|
|
begin
|
|
i:=i-3;
|
|
if TmpStr[i]<>'-' then
|
|
Insert('.',TmpStr,i+1);
|
|
end;
|
|
DotStr:=TmpStr;
|
|
end;
|
|
|
|
|
|
function file_exists(const f : string;const path : string) : boolean;
|
|
begin
|
|
file_exists:=fsearch(f,path)<>'';
|
|
end;
|
|
|
|
|
|
function createdir(s:string):boolean;
|
|
var
|
|
s1,start : string;
|
|
err : boolean;
|
|
i : longint;
|
|
begin
|
|
err:=false;
|
|
{$I-}
|
|
getdir(0,start);
|
|
{$ifndef Unix}
|
|
if (s[2]=':') and (s[3]=DirSep) then
|
|
begin
|
|
chdir(Copy(s,1,3));
|
|
Delete(S,1,3);
|
|
end;
|
|
{$endif}
|
|
repeat
|
|
i:=Pos(DirSep,s);
|
|
if i=0 then
|
|
i:=255;
|
|
s1:=Copy(s,1,i-1);
|
|
Delete(s,1,i);
|
|
ChDir(s1);
|
|
if ioresult<>0 then
|
|
begin
|
|
mkdir(s1);
|
|
chdir(s1);
|
|
if ioresult<>0 then
|
|
begin
|
|
err:=true;
|
|
break;
|
|
end;
|
|
end;
|
|
until s='';
|
|
chdir(start);
|
|
{$I+}
|
|
createdir:=err;
|
|
end;
|
|
|
|
|
|
function DiskSpaceN(const zipfile : string) : longint;
|
|
var
|
|
compressed,uncompressed : longint;
|
|
s : string;
|
|
begin
|
|
s:=zipfile+#0;
|
|
if not (IsZip (@S [1])) then
|
|
DiskSpaceN := -1
|
|
else
|
|
begin
|
|
Uncompressed:=UnzipSize(@s[1],compressed);
|
|
DiskSpaceN:=uncompressed shr 10;
|
|
end;
|
|
end;
|
|
|
|
|
|
function diskspacestr(uncompressed : longint) : string;
|
|
begin
|
|
if Uncompressed = -1 then
|
|
DiskSpacestr := ' [INVALID]'
|
|
else
|
|
diskspacestr:=' ('+DotStr(uncompressed)+' KB)';
|
|
end;
|
|
|
|
|
|
function createinstalldir(s : string) : boolean;
|
|
var
|
|
err : boolean;
|
|
dir : searchrec;
|
|
params : array[0..0] of pointer;
|
|
begin
|
|
if s[length(s)]=DirSep then
|
|
dec(s[0]);
|
|
FindFirst(s,AnyFile,dir);
|
|
if doserror=0 then
|
|
begin
|
|
if Dir.Attr and Directory = 0 then
|
|
begin
|
|
messagebox('A file with the name chosen as the installation '+
|
|
'directory exists already. Cannot create this directory!',nil,
|
|
mferror+mfokbutton);
|
|
createinstalldir:=false;
|
|
end else
|
|
createinstalldir:=messagebox('The installation directory exists already. '+
|
|
'Do you want to continue ?',nil,
|
|
mferror+mfyesbutton+mfnobutton)=cmYes;
|
|
exit;
|
|
end;
|
|
err:=Createdir(s);
|
|
if err then
|
|
begin
|
|
params[0]:=@s;
|
|
messagebox('The installation directory %s couldn''t be created',
|
|
@params,mferror+mfokbutton);
|
|
createinstalldir:=false;
|
|
exit;
|
|
end;
|
|
{$ifndef TP}
|
|
{$IFNDEF OS2}
|
|
FindClose (dir);
|
|
{$ENDIF}
|
|
{$endif}
|
|
createinstalldir:=true;
|
|
end;
|
|
|
|
|
|
function GetProgDir: DirStr;
|
|
var
|
|
D: DirStr;
|
|
N: NameStr;
|
|
E: ExtStr;
|
|
begin
|
|
FSplit (FExpand (ParamStr (0)), D, N, E);
|
|
if (D [0] <> #0) and (D [byte (D [0])] = '\') then Dec (D [0]);
|
|
GetProgDir := D;
|
|
end;
|
|
|
|
function GetZipErrorInfo(error : longint) : string;
|
|
var
|
|
ErrorStr : string;
|
|
begin
|
|
case error of
|
|
unzip_CRCErr : GetZipErrorInfo:='CRC error';
|
|
unzip_WriteErr : GetZipErrorInfo:='Write error';
|
|
unzip_ReadErr : GetZipErrorInfo:='Read error';
|
|
unzip_ZipFileErr : GetZipErrorInfo:='ZipFile erroe';
|
|
unzip_UserAbort : GetZipErrorInfo:='User abort';
|
|
unzip_NotSupported : GetZipErrorInfo:='Not supported';
|
|
unzip_Encrypted : GetZipErrorInfo:='File is encrypted';
|
|
unzip_InUse : GetZipErrorInfo:='Fie is in use';
|
|
unzip_InternalError : GetZipErrorInfo:='Internal error'; {Error in zip format}
|
|
unzip_NoMoreItems : GetZipErrorInfo:='No more items';
|
|
unzip_FileError : GetZipErrorInfo:='File error'; {Error Accessing file}
|
|
unzip_NotZipfile : GetZipErrorInfo:='Not a zipfile'; {not a zip file}
|
|
unzip_SeriousError : GetZipErrorInfo:='Serious error'; {serious error}
|
|
unzip_MissingParameter : GetZipErrorInfo:='Missing parameter'; {missing parameter}
|
|
else
|
|
begin
|
|
Str(Error,ErrorStr);
|
|
GetZipErrorInfo:='Unknown error '+errorstr;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{*****************************************************************************
|
|
HTML-Index Generation
|
|
*****************************************************************************}
|
|
var
|
|
indexdlg : phtmlindexdialog;
|
|
|
|
constructor thtmlindexdialog.Init(var Bounds: TRect; ATitle: TTitleStr);
|
|
var
|
|
r : trect;
|
|
begin
|
|
inherited init(bounds,atitle);
|
|
Options:=Options or ofCentered;
|
|
R.Assign (4, 2,bounds.B.X-Bounds.A.X-2, 4);
|
|
text:=new(pstatictext,init(r,'Please wait ...'));
|
|
insert(text);
|
|
end;
|
|
|
|
procedure TFPHTMLFileLinkScanner.ProcessDoc(Doc: PHTMLLinkScanFile);
|
|
|
|
var
|
|
oldtext : pstring;
|
|
begin
|
|
oldtext:=indexdlg^.text^.text;
|
|
indexdlg^.text^.text:=newstr('Processing '+Doc^.GetDocumentURL);
|
|
indexdlg^.text^.drawview;
|
|
inherited ProcessDoc(Doc);
|
|
disposestr(indexdlg^.text^.text);
|
|
indexdlg^.text^.text:=oldtext;
|
|
indexdlg^.text^.drawview;
|
|
end;
|
|
|
|
function TFPHTMLFileLinkScanner.CheckURL(const URL: string): boolean;
|
|
var OK: boolean;
|
|
const HTTPPrefix = 'http:';
|
|
FTPPrefix = 'ftp:';
|
|
begin
|
|
OK:=inherited CheckURL(URL);
|
|
if OK then OK:=DirAndNameOf(URL)<>'';
|
|
if OK then OK:=CompareText(copy(ExtOf(URL),1,4),'.HTM')=0;
|
|
if OK then OK:=CompareText(copy(URL,1,length(HTTPPrefix)),HTTPPrefix)<>0;
|
|
if OK then OK:=CompareText(copy(URL,1,length(FTPPrefix)),FTPPrefix)<>0;
|
|
CheckURL:=OK;
|
|
end;
|
|
|
|
function TFPHTMLFileLinkScanner.CheckText(const Text: string): boolean;
|
|
var OK: boolean;
|
|
S: string;
|
|
begin
|
|
S:=Trim(Text);
|
|
OK:=(S<>'') and (copy(S,1,1)<>'[');
|
|
CheckText:=OK;
|
|
end;
|
|
|
|
procedure writehlpindex(filename : string);
|
|
|
|
var
|
|
LS : PFPHTMLFileLinkScanner;
|
|
BS : PBufStream;
|
|
Re : Word;
|
|
params : array[0..0] of pointer;
|
|
dir : searchrec;
|
|
r : trect;
|
|
|
|
begin
|
|
r.assign(10,10,70,15);
|
|
indexdlg:=new(phtmlindexdialog,init(r,'Creating HTML index file, please wait ...'));
|
|
desktop^.insert(indexdlg);
|
|
{ warning FIXME !!!!, don't know what is to fix here ... PM }
|
|
New(LS, Init(DirOf(FileName)));
|
|
LS^.ProcessDocument(FileName,[soSubDocsOnly]);
|
|
if LS^.GetDocumentCount=0 then
|
|
begin
|
|
params[0]:=@filename;
|
|
MessageBox('Problem creating help index %1, aborting',@params,
|
|
mferror+mfokbutton);
|
|
end
|
|
else
|
|
begin
|
|
FileName:=DirAndNameOf(FileName)+HTMLIndexExt;
|
|
findfirst(filename,AnyFile,dir);
|
|
if doserror=0 then
|
|
begin
|
|
params[0]:=@filename;
|
|
Re:=MessageBox('Help index %s already exists, overwrite it?',@params,
|
|
mfinformation+mfyesbutton+mfnobutton);
|
|
end
|
|
else
|
|
Re:=cmYes;
|
|
if Re<>cmNo then
|
|
begin
|
|
New(BS, Init(FileName, stCreate, 4096));
|
|
if Assigned(BS)=false then
|
|
begin
|
|
MessageBox('Error while writing help index! '+
|
|
'No help index is created',@params,
|
|
mferror+mfokbutton);
|
|
Re:=cmCancel;
|
|
end
|
|
else
|
|
begin
|
|
LS^.StoreDocuments(BS^);
|
|
if BS^.Status<>stOK then
|
|
begin
|
|
MessageBox('Error while writing help index!'#13+
|
|
'No help index is created',@params,
|
|
mferror+mfokbutton);
|
|
Re:=cmCancel;
|
|
end;
|
|
Dispose(BS, Done);
|
|
end;
|
|
end;
|
|
end;
|
|
Dispose(LS, Done);
|
|
desktop^.delete(indexdlg);
|
|
dispose(indexdlg,done);
|
|
end;
|
|
|
|
{*****************************************************************************
|
|
Writing of fpc.cfg
|
|
*****************************************************************************}
|
|
|
|
procedure writedefcfg(const fn:string;const cfgdata : tcfgarray;count : longint;const targetname : string);
|
|
var
|
|
t : text;
|
|
i : longint;
|
|
s : string;
|
|
dir : searchrec;
|
|
params : array[0..0] of pointer;
|
|
d : dirstr;
|
|
n : namestr;
|
|
e : extstr;
|
|
begin
|
|
{ already exists }
|
|
findfirst(fn,AnyFile,dir);
|
|
if doserror=0 then
|
|
begin
|
|
params[0]:=@fn;
|
|
if MessageBox('Config %s already exists, continue writing default config?',@params,
|
|
mfinformation+mfyesbutton+mfnobutton)=cmNo then
|
|
exit;
|
|
end;
|
|
{ create directory }
|
|
fsplit(fn,d,n,e);
|
|
createdir(d);
|
|
{ create the fpc.cfg }
|
|
assign(t,fn);
|
|
{$I-}
|
|
rewrite(t);
|
|
{$I+}
|
|
if ioresult<>0 then
|
|
begin
|
|
params[0]:=@fn;
|
|
MessageBox(#3'A config not written.'#13#3'%s'#13#3'couldn''t be created',@params,mfinformation+mfokbutton);
|
|
exit;
|
|
end;
|
|
for i:=1 to count do
|
|
if assigned(cfgdata[i]) then
|
|
begin
|
|
s:=cfgdata[i]^;
|
|
Replace(s,'%basepath%',data.basepath);
|
|
Replace(s,'%targetname%',targetname);
|
|
if pos('-',targetname)=0 then
|
|
begin
|
|
Replace(s,'%targetos%',targetname);
|
|
Replace(s,'%fpctargetmacro%','$FPCOS')
|
|
end
|
|
else
|
|
begin
|
|
Replace(s,'%targetos%',Copy(targetname,pos('-',targetname)+1,255));
|
|
Replace(s,'%fpctargetmacro%','$FPCTARGET');
|
|
end;
|
|
writeln(t,s);
|
|
end
|
|
else
|
|
writeln(t,'');
|
|
close(t);
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
TUnZipDialog
|
|
*****************************************************************************}
|
|
|
|
constructor tunzipdialog.Init(var Bounds: TRect; ATitle: TTitleStr);
|
|
var
|
|
r : trect;
|
|
begin
|
|
inherited init(bounds,atitle);
|
|
Options:=Options or ofCentered;
|
|
(* R.Assign (11, 4, 38, 6);*)
|
|
R.Assign (1, 4,bounds.B.X-Bounds.A.X-2, 6);
|
|
filetext:=new(pstatictext,init(r,#3'File: '));
|
|
insert(filetext);
|
|
R.Assign (1, 7,bounds.B.X-Bounds.A.X-2, 9);
|
|
extractfiletext:=new(pstatictext,init(r,#3' '));
|
|
insert(extractfiletext);
|
|
end;
|
|
|
|
{$IFNDEF DLL}
|
|
procedure UnzipCheckFn (Retcode: longint; Rec: pReportRec );{$ifdef Delphi32}STDCALL;{$endif}
|
|
{$ifndef fpc}{$IFNDEF BIT32} FAR;{$ENDIF BIT32}{$endif}
|
|
var
|
|
name : string;
|
|
begin
|
|
case Rec^.Status of
|
|
unzip_starting:
|
|
UnzipErr := 0;
|
|
file_starting:
|
|
begin
|
|
with UnzDlg^.extractfiletext^ do
|
|
begin
|
|
Disposestr(text);
|
|
name:=Strpas(Rec^.FileName);
|
|
UnzDlg^.currentfile:=name;
|
|
Text:=NewStr(#3+name);
|
|
DrawView;
|
|
end;
|
|
end;
|
|
file_failure:
|
|
UnzipErr := RetCode;
|
|
file_unzipping:
|
|
begin
|
|
with UnzDlg^.FileText^ do
|
|
begin
|
|
Inc (StatusPos);
|
|
if StatusPos > MaxStatusPos then StatusPos := 1;
|
|
Text^ [Length (Text^)] := StatusChars [StatusPos];
|
|
DrawView;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
procedure tunzipdialog.do_unzip(s,topath : string);
|
|
var
|
|
{$ifdef MAYBE_LFN}
|
|
p : pathstr;
|
|
n : namestr;
|
|
e : extstr;
|
|
islfn : boolean;
|
|
{$endif MAYBE_LFN}
|
|
again : boolean;
|
|
st2,fn,dir,wild : string;
|
|
|
|
begin
|
|
Disposestr(filetext^.text);
|
|
filetext^.Text:=NewStr(#3'File: '+s + #13#3' ');
|
|
filetext^.drawview;
|
|
if not(file_exists(s,startpath)) then
|
|
begin
|
|
messagebox('File "'+s+'" missing for the selected installation. '+
|
|
'Installation hasn''t been completed.',nil,mferror+mfokbutton);
|
|
WriteLog ('File "' + S +
|
|
'" missing for the selected installation!');
|
|
errorhalt;
|
|
end;
|
|
{$IFNDEF DLL}
|
|
{$IFDEF FPC}
|
|
SetUnzipReportProc (@UnzipCheckFn);
|
|
{$ELSE FPC}
|
|
SetUnzipReportProc (UnzipCheckFn);
|
|
{$ENDIF FPC}
|
|
{$ENDIF DLL}
|
|
|
|
WriteLog ('Unpacking ' + AllFiles + ' from '
|
|
+ StartPath + DirSep + S + ' to ' + ToPath);
|
|
repeat
|
|
fn:=startpath+DirSep+s+#0;
|
|
dir:=topath+#0;
|
|
wild:=AllFiles + #0;
|
|
again:=false;
|
|
FileUnzipEx(@fn[1],@dir[1],@wild[1]);
|
|
if (UnzipErr <> 0) and (UnzipErr <> 1) then
|
|
begin
|
|
if CreateLog then
|
|
begin
|
|
WriteLn (Log, 'Error ', UnzipErr, ' while unpacking!');
|
|
Flush (Log);
|
|
end;
|
|
s:=GetZipErrorInfo(UnzipErr);
|
|
{ Str(UnzipErr,s);}
|
|
st2:='';
|
|
if UnzipErr=unzip_WriteErr then
|
|
begin
|
|
{$ifdef MAYBE_LFN}
|
|
if not(locallfnsupport) then
|
|
begin
|
|
islfn:=false;
|
|
fsplit(currentfile,p,n,e);
|
|
if (length(n)>8) or (length(e)>4) or
|
|
(pos('.',n)>0) or (upper(p+n+e)<>upper(currentfile)) then
|
|
islfn:=true;
|
|
if islfn then
|
|
begin
|
|
WriteLog ('Error while extracting ' +
|
|
CurrentFile + ' because of missing LFN support,' +
|
|
LineEnding + ' skipping rest of ZIP file.');
|
|
messagebox('Error while extracting '+currentfile+
|
|
#13#3'because of missing lfn support'+
|
|
#13#3'skipping rest of zipfile '+s
|
|
,nil,mferror+mfOkButton);
|
|
again:=false;
|
|
exit;
|
|
end;
|
|
end
|
|
else
|
|
{$endif MAYBE_LFN}
|
|
st2:=' Disk full?';
|
|
end;
|
|
if CreateLog then
|
|
WriteLog ('Error (' + S + ') while extracting.' + ST2);
|
|
if messagebox('Error (' + S + ') while extracting.'+st2+#13+
|
|
#13#3'Try again?',nil,mferror+mfyesbutton+mfnobutton)=cmYes then
|
|
again:=true
|
|
else
|
|
errorhalt;
|
|
end;
|
|
until not again;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
TEndDialog
|
|
*****************************************************************************}
|
|
|
|
constructor tenddialog.init;
|
|
var
|
|
R : TRect;
|
|
P : PStaticText;
|
|
Control : PButton;
|
|
YB: word;
|
|
{$IFNDEF UNIX}
|
|
i : longint;
|
|
S: string;
|
|
WPath: boolean;
|
|
MixedCasePath: boolean;
|
|
{$ENDIF}
|
|
{$IFDEF OS2}
|
|
ErrPath: array [0..259] of char;
|
|
Handle: longint;
|
|
WLibPath: boolean;
|
|
const
|
|
EMXName: array [1..4] of char = 'EMX'#0;
|
|
BFD2EName: array [1..6] of char = 'BFD2E'#0;
|
|
{$ENDIF}
|
|
begin
|
|
if haside then
|
|
YB := 15
|
|
else
|
|
YB := 14;
|
|
|
|
{$IFNDEF UNIX}
|
|
s:='';
|
|
for i:=1 to cfg.packs do
|
|
if cfg.pack[i].binsub<>'' then
|
|
begin
|
|
if s<>'' then
|
|
s:=s+';';
|
|
S := s+Data.BasePath + Cfg.pack[i].BinSub;
|
|
end;
|
|
if Pos (Upper (S), Upper (GetEnv ('PATH'))) = 0 then
|
|
begin
|
|
WPath := true;
|
|
Inc (YB, 3);
|
|
end
|
|
else
|
|
WPath := false;
|
|
{ look if path is set as Path,
|
|
this leads to problems for mingw32 make PM }
|
|
MixedCasePath:=false;
|
|
for i:=1 to EnvCount do
|
|
begin
|
|
if Pos('PATH=',Upper(EnvStr(i)))=1 then
|
|
if Pos('PATH=',EnvStr(i))<>1 then
|
|
Begin
|
|
MixedCasePath:=true;
|
|
Inc(YB, 2);
|
|
End;
|
|
end;
|
|
{$IFDEF OS2}
|
|
if DosLoadModule (@ErrPath, SizeOf (ErrPath), @EMXName, Handle) = 0 then
|
|
begin
|
|
WLibPath := false;
|
|
DosFreeModule (Handle);
|
|
end
|
|
else
|
|
if DosLoadModule (@ErrPath, SizeOf (ErrPath), @BFD2EName, Handle) = 0 then
|
|
begin
|
|
WLibPath := false;
|
|
DosFreeModule (Handle);
|
|
end
|
|
else
|
|
begin
|
|
WLibPath := true;
|
|
Inc (YB, 2);
|
|
end;
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
|
|
R.Assign(6, 6, 74, YB);
|
|
inherited init(r,'Installation successful.');
|
|
Options:=Options or ofCentered;
|
|
|
|
{$IFNDEF UNIX}
|
|
if WPath then
|
|
begin
|
|
R.Assign(2, 3, 64, 5);
|
|
P:=new(pstatictext,init(r,'Extend your PATH variable with '''+S+''''));
|
|
insert(P);
|
|
end;
|
|
|
|
{$IFDEF OS2}
|
|
if WLibPath then
|
|
begin
|
|
if WPath then
|
|
S := 'and your LIBPATH with ''' + S + '\dll'''
|
|
else
|
|
S := 'Extend your LIBPATH with ''' + S + '\dll''';
|
|
R.Assign (2, YB - 14, 64, YB - 12);
|
|
P := New (PStaticText, Init (R, S));
|
|
Insert (P);
|
|
end;
|
|
{$ELSE OS2}
|
|
if MixedCasePath then
|
|
begin
|
|
R.Assign(2, 5, 64, 6);
|
|
P:=new(pstatictext,init(r,'You need to use setpath.bat file if you want to use Makefiles'));
|
|
insert(P);
|
|
end;
|
|
{$ENDIF OS2}
|
|
{$ENDIF}
|
|
|
|
R.Assign(2, YB - 13, 64, YB - 12);
|
|
P:=new(pstatictext,init(r,'To compile files enter fpc [file]'''));
|
|
insert(P);
|
|
|
|
if haside then
|
|
begin
|
|
R.Assign(2, YB - 12, 64, YB - 10);
|
|
P:=new(pstatictext,init(r,'To start the IDE (Integrated Development Environment) type ''fp'' at a command line prompt'));
|
|
insert(P);
|
|
end;
|
|
|
|
R.Assign (29, YB - 9, 39, YB - 7);
|
|
Control := New (PButton, Init (R,'~O~k', cmOK, bfDefault));
|
|
Insert (Control);
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
TInstallDialog
|
|
*****************************************************************************}
|
|
{$ifdef MAYBE_LFN}
|
|
var
|
|
islfn : boolean;
|
|
|
|
procedure lfnreport( Retcode : longint;Rec : pReportRec );
|
|
|
|
var
|
|
p : pathstr;
|
|
n : namestr;
|
|
e : extstr;
|
|
|
|
begin
|
|
fsplit(strpas(rec^.Filename),p,n,e);
|
|
if (length(n)>8) or (length(e)>4) or
|
|
(pos('.',n)>0) or (upper(p+n+e)<>upper(strpas(rec^.Filename))) then
|
|
islfn:=true;
|
|
end;
|
|
|
|
function haslfn(const zipfile : string) : boolean;
|
|
|
|
var
|
|
buf : array[0..255] of char;
|
|
|
|
begin
|
|
strpcopy(buf,zipfile);
|
|
islfn:=false;
|
|
{$ifdef FPC}
|
|
ViewZip(buf,AllFiles,@lfnreport);
|
|
{$else FPC}
|
|
ViewZip(buf,AllFiles,lfnreport);
|
|
{$endif FPC}
|
|
haslfn:=islfn;
|
|
end;
|
|
{$endif MAYBE_LFN}
|
|
|
|
var
|
|
AllFilesPresent : boolean;
|
|
|
|
procedure presentreport( Retcode : longint;Rec : pReportRec );
|
|
|
|
var
|
|
st : string;
|
|
f : file;
|
|
size,time : longint;
|
|
p : pathstr;
|
|
n : namestr;
|
|
e : extstr;
|
|
|
|
begin
|
|
if not ALLFilesPresent then
|
|
exit;
|
|
st:=Data.BasePath+strpas(rec^.Filename);
|
|
fsplit(st,p,n,e);
|
|
|
|
if not file_exists(n+e,p) then
|
|
AllFilesPresent:=false
|
|
else
|
|
begin
|
|
Assign(f,st);
|
|
Reset(f,1);
|
|
if IOresult<>0 then
|
|
begin
|
|
ALLfilesPresent:=false;
|
|
exit;
|
|
end;
|
|
GetFtime(f,time);
|
|
size:=FileSize(f);
|
|
if (rec^.Time<>time) or (rec^.size<>size) then
|
|
ALLFilesPresent:=false;
|
|
close(f);
|
|
end;
|
|
end;
|
|
|
|
function AreAllFilesPresent(const zipfile : string) : boolean;
|
|
|
|
var
|
|
buf : array[0..255] of char;
|
|
|
|
begin
|
|
strpcopy(buf,zipfile);
|
|
AllFilesPresent:=true;
|
|
{$ifdef FPC}
|
|
ViewZip(buf,AllFiles,@presentreport);
|
|
{$else FPC}
|
|
ViewZip(buf,AllFiles,presentreport);
|
|
{$endif FPC}
|
|
AreAllFilesPresent:=AllFilesPresent;
|
|
end;
|
|
|
|
constructor tinstalldialog.init;
|
|
const
|
|
width = 76;
|
|
height = 20;
|
|
x1 = (79-width) div 2;
|
|
y1 = (23-height) div 2;
|
|
x2 = x1+width;
|
|
y2 = y1+height;
|
|
var
|
|
tabr,tabir,r : trect;
|
|
packmask : array[1..maxpacks] of longint;
|
|
enabmask : array[1..maxpacks] of longint;
|
|
i,line,j : integer;
|
|
items : array[1..maxpacks] of psitem;
|
|
f : pview;
|
|
found : boolean;
|
|
okbut,cancelbut : pbutton;
|
|
firstitem : array[1..maxpacks] of integer;
|
|
packcbs : array[1..maxpacks] of pcheckboxes;
|
|
packtd : ptabdef;
|
|
labpath : plabel;
|
|
ilpath : pspecialinputline;
|
|
tab : ptab;
|
|
titletext : pcoloredtext;
|
|
labcfg : plabel;
|
|
cfgcb : pcheckboxes;
|
|
scrollbox: pscrollbox;
|
|
sbr,sbsbr: trect;
|
|
sbsb: pscrollbar;
|
|
zipfile : string;
|
|
begin
|
|
f:=nil;
|
|
{ walk packages reverse and insert a newsitem for each, and set the mask }
|
|
for j:=1 to cfg.packs do
|
|
with cfg.pack[j] do
|
|
begin
|
|
firstitem[j]:=0;
|
|
items[j]:=nil;
|
|
packmask[j]:=0;
|
|
enabmask[j]:=0;
|
|
for i:=packages downto 1 do
|
|
begin
|
|
zipfile:='';
|
|
if file_exists(package[i].zip,startpath) then
|
|
zipfile:=startpath+DirSep+package[i].zip
|
|
else if file_exists(package[i].zipshort,startpath) then
|
|
begin
|
|
zipfile:=startpath+DirSep+package[i].zipshort;
|
|
{ update package to replace the full zipname with the short name }
|
|
package[i].zip:=package[i].zipshort;
|
|
end;
|
|
if zipfile<>'' then
|
|
begin
|
|
{ get diskspace required }
|
|
package[i].diskspace:=diskspaceN(zipfile);
|
|
{$ifdef MAYBE_LFN}
|
|
if not(locallfnsupport) then
|
|
begin
|
|
if not(haslfn(zipfile)) then
|
|
begin
|
|
items[j]:=newsitem(package[i].name+diskspacestr(package[i].diskspace),items[j]);
|
|
packmask[j]:=packmask[j] or packagemask(i);
|
|
enabmask[j]:=enabmask[j] or packagemask(i);
|
|
firstitem[j]:=i-1;
|
|
WriteLog ('Checking lfn usage for ' + zipfile + ' ... no lfn');
|
|
end
|
|
else
|
|
begin
|
|
items[j]:=newsitem(package[i].name+' (requires LFN support)',items[j]);
|
|
enabmask[j]:=enabmask[j] or packagemask(i);
|
|
firstitem[j]:=i-1;
|
|
WriteLog ('Checking lfn usage for ' + zipfile + ' ... uses lfn');
|
|
end;
|
|
end
|
|
else
|
|
{$endif MAYBE_LFN}
|
|
begin
|
|
items[j]:=newsitem(package[i].name+diskspacestr(package[i].diskspace),items[j]);
|
|
packmask[j]:=packmask[j] or packagemask(i);
|
|
enabmask[j]:=enabmask[j] or packagemask(i);
|
|
firstitem[j]:=i-1;
|
|
end;
|
|
end
|
|
else
|
|
items[j]:=newsitem(package[i].name,items[j]);
|
|
end;
|
|
end;
|
|
|
|
{ If no component found abort }
|
|
found:=false;
|
|
for j:=1 to cfg.packs do
|
|
if packmask[j]<>0 then
|
|
found:=true;
|
|
if not found then
|
|
begin
|
|
messagebox('No components found to install, aborting.',nil,mferror+mfokbutton);
|
|
if CreateLog then
|
|
WriteLog ('No components found to install, aborting.');
|
|
errorhalt;
|
|
end;
|
|
|
|
r.assign(x1,y1,x2,y2);
|
|
inherited init(r,'');
|
|
Options:=Options or ofCentered;
|
|
GetExtent(R);
|
|
R.Grow(-2,-1);
|
|
Dec(R.B.Y,2);
|
|
TabR.Copy(R);
|
|
TabIR.Copy(R);
|
|
TabIR.Grow(-2,-2);
|
|
TabIR.Move(-2,0);
|
|
|
|
{-------- General Sheets ----------}
|
|
R.Copy(TabIR);
|
|
r.move(0,1);
|
|
r.b.x:=r.a.x+40;
|
|
r.b.y:=r.a.y+1;
|
|
new(titletext,init(r,cfg.title,$71));
|
|
|
|
r.move(0,2);
|
|
r.b.x:=r.a.x+40;
|
|
new(labpath,init(r,'~B~ase path',f));
|
|
r.move(0,1);
|
|
r.b.x:=r.a.x+40;
|
|
r.b.y:=r.a.y+1;
|
|
new(ilpath,init(r,high(DirStr)));
|
|
|
|
r.move(0,2);
|
|
r.b.x:=r.a.x+40;
|
|
new(labcfg,init(r,'Con~f~ig',f));
|
|
r.move(0,1);
|
|
r.b.x:=r.a.x+40;
|
|
r.b.y:=r.a.y+1;
|
|
new(cfgcb,init(r,newsitem('create fpc.cfg',nil)));
|
|
data.cfgval:=1;
|
|
|
|
{-------- Pack Sheets ----------}
|
|
for j:=1 to cfg.packs do
|
|
begin
|
|
R.Copy(TabIR);
|
|
if R.A.Y+cfg.pack[j].packages>R.B.Y then
|
|
R.B.Y:=R.A.Y+cfg.pack[j].packages;
|
|
new(packcbs[j],init(r,items[j]));
|
|
if data.packmask[j]=high(sw_word) then
|
|
data.packmask[j]:=packmask[j];
|
|
packcbs[j]^.enablemask:={$ifdef DEV}$7fffffff{$else}enabmask[j]{$endif};
|
|
packcbs[j]^.sel:=firstitem[j];
|
|
end;
|
|
|
|
{--------- Main ---------}
|
|
packtd:=nil;
|
|
sbr.assign(1,3,tabr.b.x-tabr.a.x-3,tabr.b.y-tabr.a.y-1);
|
|
for j:=cfg.packs downto 1 do
|
|
begin
|
|
if (sbr.b.y-sbr.a.y)<cfg.pack[j].packages then
|
|
begin
|
|
sbsbr.assign(sbr.b.x,sbr.a.y,sbr.b.x+1,sbr.b.y);
|
|
New(sbsb, init(sbsbr));
|
|
end
|
|
else
|
|
sbsb:=nil;
|
|
New(ScrollBox, Init(sbr, nil, sbsb));
|
|
PackCbs[j]^.MoveTo(0,0);
|
|
ScrollBox^.Insert(PackCbs[j]);
|
|
|
|
packtd:=NewTabDef(
|
|
cfg.pack[j].name,ScrollBox,
|
|
NewTabItem(sbsb,
|
|
NewTabItem(ScrollBox,
|
|
nil)),
|
|
packtd);
|
|
end;
|
|
|
|
New(Tab, Init(TabR,
|
|
NewTabDef('~G~eneral',IlPath,
|
|
NewTabItem(TitleText,
|
|
NewTabItem(LabPath,
|
|
NewTabItem(ILPath,
|
|
NewTabItem(LabCfg,
|
|
NewTabItem(CfgCB,
|
|
nil))))),
|
|
packtd)
|
|
));
|
|
Tab^.GrowMode:=0;
|
|
|
|
Insert(Tab);
|
|
|
|
line:=tabr.b.y;
|
|
r.assign((width div 2)-18,line,(width div 2)-4,line+2);
|
|
new(okbut,init(r,'~C~ontinue',cmok,bfdefault));
|
|
Insert(OkBut);
|
|
|
|
r.assign((width div 2)+4,line,(width div 2)+14,line+2);
|
|
new(cancelbut,init(r,'~Q~uit',cmcancel,bfnormal));
|
|
Insert(CancelBut);
|
|
|
|
Tab^.Select;
|
|
end;
|
|
|
|
procedure tinstalldialog.handleevent(var event : tevent);
|
|
begin
|
|
if event.what=evcommand then
|
|
if event.command=cmquit then
|
|
begin
|
|
putevent(event);
|
|
event.command:=cmCancel;
|
|
end;
|
|
inherited handleevent(event);
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
TSpecialInputLine
|
|
*****************************************************************************}
|
|
|
|
{ this should use AreAllFilesPresent if the base dir is changed...
|
|
but what if the installer has already choosen which files he wants ... }
|
|
procedure TSpecialInputLine.GetData(var Rec);
|
|
begin
|
|
inherited GetData(Rec);
|
|
end;
|
|
|
|
{*****************************************************************************
|
|
TApp
|
|
*****************************************************************************}
|
|
|
|
const
|
|
cmstart = 1000;
|
|
|
|
procedure tapp.do_installdialog;
|
|
var
|
|
p : pinstalldialog;
|
|
p3 : penddialog;
|
|
r : trect;
|
|
result,
|
|
c : word;
|
|
i,j : longint;
|
|
found : boolean;
|
|
{$ifndef Unix}
|
|
DSize,Space,ASpace : int64;
|
|
S: DirStr;
|
|
{$endif}
|
|
|
|
procedure doconfigwrite;
|
|
|
|
var
|
|
i : longint;
|
|
|
|
begin
|
|
for i:=1 to cfg.packs do
|
|
begin
|
|
if cfg.pack[i].defcfgfile<>'' then
|
|
writedefcfg(data.basepath+cfg.pack[i].binsub+DirSep+cfg.pack[i].defcfgfile,cfg.defcfg,cfg.defcfgs,cfg.pack[i].targetname);
|
|
if cfg.pack[i].setpathfile<>'' then
|
|
writedefcfg(data.basepath+cfg.pack[i].binsub+DirSep+cfg.pack[i].setpathfile,cfg.defsetpath,cfg.defsetpaths,cfg.pack[i].targetname);
|
|
end;
|
|
if haside then
|
|
begin
|
|
for i:=1 to cfg.packs do
|
|
if cfg.pack[i].defidecfgfile<>'' then
|
|
writedefcfg(data.basepath+cfg.pack[i].binsub+DirSep+cfg.pack[i].defidecfgfile,cfg.defidecfg,cfg.defidecfgs,cfg.pack[i].targetname);
|
|
for i:=1 to cfg.packs do
|
|
if cfg.pack[i].defideinifile<>'' then
|
|
writedefcfg(data.basepath+cfg.pack[i].binsub+DirSep+cfg.pack[i].defideinifile,cfg.defideini,cfg.defideinis,cfg.pack[i].targetname);
|
|
if hashtmlhelp then
|
|
writehlpindex(data.basepath+DirSep+cfg.DocSub+DirSep+cfg.helpidx);
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
data.basepath:=cfg.basepath;
|
|
data.cfgval:=0;
|
|
for j:=1 to cfg.packs do
|
|
data.packmask[j]:=high(sw_word);
|
|
|
|
repeat
|
|
{ select components }
|
|
p:=new(pinstalldialog,init);
|
|
c:=executedialog(p,@data);
|
|
if (c=cmok) then
|
|
begin
|
|
if Data.BasePath = '' then
|
|
messagebox('Please, choose the directory for installation first.',nil,mferror+mfokbutton)
|
|
else
|
|
begin
|
|
found:=false;
|
|
for j:=1 to cfg.packs do
|
|
if data.packmask[j]>0 then
|
|
found:=true;
|
|
if found then
|
|
begin
|
|
{$IFNDEF UNIX}
|
|
{ TH - check the available disk space here }
|
|
DSize := 0;
|
|
for j:=1 to cfg.packs do
|
|
with cfg.pack[j] do
|
|
begin
|
|
for i:=1 to packages do
|
|
begin
|
|
if data.packmask[j] and packagemask(i)<>0 then
|
|
begin
|
|
ASpace := package[i].diskspace;
|
|
if ASpace = -1 then
|
|
begin
|
|
MessageBox ('File ' + package[i].zip +
|
|
' is probably corrupted!', nil,
|
|
mferror + mfokbutton);
|
|
WriteLog ('File ' + package[i].zip +
|
|
' is probably corrupted!');
|
|
end
|
|
else Inc (DSize, ASpace);
|
|
end;
|
|
end;
|
|
end;
|
|
WriteLog ('Diskspace needed: ' + DotStr (DSize) + ' Kb');
|
|
|
|
S := FExpand (Data.BasePath);
|
|
if S [Length (S)] = DirSep then
|
|
Dec (S [0]);
|
|
Space := DiskFree (byte (Upcase(S [1])) - 64);
|
|
{ -1 means that the drive is invalid }
|
|
if Space=-1 then
|
|
begin
|
|
WriteLog ('The drive ' + S [1] + ': is not valid');
|
|
if messagebox('The drive '+S[1]+': is not valid. Do you ' +
|
|
'want to change the installation path?',nil,
|
|
mferror+mfyesbutton+mfnobutton) = cmYes then
|
|
Continue;
|
|
Space:=0;
|
|
end;
|
|
Space := Space shr 10;
|
|
WriteLog ('Free space on drive ' + S [1] + ': ' +
|
|
DotStr (Space) + ' Kb');
|
|
|
|
if Space < DSize then
|
|
S := 'is not '
|
|
else
|
|
S := '';
|
|
if (Space < DSize + 500) then
|
|
begin
|
|
if S = '' then
|
|
S := 'might not be ';
|
|
if messagebox('There ' + S + 'enough space on the target ' +
|
|
'drive for all the selected components. Do you ' +
|
|
'want to change the installation path?',nil,
|
|
mferror+mfyesbutton+mfnobutton) = cmYes then
|
|
Continue;
|
|
end;
|
|
{$ENDIF}
|
|
if createinstalldir(data.basepath) then
|
|
break;
|
|
end
|
|
else
|
|
begin
|
|
{ maybe only config }
|
|
if (data.cfgval and 1)<>0 then
|
|
begin
|
|
result:=messagebox('No components selected.'#13#13'Create a configfile ?',nil,
|
|
mfinformation+mfyesbutton+mfnobutton);
|
|
if (result=cmYes) and createinstalldir(data.basepath) then
|
|
doconfigwrite;
|
|
exit;
|
|
end
|
|
else
|
|
begin
|
|
result:=messagebox('No components selected.'#13#13'Abort installation?',nil,
|
|
mferror+mfyesbutton+mfnobutton);
|
|
if result=cmYes then
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
end
|
|
else
|
|
exit;
|
|
until false;
|
|
|
|
{ extract packages }
|
|
for j:=1 to cfg.packs do
|
|
with cfg.pack[j] do
|
|
begin
|
|
r.assign(10,7,70,18);
|
|
UnzDlg:=new(punzipdialog,init(r,'Extracting Packages'));
|
|
desktop^.insert(UnzDlg);
|
|
for i:=1 to packages do
|
|
begin
|
|
if data.packmask[j] and packagemask(i)<>0 then
|
|
begin
|
|
UnzDlg^.do_unzip(package[i].zip,data.basepath);
|
|
{ gather some information about the installed files }
|
|
if copy(package[i].zip,1,3)='ide' then
|
|
haside:=true;
|
|
if copy(package[i].zip,1,7)='doc-htm' then
|
|
begin
|
|
hashtmlhelp:=true;
|
|
{ correct the fpctoc file name if .html files are used }
|
|
if package[i].zip='doc-html.zip' then
|
|
if copy(cfg.helpidx,length(cfg.helpidx)-3,4)='.htm' then
|
|
cfg.helpidx:=cfg.helpidx+'l';
|
|
end;
|
|
end;
|
|
end;
|
|
desktop^.delete(UnzDlg);
|
|
dispose(UnzDlg,done);
|
|
end;
|
|
|
|
{ write config }
|
|
if (data.cfgval and 1)<>0 then
|
|
doconfigwrite;
|
|
|
|
{ show end message }
|
|
p3:=new(penddialog,init);
|
|
executedialog(p3,nil);
|
|
end;
|
|
|
|
|
|
procedure tapp.readcfg(const fn:string);
|
|
var
|
|
t : text;
|
|
i,j,k,
|
|
line : longint;
|
|
item,
|
|
s,hs : string;
|
|
params : array[0..0] of pointer;
|
|
|
|
{$ifndef FPC}
|
|
procedure readln(var t:text;var s:string);
|
|
var
|
|
c : char;
|
|
i : longint;
|
|
begin
|
|
c:=#0;
|
|
i:=0;
|
|
while (not eof(t)) and (c<>#10) do
|
|
begin
|
|
read(t,c);
|
|
if c<>#10 then
|
|
begin
|
|
inc(i);
|
|
s[i]:=c;
|
|
end;
|
|
end;
|
|
if (i>0) and (s[i]=#13) then
|
|
dec(i);
|
|
s[0]:=chr(i);
|
|
end;
|
|
{$endif}
|
|
|
|
begin
|
|
assign(t,StartPath + DirSep + fn);
|
|
{$I-}
|
|
reset(t);
|
|
{$I+}
|
|
if ioresult<>0 then
|
|
begin
|
|
StartPath := GetProgDir;
|
|
assign(t,StartPath + DirSep + fn);
|
|
{$I-}
|
|
reset(t);
|
|
{$I+}
|
|
if ioresult<>0 then
|
|
begin
|
|
params[0]:=@fn;
|
|
messagebox('File %s not found!',@params,mferror+mfokbutton);
|
|
WriteLog ('File "' + fn + '" not found!');
|
|
errorhalt;
|
|
end;
|
|
end;
|
|
line:=0;
|
|
while not eof(t) do
|
|
begin
|
|
readln(t,s);
|
|
inc(line);
|
|
if (s<>'') and not(s[1] in ['#',';']) then
|
|
begin
|
|
i:=pos('=',s);
|
|
if i>0 then
|
|
begin
|
|
item:=upper(Copy(s,1,i-1));
|
|
system.delete(s,1,i);
|
|
if item='VERSION' then
|
|
cfg.version:=s
|
|
else
|
|
if item='TITLE' then
|
|
cfg.title:=s
|
|
else
|
|
if item='BASEPATH' then
|
|
cfg.basepath:=s
|
|
else
|
|
if item='HELPIDX' then
|
|
cfg.helpidx:=s
|
|
else
|
|
if item='DOCSUB' then
|
|
cfg.docsub:=s
|
|
else
|
|
if item='DEFAULTCFG' then
|
|
begin
|
|
repeat
|
|
readln(t,s);
|
|
if upper(s)='ENDCFG' then
|
|
break;
|
|
if cfg.defcfgs<maxdefcfgs then
|
|
begin
|
|
inc(cfg.defcfgs);
|
|
cfg.defcfg[cfg.defcfgs]:=newstr(s);
|
|
end;
|
|
until false;
|
|
end
|
|
else
|
|
if item='DEFAULTIDECFG' then
|
|
begin
|
|
repeat
|
|
readln(t,s);
|
|
if upper(s)='ENDCFG' then
|
|
break;
|
|
if cfg.defidecfgs<maxdefcfgs then
|
|
begin
|
|
inc(cfg.defidecfgs);
|
|
cfg.defidecfg[cfg.defidecfgs]:=newstr(s);
|
|
end;
|
|
until false;
|
|
end
|
|
else
|
|
if item='DEFAULTSETPATH' then
|
|
begin
|
|
repeat
|
|
readln(t,s);
|
|
if upper(s)='ENDCFG' then
|
|
break;
|
|
if cfg.defsetpaths<maxdefcfgs then
|
|
begin
|
|
inc(cfg.defsetpaths);
|
|
cfg.defsetpath[cfg.defsetpaths]:=newstr(s);
|
|
end;
|
|
until false;
|
|
end
|
|
else
|
|
if item='DEFAULTIDEINI' then
|
|
begin
|
|
repeat
|
|
readln(t,s);
|
|
if upper(s)='ENDCFG' then
|
|
break;
|
|
if cfg.defideinis<maxdefcfgs then
|
|
begin
|
|
inc(cfg.defideinis);
|
|
cfg.defideini[cfg.defideinis]:=newstr(s);
|
|
end;
|
|
until false;
|
|
end
|
|
else
|
|
if item='PACK' then
|
|
begin
|
|
inc(cfg.packs);
|
|
if cfg.packs>maxpacks then
|
|
begin
|
|
MessageBox ('Too many packs!', nil,
|
|
mfError + mfOkButton);
|
|
if CreateLog then
|
|
begin
|
|
WriteLn (Log, 'Too many packs');
|
|
close(log);
|
|
end;
|
|
halt(1);
|
|
end;
|
|
cfg.pack[cfg.packs].name:=s;
|
|
end
|
|
else
|
|
if item='CFGFILE' then
|
|
begin
|
|
if cfg.packs=0 then
|
|
begin
|
|
MessageBox ('No pack set found!', nil,
|
|
mfError + mfOkButton);
|
|
if CreateLog then
|
|
begin
|
|
WriteLn (Log, 'No pack set');
|
|
close(Log);
|
|
end;
|
|
halt(1);
|
|
end;
|
|
cfg.pack[cfg.packs].defcfgfile:=s
|
|
end
|
|
else
|
|
if item='IDECFGFILE' then
|
|
begin
|
|
if cfg.packs=0 then
|
|
begin
|
|
MessageBox ('No pack set found!', nil,
|
|
mfError + mfOkButton);
|
|
if CreateLog then
|
|
begin
|
|
WriteLn (Log, 'No pack set');
|
|
Close(Log);
|
|
end;
|
|
halt(1);
|
|
end;
|
|
cfg.pack[cfg.packs].defidecfgfile:=s
|
|
end
|
|
else
|
|
if item='SETPATHFILE' then
|
|
begin
|
|
if cfg.packs=0 then
|
|
begin
|
|
MessageBox ('No pack set found!', nil,
|
|
mfError + mfOkButton);
|
|
if CreateLog then
|
|
begin
|
|
WriteLn (Log, 'No pack set');
|
|
close(Log);
|
|
end;
|
|
halt(1);
|
|
end;
|
|
cfg.pack[cfg.packs].setpathfile:=s
|
|
end
|
|
else
|
|
if item='IDEINIFILE' then
|
|
begin
|
|
if cfg.packs=0 then
|
|
begin
|
|
MessageBox ('No pack set found!', nil,
|
|
mfError + mfOkButton);
|
|
if CreateLog then
|
|
begin
|
|
WriteLn (Log, 'No pack set');
|
|
Close(Log);
|
|
end;
|
|
halt(1);
|
|
end;
|
|
cfg.pack[cfg.packs].defideinifile:=s
|
|
end
|
|
else
|
|
if item='PPC386' then
|
|
begin
|
|
if cfg.packs=0 then
|
|
begin
|
|
MessageBox ('No pack set found!', nil,
|
|
mfError + mfOkButton);
|
|
if CreateLog then
|
|
begin
|
|
WriteLn (Log, 'No pack set');
|
|
Close(Log);
|
|
end;
|
|
halt(1);
|
|
end;
|
|
cfg.pack[cfg.packs].ppc386:=s;
|
|
end
|
|
else
|
|
if item='BINSUB' then
|
|
begin
|
|
if cfg.packs=0 then
|
|
begin
|
|
MessageBox ('No pack set found!', nil,
|
|
mfError + mfOkButton);
|
|
if CreateLog then
|
|
begin
|
|
WriteLn (Log, 'No pack set');
|
|
Close(Log);
|
|
end;
|
|
halt(1);
|
|
end;
|
|
cfg.pack[cfg.packs].binsub:=s;
|
|
end
|
|
{else: Obsolete PM }
|
|
{ if item='FILECHECK' then
|
|
begin
|
|
if cfg.packs=0 then
|
|
begin
|
|
MessageBox ('No pack set found!', nil,
|
|
mfError + mfOkButton);
|
|
if CreateLog then
|
|
WriteLn (Log, 'No pack set');
|
|
halt(1);
|
|
end;
|
|
cfg.pack[cfg.packs].filechk:=s;
|
|
end }
|
|
else
|
|
if item='TARGETNAME' then
|
|
begin
|
|
if cfg.packs=0 then
|
|
begin
|
|
MessageBox ('No pack set found!', nil,
|
|
mfError + mfOkButton);
|
|
if CreateLog then
|
|
begin
|
|
WriteLn (Log, 'No pack set');
|
|
Close(Log);
|
|
end;
|
|
halt(1);
|
|
end;
|
|
cfg.pack[cfg.packs].targetname:=s;
|
|
end
|
|
else
|
|
if item='PACKAGE' then
|
|
begin
|
|
if cfg.packs=0 then
|
|
begin
|
|
MessageBox ('No pack set found!', nil,
|
|
mfError + mfOkButton);
|
|
if CreateLog then
|
|
begin
|
|
WriteLn (Log, 'No pack set');
|
|
Close(Log);
|
|
end;
|
|
halt(1);
|
|
end;
|
|
with cfg.pack[cfg.packs] do
|
|
begin
|
|
j:=pos(',',s);
|
|
if (j>0) and (packages<maxpackages) then
|
|
begin
|
|
inc(packages);
|
|
hs:=copy(s,1,j-1);
|
|
k:=pos('[',hs);
|
|
if (k>0) then
|
|
begin
|
|
package[packages].zip:=Copy(hs,1,k-1);
|
|
package[packages].zipshort:=Copy(hs,k+1,length(hs)-k-1);
|
|
end
|
|
else
|
|
package[packages].zip:=hs;
|
|
package[packages].name:=copy(s,j+1,255);
|
|
end;
|
|
package[packages].diskspace:=-1;
|
|
end;
|
|
end
|
|
end;
|
|
end;
|
|
end;
|
|
close(t);
|
|
end;
|
|
|
|
|
|
procedure tapp.checkavailpack;
|
|
var
|
|
i, j : longint;
|
|
one_found : boolean;
|
|
begin
|
|
{ check the packages }
|
|
j:=0;
|
|
while (j<cfg.packs) do
|
|
begin
|
|
inc(j);
|
|
one_found:=false;
|
|
{if cfg.pack[j].filechk<>'' then}
|
|
for i:=1 to cfg.pack[j].packages do
|
|
begin
|
|
if file_exists(cfg.pack[j].package[i].zip,startpath) or
|
|
file_exists(cfg.pack[j].package[i].zipshort,startpath) then
|
|
begin
|
|
one_found:=true;
|
|
break;
|
|
end;
|
|
end;
|
|
|
|
if not one_found then
|
|
begin
|
|
{ remove the package }
|
|
move(cfg.pack[j+1],cfg.pack[j],sizeof(tpack)*(cfg.packs-j));
|
|
dec(cfg.packs);
|
|
dec(j);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure tapp.initmenubar;
|
|
var
|
|
r : trect;
|
|
begin
|
|
getextent(r);
|
|
r.b.y:=r.a.y+1;
|
|
menubar:=new(pmenubar,init(r,newmenu(
|
|
newsubmenu('Free Pascal Installer',hcnocontext,newmenu(nil
|
|
),
|
|
nil))));
|
|
end;
|
|
|
|
|
|
procedure tapp.handleevent(var event : tevent);
|
|
begin
|
|
inherited handleevent(event);
|
|
if event.what=evcommand then
|
|
if event.command=cmstart then
|
|
begin
|
|
clearevent(event);
|
|
do_installdialog;
|
|
if successfull then
|
|
begin
|
|
event.what:=evcommand;
|
|
event.command:=cmquit;
|
|
handleevent(event);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{$IFDEF DOSSTUB}
|
|
function CheckOS2: boolean;
|
|
var
|
|
OwnName: PathStr;
|
|
OwnDir: DirStr;
|
|
Name: NameStr;
|
|
Ext: ExtStr;
|
|
DosV, W: word;
|
|
P: PChar;
|
|
const
|
|
Title: string [15] = 'FPC Installer'#0;
|
|
RunBlock: TRunBlock = (Length: $32;
|
|
Dependent: 0;
|
|
Background: 0;
|
|
TraceLevel: 0;
|
|
PrgTitle: @Title [1];
|
|
PrgName: nil;
|
|
Args: nil;
|
|
TermQ: 0;
|
|
Environment: nil;
|
|
Inheritance: 0;
|
|
SesType: 2;
|
|
Icon: nil;
|
|
PgmHandle: 0;
|
|
PgmControl: 2;
|
|
Column: 0;
|
|
Row: 0;
|
|
Width: 80;
|
|
Height: 25);
|
|
begin
|
|
CheckOS2 := false;
|
|
asm
|
|
mov ah, 30h
|
|
int 21h
|
|
xchg ah, al
|
|
mov DosV, ax
|
|
mov ax, 4010h
|
|
int 2Fh
|
|
cmp ax, 4010h
|
|
jnz @0
|
|
xor bx, bx
|
|
@0:
|
|
mov W, bx
|
|
end;
|
|
if DosV > 3 shl 8 then
|
|
begin
|
|
OwnName := FExpand (ParamStr (0));
|
|
FSplit (OwnName, OwnDir, Name, Ext);
|
|
if (DosV >= 20 shl 8 + 10) and (W >= 20 shl 8 + 10) then
|
|
(* OS/2 version 2.1 or later running (double-checked) *)
|
|
begin
|
|
OwnName [Succ (byte (OwnName [0]))] := #0;
|
|
RunBlock.PrgName := @OwnName [1];
|
|
P := Ptr (PrefixSeg, $80);
|
|
if PByte (P)^ <> 0 then
|
|
begin
|
|
Inc (P);
|
|
RunBlock.Args := Ptr (PrefixSeg, $81);
|
|
end;
|
|
asm
|
|
mov ax, 6400h
|
|
mov bx, 0025h
|
|
mov cx, 636Ch
|
|
mov si, offset RunBlock
|
|
int 21h
|
|
jc @0
|
|
mov DosV, 0
|
|
@0:
|
|
end;
|
|
CheckOS2 := DosV = 0;
|
|
end;
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
|
|
procedure usagescreen;
|
|
begin
|
|
writeln('FPC Installer ',installerversion,' ',installercopyright);
|
|
writeln('Command line options:');
|
|
writeln(' -l create log file');
|
|
{$ifdef MAYBE_LFN}
|
|
writeln(' --nolfn force installation with short file names');
|
|
{$endif MAYBE_LFN}
|
|
writeln;
|
|
writeln(' -h displays this help');
|
|
end;
|
|
|
|
var
|
|
OldExit: pointer;
|
|
|
|
procedure NewExit;
|
|
begin
|
|
ExitProc := OldExit;
|
|
if CreateLog then
|
|
begin
|
|
{$I-}
|
|
if ErrorAddr <> nil then
|
|
begin
|
|
WriteLn (Log, 'Installer crashed with RTE ', ExitCode);
|
|
Close (Log);
|
|
end
|
|
else
|
|
if ExitCode <> 0 then
|
|
begin
|
|
WriteLn (Log, 'Installer ended with non-zero exit code ', ExitCode);
|
|
Close (Log);
|
|
end
|
|
{$I+}
|
|
end;
|
|
end;
|
|
|
|
|
|
var
|
|
i : longint;
|
|
{ vm : tvideomode;}
|
|
begin
|
|
OldExit := ExitProc;
|
|
ExitProc := @NewExit;
|
|
{ register objects for help streaming }
|
|
RegisterWHTMLScan;
|
|
{$IFDEF OS2}
|
|
{ TH - no error boxes if checking an inaccessible disk etc. }
|
|
{$IFDEF FPC}
|
|
DosCalls.DosError (0);
|
|
{$ELSE FPC}
|
|
{$IFDEF VirtualPascal}
|
|
OS2Base.DosError (ferr_DisableHardErr);
|
|
{$ELSE VirtualPascal}
|
|
BseDos.DosError (0);
|
|
{$ENDIF VirtualPascal}
|
|
{$ENDIF FPC}
|
|
{$ENDIF}
|
|
{$IFDEF DOSSTUB}
|
|
if CheckOS2 then Halt;
|
|
{$ENDIF}
|
|
createlog:=false;
|
|
{$ifdef MAYBE_LFN}
|
|
locallfnsupport:=system.lfnsupport;
|
|
{$endif MAYBE_LFN}
|
|
for i:=1 to paramcount do
|
|
begin
|
|
if paramstr(i)='-l' then
|
|
createlog:=true
|
|
{$ifdef MAYBE_LFN}
|
|
else if paramstr(i)='--nolfn' then
|
|
begin
|
|
locallfnsupport:=false;
|
|
{$ifdef GO32V2}
|
|
{ lfnsupport is a const in win32 RTL }
|
|
system.lfnsupport:=locallfnsupport;
|
|
{$endif GO32V2}
|
|
end
|
|
{$endif MAYBE_LFN}
|
|
else if paramstr(i)='-h' then
|
|
begin
|
|
usagescreen;
|
|
halt(0);
|
|
end
|
|
else
|
|
begin
|
|
usagescreen;
|
|
halt(1);
|
|
end;
|
|
end;
|
|
if createlog then
|
|
begin
|
|
assign(log,'install.log');
|
|
rewrite(log);
|
|
{$ifdef MAYBE_LFN}
|
|
if not(locallfnsupport) then
|
|
WriteLog ('OS doesn''t have LFN support');
|
|
{$endif}
|
|
end;
|
|
getdir(0,startpath);
|
|
successfull:=false;
|
|
|
|
fillchar(cfg, SizeOf(cfg), 0);
|
|
fillchar(data, SizeOf(data), 0);
|
|
|
|
installapp.init;
|
|
{ vm.col:=80;
|
|
vm.row:=25;
|
|
vm.color:=true;
|
|
installapp.SetScreenVideoMode(vm);
|
|
}
|
|
FSplit (FExpand (ParamStr (0)), DStr, CfgName, EStr);
|
|
|
|
installapp.readcfg(CfgName + CfgExt);
|
|
installapp.checkavailpack;
|
|
{ installapp.readcfg(startpath+dirsep+cfgfile);}
|
|
{$ifdef GO32V2}
|
|
if not(lfnsupport) then
|
|
MessageBox('The operating system doesn''t support LFN (long file names),'+
|
|
' so some packages will get shorten filenames when installed',nil,mfinformation or mfokbutton);
|
|
{$endif}
|
|
installapp.do_installdialog;
|
|
installapp.done;
|
|
if createlog then
|
|
close(log);
|
|
end.
|