mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-10-21 19:05:16 +02:00
984 lines
24 KiB
ObjectPascal
984 lines
24 KiB
ObjectPascal
{
|
||
$Id$
|
||
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 version 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 FV} (* TH - added to make use of the original Turbo Vision possible. *)
|
||
{ $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 VER60}
|
||
{$DEFINE TP}
|
||
{$ENDIF}
|
||
|
||
{$IFDEF VER70}
|
||
{$DEFINE TP}
|
||
{$ENDIF}
|
||
|
||
{$IFDEF OS2}
|
||
{$UNDEF FV}
|
||
{$IFDEF DOSSTUB}
|
||
{$UNDEF DOSSTUB}
|
||
{$ENDIF}
|
||
{$IFDEF VIRTUALPASCAL}
|
||
{$DEFINE DLL}
|
||
{$ENDIF}
|
||
{$ENDIF}
|
||
|
||
{$IFDEF WIN32}
|
||
{$IFDEF DOSSTUB}
|
||
{$UNDEF DOSSTUB}
|
||
{$ENDIF}
|
||
{$ENDIF}
|
||
|
||
{$IFDEF FPC}
|
||
{$IFDEF DOSSTUB}
|
||
{$UNDEF DOSSTUB}
|
||
{$ENDIF}
|
||
{$ENDIF}
|
||
|
||
{$IFDEF DPMI}
|
||
{$IFDEF DOSSTUB}
|
||
{$UNDEF DOSSTUB}
|
||
{$ENDIF}
|
||
{$ENDIF}
|
||
|
||
uses
|
||
{$IFDEF OS2}
|
||
{$IFDEF FPC}
|
||
DosCalls,
|
||
{$ELSE FPC}
|
||
{$IFDEF VirtualPascal}
|
||
OS2Base,
|
||
{$ELSE VirtualPascal}
|
||
BseDos,
|
||
{$ENDIF VirtualPascal}
|
||
{$ENDIF FPC}
|
||
{$ENDIF OS2}
|
||
{$ifdef HEAPTRC}
|
||
heaptrc,
|
||
{$endif HEAPTRC}
|
||
strings,dos,objects,drivers,
|
||
{$IFDEF FV}
|
||
commands,
|
||
{$ENDIF}
|
||
unzip,ziptypes,
|
||
{$IFDEF DLL}
|
||
unzipdll,
|
||
{$ENDIF}
|
||
app,dialogs,views,menus,msgbox;
|
||
|
||
|
||
const
|
||
maxpackages=20;
|
||
maxdefcfgs=1024;
|
||
|
||
cfgfile='install.dat';
|
||
|
||
{$ifdef linux}
|
||
DirSep='/';
|
||
{$else}
|
||
DirSep='\';
|
||
{$endif}
|
||
|
||
type
|
||
tpackage=record
|
||
name : string[60];
|
||
zip : string[12];
|
||
end;
|
||
|
||
cfgrec=record
|
||
title : string[80];
|
||
version : string[20];
|
||
basepath : DirStr;
|
||
binsub : string[12];
|
||
ppc386 : string[12];
|
||
packages : longint;
|
||
package : array[1..maxpackages] of tpackage;
|
||
defcfgfile : string[12];
|
||
defcfgs : longint;
|
||
defcfg : array[1..maxdefcfgs] of pstring;
|
||
end;
|
||
|
||
datarec=packed record
|
||
basepath : DirStr;
|
||
mask : word;
|
||
end;
|
||
|
||
punzipdialog=^tunzipdialog;
|
||
tunzipdialog=object(tdialog)
|
||
filetext : pstatictext;
|
||
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;
|
||
end;
|
||
|
||
tapp = object(tapplication)
|
||
procedure initmenubar;virtual;
|
||
procedure handleevent(var event : tevent);virtual;
|
||
procedure do_installdialog;
|
||
procedure readcfg(const fn:string);
|
||
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;
|
||
|
||
|
||
{*****************************************************************************
|
||
Helpers
|
||
*****************************************************************************}
|
||
|
||
procedure errorhalt;
|
||
begin
|
||
installapp.done;
|
||
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;
|
||
|
||
|
||
(* TH - not needed any more
|
||
function lower(const s : string):string;
|
||
var
|
||
i : integer;
|
||
begin
|
||
for i:=1 to length(s) do
|
||
if s[i] in ['A'..'Z'] then
|
||
lower[i]:=chr(ord(s[i])+32)
|
||
else
|
||
lower[i]:=s[i];
|
||
lower[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 file_exists(const f : string;const path : string) : boolean;
|
||
begin
|
||
file_exists:=fsearch(f,path)<>'';
|
||
end;
|
||
|
||
|
||
function DiskSpaceN(const zipfile : string) : longint;
|
||
var
|
||
compressed,uncompressed : longint;
|
||
s : string;
|
||
begin
|
||
s:=zipfile+#0;
|
||
uncompressed:=UnzipSize(@s[1],compressed);
|
||
DiskSpaceN:=uncompressed shr 10;
|
||
end;
|
||
|
||
|
||
function diskspace(const zipfile : string) : string;
|
||
var
|
||
uncompressed : longint;
|
||
s : string;
|
||
begin
|
||
uncompressed:=DiskSpaceN (zipfile);
|
||
str(uncompressed,s);
|
||
diskspace:=' ('+s+' KB)';
|
||
end;
|
||
|
||
|
||
function createdir(s : string) : boolean;
|
||
var
|
||
start,
|
||
s1 : string;
|
||
i : longint;
|
||
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
|
||
(* TH - check the directory attribute! *)
|
||
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);
|
||
createdir:=false;
|
||
end else
|
||
createdir:=messagebox('The installation directory exists already. '+
|
||
'Do you want to enter a new installation directory ?',nil,
|
||
mferror+mfyesbutton+mfnobutton)=cmNo;
|
||
exit;
|
||
end;
|
||
err:=false;
|
||
{$I-}
|
||
getdir(0,start);
|
||
{$ifndef linux}
|
||
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+}
|
||
if err then
|
||
begin
|
||
params[0]:=@s;
|
||
messagebox('The installation directory %s couldn''t be created',
|
||
@params,mferror+mfokbutton);
|
||
createdir:=false;
|
||
exit;
|
||
end;
|
||
{$ifndef TP}
|
||
{$IFNDEF OS2}
|
||
FindClose (dir);
|
||
{$ENDIF}
|
||
{$endif}
|
||
createdir:=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;
|
||
|
||
|
||
{*****************************************************************************
|
||
Writing of ppc386.cfg
|
||
*****************************************************************************}
|
||
|
||
procedure writedefcfg(const fn:string);
|
||
var
|
||
t : text;
|
||
i : longint;
|
||
s : string;
|
||
dir : searchrec;
|
||
params : array[0..0] of pointer;
|
||
begin
|
||
findfirst(fn,AnyFile,dir);
|
||
if doserror=0 then
|
||
begin
|
||
params[0]:=@fn;
|
||
MessageBox(#3'Default config not written.'#13#3'%s'#13#3'already exists',@params,mfinformation+mfokbutton);
|
||
exit;
|
||
end;
|
||
assign(t,fn);
|
||
{$I-}
|
||
rewrite(t);
|
||
{$I+}
|
||
if ioresult<>0 then
|
||
begin
|
||
params[0]:=@fn;
|
||
MessageBox(#3'Default config not written.'#13#3'%s'#13#3'couldn''t be created',@params,mfinformation+mfokbutton);
|
||
exit;
|
||
end;
|
||
for i:=1 to cfg.defcfgs do
|
||
if assigned(cfg.defcfg[i]) then
|
||
begin
|
||
s:=cfg.defcfg[i]^;
|
||
Replace(s,'$1',data.basepath);
|
||
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);
|
||
R.Assign(11, 4, 38, 5);
|
||
filetext:=new(pstatictext,init(r,'File: '));
|
||
insert(filetext);
|
||
end;
|
||
|
||
|
||
procedure tunzipdialog.do_unzip(s,topath : string);
|
||
var
|
||
fn,dir,wild : string;
|
||
begin
|
||
Disposestr(filetext^.text);
|
||
filetext^.Text:=NewStr('File: '+s);
|
||
filetext^.drawview;
|
||
if not(file_exists(s,startpath)) then
|
||
begin
|
||
messagebox('File: '+s+' missed for the selected installation. '+
|
||
'Installation doesn''t becomes complete',nil,mferror+mfokbutton);
|
||
errorhalt;
|
||
end;
|
||
fn:=startpath+DirSep+s+#0;
|
||
dir:=topath+#0;
|
||
wild:=AllFiles + #0;
|
||
(* TH - added to clear the previous state of DosError *)
|
||
DosError := 0;
|
||
{$IFDEF DLL}
|
||
if
|
||
{$ENDIF}
|
||
FileUnzipEx(@fn[1],@dir[1],@wild[1])
|
||
{$IFDEF DLL}
|
||
= 0 then
|
||
{$ELSE}
|
||
;
|
||
if doserror<>0 then
|
||
{$ENDIF}
|
||
begin
|
||
messagebox('Error when extracting. Disk full?',nil,mferror+mfokbutton);
|
||
errorhalt;
|
||
end;
|
||
end;
|
||
|
||
|
||
{*****************************************************************************
|
||
TEndDialog
|
||
*****************************************************************************}
|
||
|
||
constructor tenddialog.init;
|
||
var
|
||
R : TRect;
|
||
P : PStaticText;
|
||
Control : PButton;
|
||
YB: word;
|
||
{$IFNDEF LINUX}
|
||
S: string;
|
||
WPath: 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
|
||
YB := 14;
|
||
|
||
{$IFNDEF LINUX}
|
||
S := Data.BasePath + Cfg.BinSub;
|
||
if Pos (Upper (S), Upper (GetEnv ('PATH'))) = 0 then
|
||
begin
|
||
WPath := true;
|
||
Inc (YB, 2);
|
||
end else WPath := false;
|
||
{$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 Successfull');
|
||
|
||
{$IFNDEF LINUX}
|
||
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 - 13, 64, YB - 11);
|
||
P := New (PStaticText, Init (R, S));
|
||
Insert (P);
|
||
end;
|
||
{$ENDIF}
|
||
{$ENDIF}
|
||
|
||
R.Assign(2, YB - 11, 64, YB - 10);
|
||
P:=new(pstatictext,init(r,'To compile files enter '''+cfg.ppc386+' [file]'''));
|
||
insert(P);
|
||
|
||
R.Assign (29, YB - 9, 39, YB - 7);
|
||
Control := New (PButton, Init (R,'~O~k', cmOK, bfDefault));
|
||
Insert (Control);
|
||
end;
|
||
|
||
|
||
{*****************************************************************************
|
||
TInstallDialog
|
||
*****************************************************************************}
|
||
|
||
constructor tinstalldialog.init;
|
||
var
|
||
r : trect;
|
||
mask_components : longint;
|
||
i,line : integer;
|
||
items : psitem;
|
||
p,f : pview;
|
||
|
||
const
|
||
width = 76;
|
||
height = 20;
|
||
x1 = (79-width) div 2;
|
||
y1 = (23-height) div 2;
|
||
x2 = x1+width;
|
||
y2 = y1+height;
|
||
|
||
begin
|
||
r.assign(x1,y1,x2,y2);
|
||
inherited init(r,cfg.title+' Installation');
|
||
|
||
line:=2;
|
||
r.assign(3,line+1,28,line+2);
|
||
|
||
f:=new(pinputline,init(r,high(DirStr)));
|
||
insert(f);
|
||
|
||
r.assign(3,line,8,line+1);
|
||
insert(new(plabel,init(r,'~P~ath',f)));
|
||
|
||
{ walk packages reverse and insert a newsitem for each, and set the mask }
|
||
items:=nil;
|
||
mask_components:=0;
|
||
for i:=cfg.packages downto 1 do
|
||
begin
|
||
if file_exists(cfg.package[i].zip,startpath) then
|
||
begin
|
||
items:=newsitem(cfg.package[i].name+diskspace(startpath+DirSep+cfg.package[i].zip),items);
|
||
mask_components:=mask_components or packagemask(i);
|
||
end
|
||
else
|
||
begin
|
||
items:=newsitem(cfg.package[i].name,items);
|
||
end;
|
||
end;
|
||
|
||
{ If no component found abort }
|
||
if mask_components=0 then
|
||
begin
|
||
messagebox('No components found to install, aborting.',nil,mferror+mfokbutton);
|
||
errorhalt;
|
||
end;
|
||
|
||
inc(line,3);
|
||
r.assign(3,line+1,width-3,line+cfg.packages+1);
|
||
p:=new(pcheckboxes,init(r,items));
|
||
r.assign(3,line,14,line+1);
|
||
insert(new(plabel,init(r,'~C~omponents',p)));
|
||
pcluster(p)^.enablemask:=mask_components;
|
||
insert(p);
|
||
|
||
inc(line,cfg.packages+2);
|
||
r.assign((width div 2)-14,line,(width div 2)-4,line+2);
|
||
insert(new(pbutton,init(r,'~O~k',cmok,bfdefault)));
|
||
r.assign((width div 2)+4,line,(width div 2)+14,line+2);
|
||
insert(new(pbutton,init(r,'~C~ancel',cmcancel,bfnormal)));
|
||
|
||
f^.select;
|
||
end;
|
||
|
||
|
||
{*****************************************************************************
|
||
TApp
|
||
*****************************************************************************}
|
||
|
||
const
|
||
cmstart = 1000;
|
||
|
||
procedure tapp.do_installdialog;
|
||
var
|
||
p : pinstalldialog;
|
||
p2 : punzipdialog;
|
||
p3 : penddialog;
|
||
r : trect;
|
||
result,
|
||
c : word;
|
||
i, DSize, Space : longint;
|
||
S: DirStr;
|
||
begin
|
||
data.basepath:=cfg.basepath;
|
||
data.mask:=0;
|
||
|
||
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
|
||
if (data.mask>0) then
|
||
begin
|
||
(* TH - check the available disk space here *)
|
||
{$IFNDEF LINUX}
|
||
DSize := 0;
|
||
for i:=1 to cfg.packages do
|
||
begin
|
||
if data.mask and packagemask(i)<>0 then
|
||
Inc (DSize, DiskSpaceN(cfg.package[i].zip));
|
||
end;
|
||
S := FExpand (Data.BasePath);
|
||
Space := DiskFree (byte (S [1]) - 64) 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 createdir(data.basepath) then
|
||
break;
|
||
end
|
||
else
|
||
begin
|
||
result:=messagebox('No components selected.'#13#13'Abort installation?',nil,
|
||
mferror+mfyesbutton+mfnobutton);
|
||
if result=cmYes then
|
||
exit;
|
||
end;
|
||
end;
|
||
end
|
||
else
|
||
exit;
|
||
until false;
|
||
|
||
{ extract }
|
||
r.assign(20,7,60,16);
|
||
p2:=new(punzipdialog,init(r,'Extracting files'));
|
||
desktop^.insert(p2);
|
||
for i:=1 to cfg.packages do
|
||
begin
|
||
if data.mask and packagemask(i)<>0 then
|
||
p2^.do_unzip(cfg.package[i].zip,data.basepath);
|
||
end;
|
||
desktop^.delete(p2);
|
||
dispose(p2,done);
|
||
|
||
{ write config }
|
||
writedefcfg(data.basepath+cfg.binsub+DirSep+cfg.defcfgfile);
|
||
|
||
{ show end message }
|
||
p3:=new(penddialog,init);
|
||
executedialog(p3,nil);
|
||
end;
|
||
|
||
|
||
procedure tapp.readcfg(const fn:string);
|
||
var
|
||
t : text;
|
||
i,j,
|
||
line : longint;
|
||
item,
|
||
s : 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);
|
||
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='PPC386' then
|
||
cfg.ppc386:=s
|
||
else
|
||
if item='BINSUB' then
|
||
cfg.binsub:=s
|
||
else
|
||
if item='CFGFILE' then
|
||
cfg.defcfgfile:=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='PACKAGE' then
|
||
begin
|
||
j:=pos(',',s);
|
||
if (j>0) and (cfg.packages<maxpackages) then
|
||
begin
|
||
inc(cfg.packages);
|
||
cfg.package[cfg.packages].zip:=copy(s,1,j-1);
|
||
cfg.package[cfg.packages].name:=copy(s,j+1,255);
|
||
end;
|
||
end;
|
||
end;
|
||
end;
|
||
end;
|
||
close(t);
|
||
end;
|
||
|
||
|
||
procedure tapp.initmenubar;
|
||
var
|
||
r : trect;
|
||
begin
|
||
getextent(r);
|
||
r.b.y:=r.a.y+1;
|
||
menubar:=new(pmenubar,init(r,newmenu(
|
||
newsubmenu('~F~ree Pascal '+cfg.version,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}
|
||
|
||
begin
|
||
(* 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}
|
||
getdir(0,startpath);
|
||
successfull:=false;
|
||
|
||
fillchar(cfg, SizeOf(cfg), 0);
|
||
fillchar(data, SizeOf(data), 0);
|
||
|
||
installapp.init;
|
||
installapp.readcfg(cfgfile);
|
||
{ installapp.readcfg(startpath+dirsep+cfgfile);}
|
||
installapp.do_installdialog;
|
||
installapp.done;
|
||
end.
|
||
{
|
||
$Log$
|
||
Revision 1.1 1999-02-19 16:45:26 peter
|
||
* moved to fpinst/ directory
|
||
+ makefile
|
||
|
||
Revision 1.15 1999/02/17 22:34:08 peter
|
||
* updates from TH for OS2
|
||
|
||
Revision 1.14 1998/12/22 22:47:34 peter
|
||
* updates for OS2
|
||
* small fixes
|
||
|
||
Revision 1.13 1998/12/21 13:11:39 peter
|
||
* updates for 0.99.10
|
||
|
||
Revision 1.12 1998/12/16 00:25:34 peter
|
||
* updated for 0.99.10
|
||
* new end dialogbox
|
||
|
||
Revision 1.11 1998/11/01 20:32:25 peter
|
||
* packed record
|
||
|
||
Revision 1.10 1998/10/25 23:38:35 peter
|
||
* removed warnings
|
||
|
||
Revision 1.9 1998/10/23 16:57:40 pierre
|
||
* compiles without -So option
|
||
* the main dialog init was buggy !!
|
||
|
||
Revision 1.8 1998/09/22 21:10:31 jonas
|
||
* initialize cfg and data with 0 at startup
|
||
|
||
Revision 1.7 1998/09/16 16:46:37 peter
|
||
+ updates
|
||
|
||
Revision 1.6 1998/09/15 13:11:14 pierre
|
||
small fix to cleanup if no package
|
||
|
||
Revision 1.5 1998/09/15 12:06:06 peter
|
||
* install updated to support w32 and dos and config file
|
||
|
||
Revision 1.4 1998/09/10 10:50:49 florian
|
||
* DOS install program updated
|
||
|
||
Revision 1.3 1998/09/09 13:39:58 peter
|
||
+ internal unzip
|
||
* dialog is showed automaticly
|
||
|
||
Revision 1.2 1998/04/07 22:47:57 florian
|
||
+ version/release/patch numbers as string added
|
||
|
||
}
|
||
|