{ $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 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 VER60} {$DEFINE TP} {$ENDIF} {$IFDEF VER70} {$DEFINE TP} {$ENDIF} {$IFNDEF TP} {$UNDEF DOSSTUB} {$ELSE} {$IFDEF OS2} {$UNDEF DOSSTUB} {$ENDIF} {$ENDIF} {$IFDEF DPMI} {$UNDEF DOSSTUB} {$ENDIF} {$ifdef go32v2} {$define MAYBE_LFN} {$endif} {$ifdef debug} {$ifdef win32} {$define MAYBE_LFN} {$endif win32} {$endif debug} {$ifdef TP} {$define MAYBE_LFN} {$endif} uses {$IFDEF OS2} {$IFDEF FPC} DosCalls, {$ELSE FPC} {$IFDEF VirtualPascal} OS2Base, {$ELSE VirtualPascal} BseDos, {$ENDIF VirtualPascal} {$ENDIF FPC} {$ENDIF OS2} {$IFDEF GO32V2} { emu387, not needed anymore PM } {$ENDIF} {$ifdef HEAPTRC} heaptrc, {$endif HEAPTRC} strings,dos,objects,drivers, {$IFNDEF FVISION} commands, HelpCtx, {$ENDIF} unzip,ziptypes, {$IFDEF DLL} unzipdll, {$ENDIF} app,dialogs,views,menus,msgbox,colortxt,tabs,scroll, WHTMLScn; 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 linux} 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; 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; 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; {$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; 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 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+} 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 (iS2 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; {***************************************************************************** HTML-Index Generation *****************************************************************************} var indexdlg : phtmlindexdialog; constructor thtmlindexdialog.Init(var Bounds: TRect; ATitle: TTitleStr); var r : trect; begin inherited init(bounds,atitle); 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 !!!! } 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); (* 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); 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 : boolean; fn,dir,wild : string; begin Disposestr(filetext^.text); filetext^.Text:=NewStr(#3'File: '+s + #13#3' '); filetext^.drawview; if not(file_exists(s,startpath)) then begin messagebox('File "'+s+'" missing for the selected installation. '+ 'Installation hasn''t been completed.',nil,mferror+mfokbutton); errorhalt; end; {$IFNDEF DLL} {$IFDEF FPC} SetUnzipReportProc (@UnzipCheckFn); {$ELSE FPC} SetUnzipReportProc (UnzipCheckFn); {$ENDIF FPC} {$ENDIF DLL} repeat fn:=startpath+DirSep+s+#0; dir:=topath+#0; wild:=AllFiles + #0; again:=false; FileUnzipEx(@fn[1],@dir[1],@wild[1]); if (UnzipErr <> 0) then begin Str(UnzipErr,s); if messagebox('Error (' + S + ') while extracting. Disk full?'#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 LINUX} 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 LINUX} 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 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; 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) 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} 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; 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 : pinputline; 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; for i:=packages downto 1 do begin zipfile:=''; if file_exists(package[i].zip,startpath) then zipfile:=startpath+DirSep+package[i].zip else if file_exists(package[i].zipshort,startpath) then begin zipfile:=startpath+DirSep+package[i].zipshort; { update package to replace the full zipname with the short name } package[i].zip:=package[i].zipshort; end; if zipfile<>'' then begin { get diskspace required } package[i].diskspace:=diskspaceN(zipfile); {$ifdef MAYBE_LFN} if not(locallfnsupport) then begin if not(haslfn(zipfile)) then begin items[j]:=newsitem(package[i].name+diskspacestr(package[i].diskspace),items[j]); packmask[j]:=packmask[j] or packagemask(i); 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); 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); 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); errorhalt; end; r.assign(x1,y1,x2,y2); inherited init(r,''); 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}packmask[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)'' 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 LINUX} { 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); 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.defcfgsmaxpacks then begin writeln('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'); 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'); 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'); 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'); 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'); 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'); 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'); 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'); 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'); halt(1); end; with cfg.pack[cfg.packs] do begin j:=pos(',',s); if (j>0) and (packages0) 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'' 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 { 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)); 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; if createlog then close(log); end. { $Log$ 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 Revision 1.2.2.16 2001/11/24 14:29:54 carl * ppc386.cfg -> fpc.cfg Revision 1.2.2.15 2001/05/02 16:22:43 pierre + Shorten file names to comply with Dos 8+3 limitation Revision 1.2.2.14 2001/04/19 15:50:24 pierre * remove use of reals so emu387 is not needed anymore Revision 1.2.2.13 2001/01/02 09:43:12 florian * vresion fixed Revision 1.2.2.12 2001/01/02 09:35:50 florian * targetname is now read from the .dat file too Revision 1.2.2.11 2000/11/26 19:02:58 hajny * English correction Revision 1.2.2.10 2000/11/26 16:49:57 hajny * removed unneeded OS/2 conditionals Revision 1.2.2.9 2000/11/09 22:02:33 florian * fixed bug 1226: wrong target for the win32 IDE Revision 1.2.2.8 2000/10/11 18:08:45 peter * lfnsupport is only for go32v2 Revision 1.2.2.7 2000/10/11 16:49:02 florian + fixed a typo and the setting of haside and hashtmlhelp Revision 1.2.2.6 2000/10/11 13:10:20 florian + added preconfiguratioh of help files Revision 1.2.2.5 2000/10/10 22:12:10 florian + added a message how to start the IDE Revision 1.2.2.4 2000/10/10 16:36:12 florian + creation of IDE configuration files added Revision 1.2.2.3 2000/09/24 10:52:14 peter * window can now also be smaller again Revision 1.2.2.2 2000/09/22 08:41:36 pierre * add emulation for go32v2 and display currently extraced file Revision 1.2.2.1 2000/09/21 10:57:11 pierre changes by Gabor for scrolling support Revision 1.2 2000/07/21 10:43:01 florian + added for lfn support Revision 1.1 2000/07/13 06:30:21 michael + Initial import Revision 1.20 2000/07/09 12:55:45 hajny * updated for version 1.0 Revision 1.19 2000/06/18 18:27:32 hajny + archive validity checking, progress indicator, better error checking Revision 1.18 2000/02/24 17:47:47 peter * last fixes for 0.99.14a release Revision 1.17 2000/02/23 17:17:56 peter * write ppc386.cfg for all found targets Revision 1.16 2000/02/06 12:59:39 peter * change upper -> upcase * fixed stupid debugging leftover with diskspace check Revision 1.15 2000/02/02 17:19:10 pierre * avoid diskfree problem and get mouse visible Revision 1.14 2000/02/02 15:21:31 peter * show errorcode in message when error in unzipping Revision 1.13 2000/01/26 21:49:33 peter * install.pas compilable by FPC again * removed some notes from unzip.pas * support installer creation under linux (install has name conflict) Revision 1.12 2000/01/26 21:15:59 hajny * compilable with TP again (lines < 127install.pas, ifdef around findclose) Revision 1.11 2000/01/24 22:21:48 peter * new install version (keys not wrong correct yet) Revision 1.10 2000/01/18 00:22:48 peter * fixed uninited local var Revision 1.9 1999/08/03 20:21:53 peter * fixed sources mask which was not set correctly Revision 1.7 1999/07/01 07:56:58 hajny * installation to root fixed Revision 1.6 1999/06/29 22:20:19 peter * updated to use tab pages Revision 1.5 1999/06/25 07:06:30 hajny + searching for installation script updated Revision 1.4 1999/06/10 20:01:23 peter + fcl,fv,gtk support Revision 1.3 1999/06/10 15:00:14 peter * fixed to compile for not os2 * update install.dat Revision 1.2 1999/06/10 07:28:27 hajny * compilable with TP again 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 }