{
$Id: install.pas,v 1.19 2003/04/06 15:56:25 carl Exp $
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 win32}
{$define USE_FPUSRSCR}
{$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}
{$ifdef USE_FPUSRSCR}
FPUsrScr,
{$endif USE_FPUSRSCR}
app,dialogs,views,menus,msgbox,colortxt,tabs,scroll,
WHTMLScn;
const
installerversion='1.0.4';
maxpacks=10;
maxpackages=20;
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 : longint; { diskspace required }
end;
tpack=record
name : string[12];
binsub : string[40];
ppc386 : string[20];
targetname : string[20];
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=packed record
basepath : DirStr;
cfgval : word;
packmask : array[1..maxpacks] of 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;
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 RTrim(const S: string): string;
var
i : longint;
begin
i:=length(s);
while (i>0) and (s[i]=' ') do
dec(i);
RTrim:=Copy(s,1,i);
end;
function LTrim(const S: string): string;
var
i : longint;
begin
i:=1;
while (i<length(s)) and (s[i]=' ') do
inc(i);
LTrim:=Copy(s,i,255);
end;
function Trim(const S: string): string;
begin
Trim:=RTrim(LTrim(S));
end;
function CompareText(S1, S2: string): integer;
var R: integer;
begin
S1:=Upcase(S1);
S2:=Upcase(S2);
if S1<S2 then R:=-1 else
if S1>S2 then R:= 1 else
R:=0;
CompareText:=R;
end;
function ExtOf(const S: string): string;
var D: DirStr; E: ExtStr; N: NameStr;
begin
FSplit(S,D,N,E);
ExtOf:=E;
end;
function DirAndNameOf(const S: string): string;
var D: DirStr; E: ExtStr; N: NameStr;
begin
FSplit(S,D,N,E);
DirAndNameOf:=D+N;
end;
function DirOf(const S: string): string;
var D: DirStr; E: ExtStr; N: NameStr;
begin
FSplit(S,D,N,E);
DirOf:=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,'$1',data.basepath);
Replace(s,'$target',targetname);
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
again,islfn : boolean;
st2,fn,dir,wild : string;
p : pathstr;
n : namestr;
e : extstr;
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);
if CreateLog then
WriteLn (Log, 'File "' + S +
'" missing for the selected installation!');
errorhalt;
end;
{$IFNDEF DLL}
{$IFDEF FPC}
SetUnzipReportProc (@UnzipCheckFn);
{$ELSE FPC}
SetUnzipReportProc (UnzipCheckFn);
{$ENDIF FPC}
{$ENDIF DLL}
if CreateLog then
WriteLn (Log, '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
WriteLn (Log, 'Error ', UnzipErr, ' while unpacking!');
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
if CreateLog then
begin
WriteLn (Log, 'Error while extracting ' +
CurrentFile + ' because of missing LFN support,');
WriteLn (Log, ' skipping rest of ZIP file.');
end;
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
WriteLn (Log, 'Error (' + S + ') while extracting.' + ST2);
if messagebox('Error (' + S + ') while extracting.'+st2+#13+
#13#3'Try again?',nil,mferror+mfyesbutton+mfnobutton)=cmNo then
errorhalt
else
again:=true;
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;
{$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
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;
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;
{$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;
{$ENDIF}
{$ENDIF}
R.Assign(2, YB - 13, 64, YB - 12);
P:=new(pstatictext,init(r,'To compile files enter '''+cfg.pack[1].ppc386+' [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]);
{if not AreAllFilesPresent(zipfile) then}
packmask[j]:=packmask[j] or packagemask(i);
enabmask[j]:=enabmask[j] or packagemask(i);
firstitem[j]:=i;
if createlog then
writeln(log,'Checking lfn usage for ',zipfile,' ... no lfn');
end
else
begin
items[j]:=newsitem(package[i].name+' (requires LFN support)',items[j]);
{packmask[j]:=packmask[j] or packagemask(i);}
enabmask[j]:=enabmask[j] or packagemask(i);
firstitem[j]:=i;
if createlog then
writeln(log,'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);
{if not AreAllFilesPresent(zipfile) then}
enabmask[j]:=enabmask[j] or packagemask(i);
firstitem[j]:=i;
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
WriteLn (Log, '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]=$ffff then
data.packmask[j]:=packmask[j];
packcbs[j]^.enablemask:={$ifdef DEV}$7fffffff{$else}enabmask[j]{$endif};
packcbs[j]^.movedto(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 : longint;
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]:=$ffff;
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
MessageBox ('File ' + package[i].zip +
' is probably corrupted!', nil,
mferror + mfokbutton)
else Inc (DSize, ASpace);
end;
end;
end;
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
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;
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);
if CreateLog then
WriteLn (Log, 'File "' + S + '" 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
writeln('Too many packs');
if CreateLog then
WriteLn (Log, 'Too many packs');
halt(1);
end;
cfg.pack[cfg.packs].name:=s;
end
else
if item='CFGFILE' then
begin
if cfg.packs=0 then
begin
writeln('No pack set');
if CreateLog then
WriteLn (Log, 'No pack set');
halt(1);
end;
cfg.pack[cfg.packs].defcfgfile:=s
end
else
if item='IDECFGFILE' then
begin
if cfg.packs=0 then
begin
writeln('No pack set');
if CreateLog then
WriteLn (Log, 'No pack set');
halt(1);
end;
cfg.pack[cfg.packs].defidecfgfile:=s
end
else
if item='SETPATHFILE' then
begin
if cfg.packs=0 then
begin
writeln('No pack set');
if CreateLog then
WriteLn (Log, 'No pack set');
halt(1);
end;
cfg.pack[cfg.packs].setpathfile:=s
end
else
if item='IDEINIFILE' then
begin
if cfg.packs=0 then
begin
writeln('No pack set');
if CreateLog then
WriteLn (Log, 'No pack set');
halt(1);
end;
cfg.pack[cfg.packs].defideinifile:=s
end
else
if item='PPC386' then
begin
if cfg.packs=0 then
begin
writeln('No pack set');
if CreateLog then
WriteLn (Log, 'No pack set');
halt(1);
end;
cfg.pack[cfg.packs].ppc386:=s;
end
else
if item='BINSUB' then
begin
if cfg.packs=0 then
begin
writeln('No pack set');
if CreateLog then
WriteLn (Log, 'No pack set');
halt(1);
end;
cfg.pack[cfg.packs].binsub:=s;
end
{else: Obsolete PM }
{ if item='FILECHECK' then
begin
if cfg.packs=0 then
begin
writeln('No pack set');
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
writeln('No pack set');
if CreateLog then
WriteLn (Log, 'No pack set');
halt(1);
end;
cfg.pack[cfg.packs].targetname:=s;
end
else
if item='PACKAGE' then
begin
if cfg.packs=0 then
begin
writeln('No pack set');
if CreateLog then
WriteLn (Log, 'No pack set');
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;
dir : searchrec;
one_found : boolean;
filename : string;
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}
var
i : longint;
begin
{$ifdef USE_FPUSRSCR}
InitUserScreen;
if Assigned(UserScreen) then
UserScreen^.SwitchBackToIDEScreen;
{$endif USE_FPUSRSCR}
{ register objects for help streaming }
RegisterWHTMLScan;
{$ifdef FPC}
{$ifdef win32}
Dos.Exec(GetEnv('COMSPEC'),'/C echo This dummy call gets the mouse to become visible');
{$endif win32}
{$endif FPC}
(* TH - no error boxes if checking an inaccessible disk etc. *)
{$IFDEF OS2}
{$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
writeln('FPC Installer Copyright (c) 1993-2002 Florian Klaempfl');
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');
halt(0);
end
else
begin
writeln('Illegal command line parameter: ',paramstr(i));
WriteLn;
writeln('FPC Installer Copyright (c) 1993-2002 Florian Klaempfl');
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');
halt(1);
end;
end;
if createlog then
begin
assign(log,'install.log');
rewrite(log);
{$ifdef MAYBE_LFN}
if not(locallfnsupport) then
writeln(log,'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;
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;
{$ifdef USE_FPUSRSCR}
if Assigned(UserScreen) then
UserScreen^.SwitchToConsoleScreen;
DoneUserScreen;
{$endif USE_FPUSRSCR}
if createlog then
close(log);
end.
{
$Log: install.pas,v $
Revision 1.19 2003/04/06 15:56:25 carl
* Use FPC user screen for Win32 target
Revision 1.18 2003/03/05 21:12:32 hajny
* missing quotes in GO32v2-specific part
Revision 1.17 2003/03/01 16:15:42 hajny
+ logging enhanced
Revision 1.16 2003/02/08 21:49:59 carl
* DOS : fix user screen problem
DOS: emu386 reinstated
Revision 1.15 2003/01/22 14:15:13 pierre
* center all dialogs
Revision 1.14 2003/01/22 13:42:35 pierre
* fix problem with Alt-X (webbug 1959)
+ use fpusrscr unit to restore console at exit.
Revision 1.13 2002/09/07 15:40:59 peter
* old logs removed and tabs fixed
Revision 1.12 2002/07/06 11:51:04 carl
+ Unzip DLL fixes for warnings
Revision 1.11 2002/06/02 17:24:27 marco
* Renamefest
Revision 1.10 2002/06/01 19:43:07 marco
* Renamefest
Revision 1.9 2002/04/11 13:20:27 pierre
+ several go32v2 related fixes
Revision 1.8 2002/04/10 21:18:42 pierre
* explicitly check if one of the files from the list of each package exists
Revision 1.7 2002/04/03 12:46:02 pierre
+ create setpath.bat file if Path is mixed
Revision 1.6 2002/03/19 09:14:56 pierre
* fix fpctoc.html problem
Revision 1.5 2002/03/13 22:27:36 pierre
* fix problem if invalid drive is given
Revision 1.4 2002/02/28 21:30:34 peter
* regenated
Revision 1.3 2002/02/28 17:02:08 pierre
* fix win32 compilation if DEBUG cond is set
Revision 1.2 2002/01/29 22:01:17 peter
* support fvision
Revision 1.1 2002/01/29 17:59:15 peter
* moved installer
}
syntax highlighted by Code2HTML, v. 0.9.1