{ $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.defcfgs0) and (cfg.packages 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 }