mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-05-09 19:32:34 +02:00
594 lines
15 KiB
ObjectPascal
594 lines
15 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;
|
|
|
|
uses
|
|
app,dialogs,views,objects,menus,drivers,strings,msgbox,dos,unzip,ziptypes;
|
|
|
|
const
|
|
maxpackages=20;
|
|
maxdefcfgs=200;
|
|
|
|
cfgfile='install.dat';
|
|
|
|
type
|
|
tpackage=record
|
|
name : string[60];
|
|
zip : string[12];
|
|
end;
|
|
|
|
cfgrec=record
|
|
title : string[80];
|
|
version : string[20];
|
|
basepath : string[80];
|
|
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=record
|
|
basepath : string[80];
|
|
mask : word;
|
|
end;
|
|
|
|
var
|
|
startpath : string;
|
|
successfull : boolean;
|
|
cfg : cfgrec;
|
|
data : datarec;
|
|
|
|
{*****************************************************************************
|
|
Helpers
|
|
*****************************************************************************}
|
|
|
|
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;
|
|
|
|
|
|
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 diskspace(const zipfile : string) : string;
|
|
var
|
|
compressed,uncompressed : longint;
|
|
s : string;
|
|
begin
|
|
s:=zipfile+#0;
|
|
uncompressed:=UnzipSize(@s[1],compressed);
|
|
uncompressed:=uncompressed shr 10;
|
|
str(uncompressed,s);
|
|
diskspace:=' ('+s+' Kb)';
|
|
end;
|
|
|
|
|
|
function createdir(var s : string) : boolean;
|
|
var
|
|
result : longint;
|
|
dir : searchrec;
|
|
params : array[0..0] of pointer;
|
|
begin
|
|
if s[length(s)]='\' then
|
|
dec(s[0]);
|
|
s:=lower(s);
|
|
FindFirst(s,$ff,dir);
|
|
if doserror=0 then
|
|
begin
|
|
result:=messagebox('The installation directory exists already. '+
|
|
'Do want to enter a new installation directory ?',nil,
|
|
mferror+mfyesbutton+mfnobutton);
|
|
createdir:=(result=cmNo);
|
|
exit;
|
|
end;
|
|
{$I-}
|
|
mkdir(s);
|
|
{$I+}
|
|
if ioresult<>0 then
|
|
begin
|
|
params[0]:=@s;
|
|
messagebox('The installation directory %s couldn''t be created',
|
|
@params,mferror+mfokbutton);
|
|
createdir:=false;
|
|
exit;
|
|
end;
|
|
createdir:=true;
|
|
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,$ff,dir);
|
|
if doserror=0 then
|
|
begin
|
|
params[0]:=@fn;
|
|
MessageBox('Config file %s already exists, default config not written',@params,mfinformation+mfokbutton);
|
|
exit;
|
|
end;
|
|
assign(t,fn);
|
|
{$I-}
|
|
rewrite(t);
|
|
{$I+}
|
|
if ioresult<>0 then
|
|
begin
|
|
params[0]:=@fn;
|
|
MessageBox('Can''t create %s, default config not written',@params,mfinformation+mfokbutton);
|
|
exit;
|
|
end;
|
|
for i:=1to 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;
|
|
|
|
|
|
{*****************************************************************************
|
|
Cfg Read
|
|
*****************************************************************************}
|
|
|
|
procedure readcfg(const fn:string);
|
|
var
|
|
t : text;
|
|
i,j,
|
|
line : longint;
|
|
item,
|
|
s : string;
|
|
|
|
{$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,fn);
|
|
{$I-}
|
|
reset(t);
|
|
{$I+}
|
|
if ioresult<>0 then
|
|
begin
|
|
writeln('error: ',fn,' not found!');
|
|
halt(1);
|
|
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));
|
|
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
|
|
else
|
|
writeln('error in confg, unknown item "',item,'" skipping line ',line);
|
|
end
|
|
else
|
|
writeln('error in confg, skipping line ',line);
|
|
end;
|
|
end;
|
|
close(t);
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
TUnZipDialog
|
|
*****************************************************************************}
|
|
|
|
type
|
|
punzipdialog=^tunzipdialog;
|
|
tunzipdialog=object(tdialog)
|
|
filetext : pstatictext;
|
|
constructor Init(var Bounds: TRect; ATitle: TTitleStr);
|
|
procedure do_unzip(s,topath:string);
|
|
end;
|
|
|
|
|
|
constructor tunzipdialog.init;
|
|
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);
|
|
halt(1);
|
|
end;
|
|
fn:=startpath+'\'+s+#0;
|
|
dir:=topath+#0;
|
|
wild:='*.*'#0;
|
|
FileUnzipEx(@fn[1],@dir[1],@wild[1]);
|
|
if doserror<>0 then
|
|
begin
|
|
messagebox('Error when extracting. Disk full?',nil,mferror+mfokbutton);
|
|
halt(1);
|
|
end;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
TInstallDialog
|
|
*****************************************************************************}
|
|
|
|
type
|
|
pinstalldialog = ^tinstalldialog;
|
|
tinstalldialog = object(tdialog)
|
|
constructor init;
|
|
end;
|
|
|
|
type
|
|
tapp = object(tapplication)
|
|
procedure initmenubar;virtual;
|
|
procedure handleevent(var event : tevent);virtual;
|
|
procedure do_installdialog;
|
|
end;
|
|
|
|
var
|
|
installapp : tapp;
|
|
|
|
|
|
constructor tinstalldialog.init;
|
|
var
|
|
r : trect;
|
|
mask_components : longint;
|
|
i,line : integer;
|
|
items : psitem;
|
|
p,f : pview;
|
|
s : string;
|
|
|
|
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,8,line+1);
|
|
insert(new(plabel,init(r,'~P~ath',p)));
|
|
insert(p);
|
|
r.assign(3,line+1,28,line+2);
|
|
|
|
f:=new(pinputline,init(r,80));
|
|
insert(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+'\'+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);
|
|
{ this clears the screen at least PM }
|
|
installapp.done;
|
|
halt(1);
|
|
end;
|
|
|
|
inc(line,3);
|
|
r.assign(3,line,14,line+1);
|
|
insert(new(plabel,init(r,'~C~omponents',p)));
|
|
r.assign(3,line+1,width-3,line+cfg.packages+1);
|
|
p:=new(pcheckboxes,init(r,items));
|
|
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 : pstatictext;
|
|
r : trect;
|
|
result,
|
|
c : word;
|
|
i : longint;
|
|
begin
|
|
data.basepath:=cfg.basepath;
|
|
data.mask:=0;
|
|
|
|
repeat
|
|
p:=new(pinstalldialog,init);
|
|
{ default settings }
|
|
c:=executedialog(p,@data);
|
|
if (c=cmok) then
|
|
begin
|
|
if (data.mask>0) then
|
|
begin
|
|
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
|
|
else
|
|
exit;
|
|
until false;
|
|
|
|
r.assign(20,7,60,16);
|
|
p2:=new(punzipdialog,init(r,'Extracting files'));
|
|
desktop^.insert(p2);
|
|
for i:=1to 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);
|
|
|
|
writedefcfg(data.basepath+cfg.binsub+'\'+cfg.defcfgfile);
|
|
|
|
messagebox('Installation successfull',nil,mfinformation+mfokbutton);
|
|
successfull:=true;
|
|
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;
|
|
|
|
|
|
begin
|
|
getdir(0,startpath);
|
|
successfull:=false;
|
|
|
|
fillchar(cfg, SizeOf(cfg), 0);
|
|
fillchar(data, SizeOf(data), 0);
|
|
|
|
readcfg(cfgfile);
|
|
|
|
installapp.init;
|
|
installapp.do_installdialog;
|
|
installapp.done;
|
|
|
|
if successfull then
|
|
begin
|
|
writeln('Extend your PATH variable with ''',data.basepath+cfg.binsub+'''');
|
|
writeln;
|
|
writeln('To compile files enter ''',cfg.ppc386,' [file]''');
|
|
writeln;
|
|
end;
|
|
end.
|
|
{
|
|
$Log$
|
|
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
|
|
|
|
}
|