install.pas 49 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832
  1. {
  2. $Id$
  3. This file is part of the Free Pascal run time library.
  4. Copyright (c) 1993-98 by Florian Klaempfl
  5. member of the Free Pascal development team
  6. This is the install program for the DOS and OS/2 versions of Free Pascal
  7. See the file COPYING.FPC, included in this distribution,
  8. for details about the copyright.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  12. **********************************************************************}
  13. program install;
  14. { $DEFINE DLL} (* TH - if defined, UNZIP32.DLL library is used to unpack. *)
  15. { $DEFINE DOSSTUB} (* TH - should _not_ be defined unless creating a bound DOS and OS/2 installer!!! *)
  16. (* Defining DOSSTUB causes adding a small piece of code *)
  17. (* for starting the OS/2 part from the DOS part of a bound *)
  18. (* application if running in OS/2 VDM (DOS) window. Used *)
  19. (* only if compiling with TP/BP (see conditionals below). *)
  20. {$IFDEF VER60}
  21. {$DEFINE TP}
  22. {$ENDIF}
  23. {$IFDEF VER70}
  24. {$DEFINE TP}
  25. {$ENDIF}
  26. {$IFNDEF TP}
  27. {$UNDEF DOSSTUB}
  28. {$ELSE}
  29. {$IFDEF OS2}
  30. {$UNDEF DOSSTUB}
  31. {$ENDIF}
  32. {$ENDIF}
  33. {$IFDEF DPMI}
  34. {$UNDEF DOSSTUB}
  35. {$ENDIF}
  36. {$ifdef go32v2}
  37. {$define MAYBE_LFN}
  38. {$endif}
  39. {$ifdef debug}
  40. {$ifdef win32}
  41. {$define MAYBE_LFN}
  42. {$endif win32}
  43. {$endif debug}
  44. {$ifdef TP}
  45. {$define MAYBE_LFN}
  46. {$endif}
  47. uses
  48. {$IFDEF OS2}
  49. {$IFDEF FPC}
  50. DosCalls,
  51. {$ELSE FPC}
  52. {$IFDEF VirtualPascal}
  53. OS2Base,
  54. {$ELSE VirtualPascal}
  55. BseDos,
  56. {$ENDIF VirtualPascal}
  57. {$ENDIF FPC}
  58. {$ENDIF OS2}
  59. {$IFDEF GO32V2}
  60. { emu387, not needed anymore PM }
  61. {$ENDIF}
  62. {$ifdef HEAPTRC}
  63. heaptrc,
  64. {$endif HEAPTRC}
  65. strings,dos,objects,drivers,
  66. {$IFNDEF FVISION}
  67. commands,
  68. HelpCtx,
  69. {$ENDIF}
  70. unzip,ziptypes,
  71. {$IFDEF DLL}
  72. unzipdll,
  73. {$ENDIF}
  74. app,dialogs,views,menus,msgbox,colortxt,tabs,scroll,
  75. WHTMLScn;
  76. const
  77. installerversion='1.0.4';
  78. maxpacks=10;
  79. maxpackages=20;
  80. maxdefcfgs=1024;
  81. HTMLIndexExt = '.htx';
  82. CfgExt = '.dat';
  83. MaxStatusPos = 4;
  84. StatusChars: string [MaxStatusPos] = '/-\|';
  85. StatusPos: byte = 1;
  86. { this variable is set to true if an ide is installed }
  87. haside : boolean = false;
  88. hashtmlhelp : boolean = false;
  89. {$ifdef linux}
  90. DirSep='/';
  91. {$else}
  92. DirSep='\';
  93. {$endif}
  94. type
  95. tpackage=record
  96. name : string[60];
  97. zip : string[12];
  98. end;
  99. tpack=record
  100. name : string[12];
  101. binsub : string[40];
  102. ppc386 : string[20];
  103. targetname : string[20];
  104. defidecfgfile,
  105. defideinifile,
  106. defcfgfile : string[12];
  107. include : boolean;
  108. filechk : string[40];
  109. packages : longint;
  110. package : array[1..maxpackages] of tpackage;
  111. end;
  112. tcfgarray = array[1..maxdefcfgs] of pstring;
  113. cfgrec=record
  114. title : string[80];
  115. version : string[20];
  116. helpidx,
  117. docsub,
  118. basepath : DirStr;
  119. packs : word;
  120. pack : array[1..maxpacks] of tpack;
  121. defideinis,
  122. defidecfgs,
  123. defcfgs : longint;
  124. defideini,
  125. defidecfg,
  126. defcfg : tcfgarray;
  127. end;
  128. datarec=packed record
  129. basepath : DirStr;
  130. cfgval : word;
  131. packmask : array[1..maxpacks] of word;
  132. end;
  133. punzipdialog=^tunzipdialog;
  134. tunzipdialog=object(tdialog)
  135. filetext : pstatictext;
  136. extractfiletext : pstatictext;
  137. constructor Init(var Bounds: TRect; ATitle: TTitleStr);
  138. procedure do_unzip(s,topath:string);
  139. end;
  140. penddialog = ^tenddialog;
  141. tenddialog = object(tdialog)
  142. constructor init;
  143. end;
  144. pinstalldialog = ^tinstalldialog;
  145. tinstalldialog = object(tdialog)
  146. constructor init;
  147. end;
  148. PFPHTMLFileLinkScanner = ^TFPHTMLFileLinkScanner;
  149. TFPHTMLFileLinkScanner = object(THTMLFileLinkScanner)
  150. function CheckURL(const URL: string): boolean; virtual;
  151. function CheckText(const Text: string): boolean; virtual;
  152. procedure ProcessDoc(Doc: PHTMLLinkScanFile); virtual;
  153. end;
  154. phtmlindexdialog = ^thtmlindexdialog;
  155. thtmlindexdialog = object(tdialog)
  156. text : pstatictext;
  157. constructor init(var Bounds: TRect; ATitle: TTitleStr);
  158. end;
  159. tapp = object(tapplication)
  160. procedure initmenubar;virtual;
  161. procedure handleevent(var event : tevent);virtual;
  162. procedure do_installdialog;
  163. procedure readcfg(const fn:string);
  164. procedure checkavailpack;
  165. end;
  166. {$IFDEF DOSSTUB}
  167. PByte = ^byte;
  168. PRunBlock = ^TRunBlock;
  169. TRunBlock = record
  170. Length: word;
  171. Dependent: word;
  172. Background: word;
  173. TraceLevel: word;
  174. PrgTitle: PChar;
  175. PrgName: PChar;
  176. Args: PChar;
  177. TermQ: longint;
  178. Environment: pointer;
  179. Inheritance: word;
  180. SesType: word;
  181. Icon: pointer;
  182. PgmHandle: longint;
  183. PgmControl: word;
  184. Column: word;
  185. Row: word;
  186. Width: word;
  187. Height: word;
  188. end;
  189. {$ENDIF}
  190. var
  191. installapp : tapp;
  192. startpath : string;
  193. successfull : boolean;
  194. cfg : cfgrec;
  195. data : datarec;
  196. CfgName: NameStr;
  197. DStr: DirStr;
  198. EStr: ExtStr;
  199. UnzDlg : punzipdialog;
  200. log : text;
  201. createlog : boolean;
  202. {$IFNDEF DLL}
  203. const
  204. UnzipErr: longint = 0;
  205. {$ENDIF}
  206. {$ifdef MAYBE_LFN}
  207. const
  208. locallfnsupport : boolean = false;
  209. {$endif MAYBE_LFN}
  210. {*****************************************************************************
  211. Helpers
  212. *****************************************************************************}
  213. procedure errorhalt;
  214. begin
  215. installapp.done;
  216. halt(1);
  217. end;
  218. function packagemask(i:longint):longint;
  219. begin
  220. packagemask:=1 shl (i-1);
  221. end;
  222. function upper(const s : string):string;
  223. var
  224. i : integer;
  225. begin
  226. for i:=1 to length(s) do
  227. if s[i] in ['a'..'z'] then
  228. upper[i]:=chr(ord(s[i])-32)
  229. else
  230. upper[i]:=s[i];
  231. upper[0]:=s[0];
  232. end;
  233. procedure Replace(var s:string;const s1,s2:string);
  234. var
  235. i : longint;
  236. begin
  237. repeat
  238. i:=pos(s1,s);
  239. if i>0 then
  240. begin
  241. Delete(s,i,length(s1));
  242. Insert(s2,s,i);
  243. end;
  244. until i=0;
  245. end;
  246. function file_exists(const f : string;const path : string) : boolean;
  247. begin
  248. file_exists:=fsearch(f,path)<>'';
  249. end;
  250. function createdir(s:string):boolean;
  251. var
  252. s1,start : string;
  253. err : boolean;
  254. i : longint;
  255. begin
  256. err:=false;
  257. {$I-}
  258. getdir(0,start);
  259. {$ifndef linux}
  260. if (s[2]=':') and (s[3]=DirSep) then
  261. begin
  262. chdir(Copy(s,1,3));
  263. Delete(S,1,3);
  264. end;
  265. {$endif}
  266. repeat
  267. i:=Pos(DirSep,s);
  268. if i=0 then
  269. i:=255;
  270. s1:=Copy(s,1,i-1);
  271. Delete(s,1,i);
  272. ChDir(s1);
  273. if ioresult<>0 then
  274. begin
  275. mkdir(s1);
  276. chdir(s1);
  277. if ioresult<>0 then
  278. begin
  279. err:=true;
  280. break;
  281. end;
  282. end;
  283. until s='';
  284. chdir(start);
  285. {$I+}
  286. createdir:=err;
  287. end;
  288. function DiskSpaceN(const zipfile : string) : longint;
  289. var
  290. compressed,uncompressed : longint;
  291. s : string;
  292. begin
  293. s:=zipfile+#0;
  294. if not (IsZip (@S [1])) then DiskSpaceN := -1 else
  295. begin
  296. Uncompressed:=UnzipSize(@s[1],compressed);
  297. DiskSpaceN:=uncompressed shr 10;
  298. end;
  299. end;
  300. function diskspace(const zipfile : string) : string;
  301. var
  302. uncompressed : longint;
  303. s : string;
  304. begin
  305. uncompressed:=DiskSpaceN (zipfile);
  306. if Uncompressed = -1 then DiskSpace := ' [INVALID]' else
  307. begin
  308. str(uncompressed,s);
  309. diskspace:=' ('+s+' KB)';
  310. end;
  311. end;
  312. function createinstalldir(s : string) : boolean;
  313. var
  314. err : boolean;
  315. dir : searchrec;
  316. params : array[0..0] of pointer;
  317. begin
  318. if s[length(s)]=DirSep then
  319. dec(s[0]);
  320. FindFirst(s,AnyFile,dir);
  321. if doserror=0 then
  322. begin
  323. if Dir.Attr and Directory = 0 then
  324. begin
  325. messagebox('A file with the name chosen as the installation '+
  326. 'directory exists already. Cannot create this directory!',nil,
  327. mferror+mfokbutton);
  328. createinstalldir:=false;
  329. end else
  330. createinstalldir:=messagebox('The installation directory exists already. '+
  331. 'Do you want to continue ?',nil,
  332. mferror+mfyesbutton+mfnobutton)=cmYes;
  333. exit;
  334. end;
  335. err:=Createdir(s);
  336. if err then
  337. begin
  338. params[0]:=@s;
  339. messagebox('The installation directory %s couldn''t be created',
  340. @params,mferror+mfokbutton);
  341. createinstalldir:=false;
  342. exit;
  343. end;
  344. {$ifndef TP}
  345. {$IFNDEF OS2}
  346. FindClose (dir);
  347. {$ENDIF}
  348. {$endif}
  349. createinstalldir:=true;
  350. end;
  351. function GetProgDir: DirStr;
  352. var
  353. D: DirStr;
  354. N: NameStr;
  355. E: ExtStr;
  356. begin
  357. FSplit (FExpand (ParamStr (0)), D, N, E);
  358. if (D [0] <> #0) and (D [byte (D [0])] = '\') then Dec (D [0]);
  359. GetProgDir := D;
  360. end;
  361. function RTrim(const S: string): string;
  362. var
  363. i : longint;
  364. begin
  365. i:=length(s);
  366. while (i>0) and (s[i]=' ') do
  367. dec(i);
  368. RTrim:=Copy(s,1,i);
  369. end;
  370. function LTrim(const S: string): string;
  371. var
  372. i : longint;
  373. begin
  374. i:=1;
  375. while (i<length(s)) and (s[i]=' ') do
  376. inc(i);
  377. LTrim:=Copy(s,i,255);
  378. end;
  379. function Trim(const S: string): string;
  380. begin
  381. Trim:=RTrim(LTrim(S));
  382. end;
  383. function CompareText(S1, S2: string): integer;
  384. var R: integer;
  385. begin
  386. S1:=Upcase(S1);
  387. S2:=Upcase(S2);
  388. if S1<S2 then R:=-1 else
  389. if S1>S2 then R:= 1 else
  390. R:=0;
  391. CompareText:=R;
  392. end;
  393. function ExtOf(const S: string): string;
  394. var D: DirStr; E: ExtStr; N: NameStr;
  395. begin
  396. FSplit(S,D,N,E);
  397. ExtOf:=E;
  398. end;
  399. function DirAndNameOf(const S: string): string;
  400. var D: DirStr; E: ExtStr; N: NameStr;
  401. begin
  402. FSplit(S,D,N,E);
  403. DirAndNameOf:=D+N;
  404. end;
  405. {*****************************************************************************
  406. HTML-Index Generation
  407. *****************************************************************************}
  408. var
  409. indexdlg : phtmlindexdialog;
  410. constructor thtmlindexdialog.Init(var Bounds: TRect; ATitle: TTitleStr);
  411. var
  412. r : trect;
  413. begin
  414. inherited init(bounds,atitle);
  415. R.Assign (4, 2,bounds.B.X-Bounds.A.X-2, 4);
  416. text:=new(pstatictext,init(r,'Please wait ...'));
  417. insert(text);
  418. end;
  419. procedure TFPHTMLFileLinkScanner.ProcessDoc(Doc: PHTMLLinkScanFile);
  420. var
  421. oldtext : pstring;
  422. begin
  423. oldtext:=indexdlg^.text^.text;
  424. indexdlg^.text^.text:=newstr('Processing '+Doc^.GetDocumentURL);
  425. indexdlg^.text^.drawview;
  426. inherited ProcessDoc(Doc);
  427. disposestr(indexdlg^.text^.text);
  428. indexdlg^.text^.text:=oldtext;
  429. indexdlg^.text^.drawview;
  430. end;
  431. function TFPHTMLFileLinkScanner.CheckURL(const URL: string): boolean;
  432. var OK: boolean;
  433. const HTTPPrefix = 'http:';
  434. FTPPrefix = 'ftp:';
  435. begin
  436. OK:=inherited CheckURL(URL);
  437. if OK then OK:=DirAndNameOf(URL)<>'';
  438. if OK then OK:=CompareText(copy(ExtOf(URL),1,4),'.HTM')=0;
  439. if OK then OK:=CompareText(copy(URL,1,length(HTTPPrefix)),HTTPPrefix)<>0;
  440. if OK then OK:=CompareText(copy(URL,1,length(FTPPrefix)),FTPPrefix)<>0;
  441. CheckURL:=OK;
  442. end;
  443. function TFPHTMLFileLinkScanner.CheckText(const Text: string): boolean;
  444. var OK: boolean;
  445. S: string;
  446. begin
  447. S:=Trim(Text);
  448. OK:=(S<>'') and (copy(S,1,1)<>'[');
  449. CheckText:=OK;
  450. end;
  451. procedure writehlpindex(filename : string);
  452. var
  453. LS : PFPHTMLFileLinkScanner;
  454. BS : PBufStream;
  455. S : String;
  456. Re : Word;
  457. params : array[0..0] of pointer;
  458. dir : searchrec;
  459. r : trect;
  460. begin
  461. S:='HTML Index';
  462. r.assign(10,10,70,15);
  463. indexdlg:=new(phtmlindexdialog,init(r,'Creating HTML index file, please wait ...'));
  464. desktop^.insert(indexdlg);
  465. {$warning FIXME !!!! }
  466. New(LS, Init(''));
  467. LS^.ProcessDocument(FileName,[soSubDocsOnly]);
  468. if LS^.GetDocumentCount=0 then
  469. begin
  470. params[0]:=@filename;
  471. MessageBox('Problem creating help index %1, aborting',@params,
  472. mferror+mfokbutton);
  473. end
  474. else
  475. begin
  476. FileName:=DirAndNameOf(FileName)+HTMLIndexExt;
  477. findfirst(filename,AnyFile,dir);
  478. if doserror=0 then
  479. begin
  480. params[0]:=@filename;
  481. Re:=MessageBox('Help index %s already exists, overwrite it?',@params,
  482. mfinformation+mfyesbutton+mfnobutton);
  483. end;
  484. if Re<>cmNo then
  485. begin
  486. New(BS, Init(FileName, stCreate, 4096));
  487. if Assigned(BS)=false then
  488. begin
  489. MessageBox('Error while writing help index! '+
  490. 'No help index is created',@params,
  491. mferror+mfokbutton);
  492. Re:=cmCancel;
  493. end
  494. else
  495. begin
  496. LS^.StoreDocuments(BS^);
  497. if BS^.Status<>stOK then
  498. begin
  499. MessageBox('Error while writing help index!'#13+
  500. 'No help index is created',@params,
  501. mferror+mfokbutton);
  502. Re:=cmCancel;
  503. end;
  504. Dispose(BS, Done);
  505. end;
  506. end;
  507. end;
  508. Dispose(LS, Done);
  509. desktop^.delete(indexdlg);
  510. dispose(indexdlg,done);
  511. end;
  512. {*****************************************************************************
  513. Writing of fpc.cfg
  514. *****************************************************************************}
  515. procedure writedefcfg(const fn:string;const cfgdata : tcfgarray;count : longint;const targetname : string);
  516. var
  517. t : text;
  518. i : longint;
  519. s : string;
  520. dir : searchrec;
  521. params : array[0..0] of pointer;
  522. d : dirstr;
  523. n : namestr;
  524. e : extstr;
  525. begin
  526. { already exists }
  527. findfirst(fn,AnyFile,dir);
  528. if doserror=0 then
  529. begin
  530. params[0]:=@fn;
  531. if MessageBox('Config %s already exists, continue writing default config?',@params,
  532. mfinformation+mfyesbutton+mfnobutton)=cmNo then
  533. exit;
  534. end;
  535. { create directory }
  536. fsplit(fn,d,n,e);
  537. createdir(d);
  538. { create the fpc.cfg }
  539. assign(t,fn);
  540. {$I-}
  541. rewrite(t);
  542. {$I+}
  543. if ioresult<>0 then
  544. begin
  545. params[0]:=@fn;
  546. MessageBox(#3'A config not written.'#13#3'%s'#13#3'couldn''t be created',@params,mfinformation+mfokbutton);
  547. exit;
  548. end;
  549. for i:=1 to count do
  550. if assigned(cfgdata[i]) then
  551. begin
  552. s:=cfgdata[i]^;
  553. Replace(s,'$1',data.basepath);
  554. Replace(s,'$target',targetname);
  555. writeln(t,s);
  556. end
  557. else
  558. writeln(t,'');
  559. close(t);
  560. end;
  561. {*****************************************************************************
  562. TUnZipDialog
  563. *****************************************************************************}
  564. constructor tunzipdialog.Init(var Bounds: TRect; ATitle: TTitleStr);
  565. var
  566. r : trect;
  567. begin
  568. inherited init(bounds,atitle);
  569. (* R.Assign (11, 4, 38, 6);*)
  570. R.Assign (1, 4,bounds.B.X-Bounds.A.X-2, 6);
  571. filetext:=new(pstatictext,init(r,#3'File: '));
  572. insert(filetext);
  573. R.Assign (1, 7,bounds.B.X-Bounds.A.X-2, 9);
  574. extractfiletext:=new(pstatictext,init(r,#3' '));
  575. insert(extractfiletext);
  576. end;
  577. {$IFNDEF DLL}
  578. procedure UnzipCheckFn (Retcode: longint; Rec: pReportRec );{$ifdef Delphi32}STDCALL;{$endif}
  579. {$IFNDEF BIT32} FAR;{$ENDIF BIT32}
  580. var
  581. name : string;
  582. begin
  583. case Rec^.Status of
  584. unzip_starting:
  585. UnzipErr := 0;
  586. file_starting:
  587. begin
  588. with UnzDlg^.extractfiletext^ do
  589. begin
  590. Disposestr(text);
  591. name:=Strpas(Rec^.FileName);
  592. Text:=NewStr(#3+name);
  593. DrawView;
  594. end;
  595. end;
  596. file_failure:
  597. UnzipErr := RetCode;
  598. file_unzipping:
  599. begin
  600. with UnzDlg^.FileText^ do
  601. begin
  602. Inc (StatusPos);
  603. if StatusPos > MaxStatusPos then StatusPos := 1;
  604. Text^ [Length (Text^)] := StatusChars [StatusPos];
  605. DrawView;
  606. end;
  607. end;
  608. end;
  609. end;
  610. {$ENDIF}
  611. procedure tunzipdialog.do_unzip(s,topath : string);
  612. var
  613. again : boolean;
  614. fn,dir,wild : string;
  615. Cnt: integer;
  616. begin
  617. Disposestr(filetext^.text);
  618. filetext^.Text:=NewStr(#3'File: '+s + #13#3' ');
  619. filetext^.drawview;
  620. if not(file_exists(s,startpath)) then
  621. begin
  622. messagebox('File "'+s+'" missing for the selected installation. '+
  623. 'Installation hasn''t been completed.',nil,mferror+mfokbutton);
  624. errorhalt;
  625. end;
  626. {$IFNDEF DLL}
  627. {$IFDEF FPC}
  628. SetUnzipReportProc (@UnzipCheckFn);
  629. {$ELSE FPC}
  630. SetUnzipReportProc (UnzipCheckFn);
  631. {$ENDIF FPC}
  632. {$ENDIF DLL}
  633. repeat
  634. fn:=startpath+DirSep+s+#0;
  635. dir:=topath+#0;
  636. wild:=AllFiles + #0;
  637. again:=false;
  638. FileUnzipEx(@fn[1],@dir[1],@wild[1]);
  639. if (UnzipErr <> 0) then
  640. begin
  641. Str(UnzipErr,s);
  642. if messagebox('Error (' + S + ') while extracting. Disk full?'#13+
  643. #13#3'Try again?',nil,mferror+mfyesbutton+mfnobutton)=cmNo then
  644. errorhalt
  645. else
  646. again:=true;
  647. end;
  648. until not again;
  649. end;
  650. {*****************************************************************************
  651. TEndDialog
  652. *****************************************************************************}
  653. constructor tenddialog.init;
  654. var
  655. R : TRect;
  656. P : PStaticText;
  657. Control : PButton;
  658. YB: word;
  659. {$IFNDEF LINUX}
  660. i : longint;
  661. S: string;
  662. WPath: boolean;
  663. {$ENDIF}
  664. {$IFDEF OS2}
  665. ErrPath: array [0..259] of char;
  666. Handle: longint;
  667. WLibPath: boolean;
  668. const
  669. EMXName: array [1..4] of char = 'EMX'#0;
  670. {$ENDIF}
  671. begin
  672. if haside then
  673. YB := 15
  674. else
  675. YB := 14;
  676. {$IFNDEF LINUX}
  677. s:='';
  678. for i:=1 to cfg.packs do
  679. if cfg.pack[i].binsub<>'' then
  680. begin
  681. if s<>'' then
  682. s:=s+';';
  683. S := s+Data.BasePath + Cfg.pack[i].BinSub;
  684. end;
  685. if Pos (Upper (S), Upper (GetEnv ('PATH'))) = 0 then
  686. begin
  687. WPath := true;
  688. Inc (YB, 2);
  689. end
  690. else
  691. WPath := false;
  692. {$IFDEF OS2}
  693. if DosLoadModule (@ErrPath, SizeOf (ErrPath), @EMXName, Handle) = 0 then
  694. begin
  695. WLibPath := false;
  696. DosFreeModule (Handle);
  697. end
  698. else
  699. begin
  700. WLibPath := true;
  701. Inc (YB, 2);
  702. end;
  703. {$ENDIF}
  704. {$ENDIF}
  705. R.Assign(6, 6, 74, YB);
  706. inherited init(r,'Installation Successfull');
  707. {$IFNDEF LINUX}
  708. if WPath then
  709. begin
  710. R.Assign(2, 3, 64, 5);
  711. P:=new(pstatictext,init(r,'Extend your PATH variable with '''+S+''''));
  712. insert(P);
  713. end;
  714. {$IFDEF OS2}
  715. if WLibPath then
  716. begin
  717. if WPath then
  718. S := 'and your LIBPATH with ''' + S + '\dll'''
  719. else
  720. S := 'Extend your LIBPATH with ''' + S + '\dll''';
  721. R.Assign (2, YB - 14, 64, YB - 12);
  722. P := New (PStaticText, Init (R, S));
  723. Insert (P);
  724. end;
  725. {$ENDIF}
  726. {$ENDIF}
  727. R.Assign(2, YB - 13, 64, YB - 12);
  728. P:=new(pstatictext,init(r,'To compile files enter '''+cfg.pack[1].ppc386+' [file]'''));
  729. insert(P);
  730. if haside then
  731. begin
  732. R.Assign(2, YB - 12, 64, YB - 10);
  733. P:=new(pstatictext,init(r,'To start the IDE (Integrated Development Environment) type ''fp'' at a command line prompt'));
  734. insert(P);
  735. end;
  736. R.Assign (29, YB - 9, 39, YB - 7);
  737. Control := New (PButton, Init (R,'~O~k', cmOK, bfDefault));
  738. Insert (Control);
  739. end;
  740. {*****************************************************************************
  741. TInstallDialog
  742. *****************************************************************************}
  743. {$ifdef MAYBE_LFN}
  744. var
  745. islfn : boolean;
  746. procedure lfnreport( Retcode : longint;Rec : pReportRec );
  747. var
  748. p : pathstr;
  749. n : namestr;
  750. e : extstr;
  751. begin
  752. fsplit(strpas(rec^.Filename),p,n,e);
  753. if (length(n)>8) or (length(e)>4) then
  754. islfn:=true;
  755. end;
  756. function haslfn(const zipfile,path : string) : boolean;
  757. var
  758. buf : array[0..255] of char;
  759. begin
  760. strpcopy(buf,path+DirSep+zipfile);
  761. islfn:=false;
  762. {$ifdef FPC}
  763. ViewZip(buf,AllFiles,@lfnreport);
  764. {$else FPC}
  765. ViewZip(buf,AllFiles,lfnreport);
  766. {$endif FPC}
  767. haslfn:=islfn;
  768. end;
  769. {$endif MAYBE_LFN}
  770. constructor tinstalldialog.init;
  771. const
  772. width = 76;
  773. height = 20;
  774. x1 = (79-width) div 2;
  775. y1 = (23-height) div 2;
  776. x2 = x1+width;
  777. y2 = y1+height;
  778. var
  779. tabr,tabir,r : trect;
  780. packmask : array[1..maxpacks] of longint;
  781. i,line,j : integer;
  782. items : array[1..maxpacks] of psitem;
  783. f : pview;
  784. found : boolean;
  785. okbut,cancelbut : pbutton;
  786. firstitem : array[1..maxpacks] of integer;
  787. packcbs : array[1..maxpacks] of pcheckboxes;
  788. packtd : ptabdef;
  789. labpath : plabel;
  790. ilpath : pinputline;
  791. tab : ptab;
  792. titletext : pcoloredtext;
  793. labcfg : plabel;
  794. cfgcb : pcheckboxes;
  795. scrollbox: pscrollbox;
  796. sbr,sbsbr: trect;
  797. sbsb: pscrollbar;
  798. begin
  799. f:=nil;
  800. { walk packages reverse and insert a newsitem for each, and set the mask }
  801. for j:=1 to cfg.packs do
  802. with cfg.pack[j] do
  803. begin
  804. firstitem[j]:=0;
  805. items[j]:=nil;
  806. packmask[j]:=0;
  807. for i:=packages downto 1 do
  808. begin
  809. if file_exists(package[i].zip,startpath) then
  810. begin
  811. {$ifdef MAYBE_LFN}
  812. if not(locallfnsupport) then
  813. begin
  814. if not(haslfn(package[i].zip,startpath)) then
  815. begin
  816. items[j]:=newsitem(package[i].name+diskspace(startpath+DirSep+package[i].zip),items[j]);
  817. packmask[j]:=packmask[j] or packagemask(i);
  818. firstitem[j]:=i;
  819. if createlog then
  820. writeln(log,'Checking lfn usage for ',startpath+DirSep+package[i].zip,' ... no lfn');
  821. end
  822. else
  823. begin
  824. items[j]:=newsitem(package[i].name+' (requires LFN support)',items[j]);
  825. packmask[j]:=packmask[j] or packagemask(i);
  826. firstitem[j]:=i;
  827. if createlog then
  828. writeln(log,'Checking lfn usage for ',startpath+DirSep+package[i].zip,' ... uses lfn');
  829. end;
  830. end
  831. else
  832. {$endif MAYBE_LFN}
  833. begin
  834. items[j]:=newsitem(package[i].name+diskspace(startpath+DirSep+package[i].zip),items[j]);
  835. packmask[j]:=packmask[j] or packagemask(i);
  836. firstitem[j]:=i;
  837. end;
  838. end
  839. else
  840. items[j]:=newsitem(package[i].name,items[j]);
  841. end;
  842. end;
  843. { If no component found abort }
  844. found:=false;
  845. for j:=1 to cfg.packs do
  846. if packmask[j]<>0 then
  847. found:=true;
  848. if not found then
  849. begin
  850. messagebox('No components found to install, aborting.',nil,mferror+mfokbutton);
  851. errorhalt;
  852. end;
  853. r.assign(x1,y1,x2,y2);
  854. inherited init(r,'');
  855. GetExtent(R);
  856. R.Grow(-2,-1);
  857. Dec(R.B.Y,2);
  858. TabR.Copy(R);
  859. TabIR.Copy(R);
  860. TabIR.Grow(-2,-2);
  861. TabIR.Move(-2,0);
  862. {-------- General Sheets ----------}
  863. R.Copy(TabIR);
  864. r.move(0,1);
  865. r.b.x:=r.a.x+40;
  866. r.b.y:=r.a.y+1;
  867. new(titletext,init(r,cfg.title,$71));
  868. r.move(0,2);
  869. r.b.x:=r.a.x+40;
  870. new(labpath,init(r,'~B~ase path',f));
  871. r.move(0,1);
  872. r.b.x:=r.a.x+40;
  873. r.b.y:=r.a.y+1;
  874. new(ilpath,init(r,high(DirStr)));
  875. r.move(0,2);
  876. r.b.x:=r.a.x+40;
  877. new(labcfg,init(r,'Con~f~ig',f));
  878. r.move(0,1);
  879. r.b.x:=r.a.x+40;
  880. r.b.y:=r.a.y+1;
  881. new(cfgcb,init(r,newsitem('create fpc.cfg',nil)));
  882. data.cfgval:=1;
  883. {-------- Pack Sheets ----------}
  884. for j:=1 to cfg.packs do
  885. begin
  886. R.Copy(TabIR);
  887. if R.A.Y+cfg.pack[j].packages>R.B.Y then
  888. R.B.Y:=R.A.Y+cfg.pack[j].packages;
  889. new(packcbs[j],init(r,items[j]));
  890. if data.packmask[j]=$ffff then
  891. data.packmask[j]:=packmask[j];
  892. packcbs[j]^.enablemask:={$ifdef DEV}$7fffffff{$else}packmask[j]{$endif};
  893. packcbs[j]^.movedto(firstitem[j]);
  894. end;
  895. {--------- Main ---------}
  896. packtd:=nil;
  897. sbr.assign(1,3,tabr.b.x-tabr.a.x-3,tabr.b.y-tabr.a.y-1);
  898. for j:=cfg.packs downto 1 do
  899. begin
  900. if (sbr.b.y-sbr.a.y)<cfg.pack[j].packages then
  901. begin
  902. sbsbr.assign(sbr.b.x,sbr.a.y,sbr.b.x+1,sbr.b.y);
  903. New(sbsb, init(sbsbr));
  904. end
  905. else
  906. sbsb:=nil;
  907. New(ScrollBox, Init(sbr, nil, sbsb));
  908. PackCbs[j]^.MoveTo(0,0);
  909. ScrollBox^.Insert(PackCbs[j]);
  910. packtd:=NewTabDef(
  911. cfg.pack[j].name,ScrollBox,
  912. NewTabItem(sbsb,
  913. NewTabItem(ScrollBox,
  914. nil)),
  915. packtd);
  916. end;
  917. New(Tab, Init(TabR,
  918. NewTabDef('~G~eneral',IlPath,
  919. NewTabItem(TitleText,
  920. NewTabItem(LabPath,
  921. NewTabItem(ILPath,
  922. NewTabItem(LabCfg,
  923. NewTabItem(CfgCB,
  924. nil))))),
  925. packtd)
  926. ));
  927. Tab^.GrowMode:=0;
  928. Insert(Tab);
  929. line:=tabr.b.y;
  930. r.assign((width div 2)-18,line,(width div 2)-4,line+2);
  931. new(okbut,init(r,'~C~ontinue',cmok,bfdefault));
  932. Insert(OkBut);
  933. r.assign((width div 2)+4,line,(width div 2)+14,line+2);
  934. new(cancelbut,init(r,'~Q~uit',cmcancel,bfnormal));
  935. Insert(CancelBut);
  936. Tab^.Select;
  937. end;
  938. {*****************************************************************************
  939. TApp
  940. *****************************************************************************}
  941. const
  942. cmstart = 1000;
  943. procedure tapp.do_installdialog;
  944. var
  945. p : pinstalldialog;
  946. p3 : penddialog;
  947. r : trect;
  948. result,
  949. c : word;
  950. i,j : longint;
  951. found : boolean;
  952. {$ifndef linux}
  953. DSize,Space,ASpace : longint;
  954. S: DirStr;
  955. {$endif}
  956. procedure doconfigwrite;
  957. var
  958. i : longint;
  959. begin
  960. for i:=1 to cfg.packs do
  961. if cfg.pack[i].defcfgfile<>'' then
  962. writedefcfg(data.basepath+cfg.pack[i].binsub+DirSep+cfg.pack[i].defcfgfile,cfg.defcfg,cfg.defcfgs,cfg.pack[i].targetname);
  963. if haside then
  964. begin
  965. for i:=1 to cfg.packs do
  966. if cfg.pack[i].defidecfgfile<>'' then
  967. writedefcfg(data.basepath+cfg.pack[i].binsub+DirSep+cfg.pack[i].defidecfgfile,cfg.defidecfg,cfg.defidecfgs,cfg.pack[i].targetname);
  968. for i:=1 to cfg.packs do
  969. if cfg.pack[i].defideinifile<>'' then
  970. writedefcfg(data.basepath+cfg.pack[i].binsub+DirSep+cfg.pack[i].defideinifile,cfg.defideini,cfg.defideinis,cfg.pack[i].targetname);
  971. if hashtmlhelp then
  972. writehlpindex(data.basepath+DirSep+cfg.DocSub+DirSep+cfg.helpidx);
  973. end;
  974. end;
  975. begin
  976. data.basepath:=cfg.basepath;
  977. data.cfgval:=0;
  978. for j:=1 to cfg.packs do
  979. data.packmask[j]:=$ffff;
  980. repeat
  981. { select components }
  982. p:=new(pinstalldialog,init);
  983. c:=executedialog(p,@data);
  984. if (c=cmok) then
  985. begin
  986. if Data.BasePath = '' then
  987. messagebox('Please, choose the directory for installation first.',nil,mferror+mfokbutton)
  988. else
  989. begin
  990. found:=false;
  991. for j:=1 to cfg.packs do
  992. if data.packmask[j]>0 then
  993. found:=true;
  994. if found then
  995. begin
  996. {$IFNDEF LINUX}
  997. { TH - check the available disk space here }
  998. DSize := 0;
  999. for j:=1 to cfg.packs do
  1000. with cfg.pack[j] do
  1001. begin
  1002. for i:=1 to packages do
  1003. begin
  1004. if data.packmask[j] and packagemask(i)<>0 then
  1005. begin
  1006. ASpace := DiskSpaceN (package[i].zip);
  1007. if ASpace = -1 then
  1008. MessageBox ('File ' + package[i].zip +
  1009. ' is probably corrupted!', nil,
  1010. mferror + mfokbutton)
  1011. else Inc (DSize, ASpace);
  1012. end;
  1013. end;
  1014. end;
  1015. S := FExpand (Data.BasePath);
  1016. if S [Length (S)] = DirSep then
  1017. Dec (S [0]);
  1018. Space := DiskFree (byte (Upcase(S [1])) - 64) shr 10;
  1019. if Space < DSize then
  1020. S := 'is not'
  1021. else
  1022. S := '';
  1023. if (Space < DSize + 500) then
  1024. begin
  1025. if S = '' then
  1026. S := 'might not be';
  1027. if messagebox('There ' + S + ' enough space on the target ' +
  1028. 'drive for all the selected components. Do you ' +
  1029. 'want to change the installation path?',nil,
  1030. mferror+mfyesbutton+mfnobutton) = cmYes then
  1031. Continue;
  1032. end;
  1033. {$ENDIF}
  1034. if createinstalldir(data.basepath) then
  1035. break;
  1036. end
  1037. else
  1038. begin
  1039. { maybe only config }
  1040. if (data.cfgval and 1)<>0 then
  1041. begin
  1042. result:=messagebox('No components selected.'#13#13'Create a configfile ?',nil,
  1043. mfinformation+mfyesbutton+mfnobutton);
  1044. if (result=cmYes) and createinstalldir(data.basepath) then
  1045. doconfigwrite;
  1046. exit;
  1047. end
  1048. else
  1049. begin
  1050. result:=messagebox('No components selected.'#13#13'Abort installation?',nil,
  1051. mferror+mfyesbutton+mfnobutton);
  1052. if result=cmYes then
  1053. exit;
  1054. end;
  1055. end;
  1056. end;
  1057. end
  1058. else
  1059. exit;
  1060. until false;
  1061. { extract packages }
  1062. for j:=1 to cfg.packs do
  1063. with cfg.pack[j] do
  1064. begin
  1065. r.assign(10,7,70,18);
  1066. UnzDlg:=new(punzipdialog,init(r,'Extracting Packages'));
  1067. desktop^.insert(UnzDlg);
  1068. for i:=1 to packages do
  1069. begin
  1070. if data.packmask[j] and packagemask(i)<>0 then
  1071. begin
  1072. UnzDlg^.do_unzip(package[i].zip,data.basepath);
  1073. { gather some information about the installed files }
  1074. if copy(package[i].zip,1,3)='ide' then
  1075. haside:=true;
  1076. if copy(package[i].zip,1,7)='doc-htm' then
  1077. hashtmlhelp:=true;
  1078. end;
  1079. end;
  1080. desktop^.delete(UnzDlg);
  1081. dispose(UnzDlg,done);
  1082. end;
  1083. { write config }
  1084. if (data.cfgval and 1)<>0 then
  1085. doconfigwrite;
  1086. { show end message }
  1087. p3:=new(penddialog,init);
  1088. executedialog(p3,nil);
  1089. end;
  1090. procedure tapp.readcfg(const fn:string);
  1091. var
  1092. t : text;
  1093. i,j,
  1094. line : longint;
  1095. item,
  1096. s : string;
  1097. params : array[0..0] of pointer;
  1098. {$ifndef FPC}
  1099. procedure readln(var t:text;var s:string);
  1100. var
  1101. c : char;
  1102. i : longint;
  1103. begin
  1104. c:=#0;
  1105. i:=0;
  1106. while (not eof(t)) and (c<>#10) do
  1107. begin
  1108. read(t,c);
  1109. if c<>#10 then
  1110. begin
  1111. inc(i);
  1112. s[i]:=c;
  1113. end;
  1114. end;
  1115. if (i>0) and (s[i]=#13) then
  1116. dec(i);
  1117. s[0]:=chr(i);
  1118. end;
  1119. {$endif}
  1120. begin
  1121. assign(t,StartPath + DirSep + fn);
  1122. {$I-}
  1123. reset(t);
  1124. {$I+}
  1125. if ioresult<>0 then
  1126. begin
  1127. StartPath := GetProgDir;
  1128. assign(t,StartPath + DirSep + fn);
  1129. {$I-}
  1130. reset(t);
  1131. {$I+}
  1132. if ioresult<>0 then
  1133. begin
  1134. params[0]:=@fn;
  1135. messagebox('File %s not found!',@params,mferror+mfokbutton);
  1136. errorhalt;
  1137. end;
  1138. end;
  1139. line:=0;
  1140. while not eof(t) do
  1141. begin
  1142. readln(t,s);
  1143. inc(line);
  1144. if (s<>'') and not(s[1] in ['#',';']) then
  1145. begin
  1146. i:=pos('=',s);
  1147. if i>0 then
  1148. begin
  1149. item:=upper(Copy(s,1,i-1));
  1150. system.delete(s,1,i);
  1151. if item='VERSION' then
  1152. cfg.version:=s
  1153. else
  1154. if item='TITLE' then
  1155. cfg.title:=s
  1156. else
  1157. if item='BASEPATH' then
  1158. cfg.basepath:=s
  1159. else
  1160. if item='HELPIDX' then
  1161. cfg.helpidx:=s
  1162. else
  1163. if item='DOCSUB' then
  1164. cfg.docsub:=s
  1165. else
  1166. if item='DEFAULTCFG' then
  1167. begin
  1168. repeat
  1169. readln(t,s);
  1170. if upper(s)='ENDCFG' then
  1171. break;
  1172. if cfg.defcfgs<maxdefcfgs then
  1173. begin
  1174. inc(cfg.defcfgs);
  1175. cfg.defcfg[cfg.defcfgs]:=newstr(s);
  1176. end;
  1177. until false;
  1178. end
  1179. else if item='DEFAULTIDECFG' then
  1180. begin
  1181. repeat
  1182. readln(t,s);
  1183. if upper(s)='ENDCFG' then
  1184. break;
  1185. if cfg.defidecfgs<maxdefcfgs then
  1186. begin
  1187. inc(cfg.defidecfgs);
  1188. cfg.defidecfg[cfg.defidecfgs]:=newstr(s);
  1189. end;
  1190. until false;
  1191. end
  1192. else if item='DEFAULTIDEINI' then
  1193. begin
  1194. repeat
  1195. readln(t,s);
  1196. if upper(s)='ENDCFG' then
  1197. break;
  1198. if cfg.defideinis<maxdefcfgs then
  1199. begin
  1200. inc(cfg.defideinis);
  1201. cfg.defideini[cfg.defideinis]:=newstr(s);
  1202. end;
  1203. until false;
  1204. end
  1205. else
  1206. if item='PACK' then
  1207. begin
  1208. inc(cfg.packs);
  1209. if cfg.packs>maxpacks then
  1210. begin
  1211. writeln('Too many packs');
  1212. halt(1);
  1213. end;
  1214. cfg.pack[cfg.packs].name:=s;
  1215. end
  1216. else
  1217. if item='CFGFILE' then
  1218. begin
  1219. if cfg.packs=0 then
  1220. begin
  1221. writeln('No pack set');
  1222. halt(1);
  1223. end;
  1224. cfg.pack[cfg.packs].defcfgfile:=s
  1225. end
  1226. else
  1227. if item='IDECFGFILE' then
  1228. begin
  1229. if cfg.packs=0 then
  1230. begin
  1231. writeln('No pack set');
  1232. halt(1);
  1233. end;
  1234. cfg.pack[cfg.packs].defidecfgfile:=s
  1235. end
  1236. else
  1237. if item='IDEINIFILE' then
  1238. begin
  1239. if cfg.packs=0 then
  1240. begin
  1241. writeln('No pack set');
  1242. halt(1);
  1243. end;
  1244. cfg.pack[cfg.packs].defideinifile:=s
  1245. end
  1246. else
  1247. if item='PPC386' then
  1248. begin
  1249. if cfg.packs=0 then
  1250. begin
  1251. writeln('No pack set');
  1252. halt(1);
  1253. end;
  1254. cfg.pack[cfg.packs].ppc386:=s;
  1255. end
  1256. else
  1257. if item='BINSUB' then
  1258. begin
  1259. if cfg.packs=0 then
  1260. begin
  1261. writeln('No pack set');
  1262. halt(1);
  1263. end;
  1264. cfg.pack[cfg.packs].binsub:=s;
  1265. end
  1266. else
  1267. if item='FILECHECK' then
  1268. begin
  1269. if cfg.packs=0 then
  1270. begin
  1271. writeln('No pack set');
  1272. halt(1);
  1273. end;
  1274. cfg.pack[cfg.packs].filechk:=s;
  1275. end
  1276. else
  1277. if item='TARGETNAME' then
  1278. begin
  1279. if cfg.packs=0 then
  1280. begin
  1281. writeln('No pack set');
  1282. halt(1);
  1283. end;
  1284. cfg.pack[cfg.packs].targetname:=s;
  1285. end
  1286. else
  1287. if item='PACKAGE' then
  1288. begin
  1289. if cfg.packs=0 then
  1290. begin
  1291. writeln('No pack set');
  1292. halt(1);
  1293. end;
  1294. with cfg.pack[cfg.packs] do
  1295. begin
  1296. j:=pos(',',s);
  1297. if (j>0) and (packages<maxpackages) then
  1298. begin
  1299. inc(packages);
  1300. package[packages].zip:=copy(s,1,j-1);
  1301. package[packages].name:=copy(s,j+1,255);
  1302. end;
  1303. end;
  1304. end
  1305. end;
  1306. end;
  1307. end;
  1308. close(t);
  1309. end;
  1310. procedure tapp.checkavailpack;
  1311. var
  1312. j : longint;
  1313. dir : searchrec;
  1314. begin
  1315. { check the packages }
  1316. j:=0;
  1317. while (j<cfg.packs) do
  1318. begin
  1319. inc(j);
  1320. if cfg.pack[j].filechk<>'' then
  1321. begin
  1322. findfirst(cfg.pack[j].filechk,$20,dir);
  1323. if doserror<>0 then
  1324. begin
  1325. { remove the package }
  1326. move(cfg.pack[j+1],cfg.pack[j],sizeof(tpack)*(cfg.packs-j));
  1327. dec(cfg.packs);
  1328. dec(j);
  1329. end;
  1330. {$IFNDEF TP}
  1331. findclose(dir);
  1332. {$ENDIF}
  1333. end;
  1334. end;
  1335. end;
  1336. procedure tapp.initmenubar;
  1337. var
  1338. r : trect;
  1339. begin
  1340. getextent(r);
  1341. r.b.y:=r.a.y+1;
  1342. menubar:=new(pmenubar,init(r,newmenu(
  1343. newsubmenu('Free Pascal Installer',hcnocontext,newmenu(nil
  1344. ),
  1345. nil))));
  1346. end;
  1347. procedure tapp.handleevent(var event : tevent);
  1348. begin
  1349. inherited handleevent(event);
  1350. if event.what=evcommand then
  1351. if event.command=cmstart then
  1352. begin
  1353. clearevent(event);
  1354. do_installdialog;
  1355. if successfull then
  1356. begin
  1357. event.what:=evcommand;
  1358. event.command:=cmquit;
  1359. handleevent(event);
  1360. end;
  1361. end;
  1362. end;
  1363. {$IFDEF DOSSTUB}
  1364. function CheckOS2: boolean;
  1365. var
  1366. OwnName: PathStr;
  1367. OwnDir: DirStr;
  1368. Name: NameStr;
  1369. Ext: ExtStr;
  1370. DosV, W: word;
  1371. P: PChar;
  1372. const
  1373. Title: string [15] = 'FPC Installer'#0;
  1374. RunBlock: TRunBlock = (Length: $32;
  1375. Dependent: 0;
  1376. Background: 0;
  1377. TraceLevel: 0;
  1378. PrgTitle: @Title [1];
  1379. PrgName: nil;
  1380. Args: nil;
  1381. TermQ: 0;
  1382. Environment: nil;
  1383. Inheritance: 0;
  1384. SesType: 2;
  1385. Icon: nil;
  1386. PgmHandle: 0;
  1387. PgmControl: 2;
  1388. Column: 0;
  1389. Row: 0;
  1390. Width: 80;
  1391. Height: 25);
  1392. begin
  1393. CheckOS2 := false;
  1394. asm
  1395. mov ah, 30h
  1396. int 21h
  1397. xchg ah, al
  1398. mov DosV, ax
  1399. mov ax, 4010h
  1400. int 2Fh
  1401. cmp ax, 4010h
  1402. jnz @0
  1403. xor bx, bx
  1404. @0:
  1405. mov W, bx
  1406. end;
  1407. if DosV > 3 shl 8 then
  1408. begin
  1409. OwnName := FExpand (ParamStr (0));
  1410. FSplit (OwnName, OwnDir, Name, Ext);
  1411. if (DosV >= 20 shl 8 + 10) and (W >= 20 shl 8 + 10) then
  1412. (* OS/2 version 2.1 or later running (double-checked) *)
  1413. begin
  1414. OwnName [Succ (byte (OwnName [0]))] := #0;
  1415. RunBlock.PrgName := @OwnName [1];
  1416. P := Ptr (PrefixSeg, $80);
  1417. if PByte (P)^ <> 0 then
  1418. begin
  1419. Inc (P);
  1420. RunBlock.Args := Ptr (PrefixSeg, $81);
  1421. end;
  1422. asm
  1423. mov ax, 6400h
  1424. mov bx, 0025h
  1425. mov cx, 636Ch
  1426. mov si, offset RunBlock
  1427. int 21h
  1428. jc @0
  1429. mov DosV, 0
  1430. @0:
  1431. end;
  1432. CheckOS2 := DosV = 0;
  1433. end;
  1434. end;
  1435. end;
  1436. {$ENDIF}
  1437. var
  1438. i : longint;
  1439. begin
  1440. { register objects for help streaming }
  1441. RegisterWHTMLScan;
  1442. {$ifdef FPC}
  1443. {$ifdef win32}
  1444. Dos.Exec(GetEnv('COMSPEC'),'/C echo This dummy call gets the mouse to become visible');
  1445. {$endif win32}
  1446. {$endif FPC}
  1447. (* TH - no error boxes if checking an inaccessible disk etc. *)
  1448. {$IFDEF OS2}
  1449. {$IFDEF FPC}
  1450. DosCalls.DosError (0);
  1451. {$ELSE FPC}
  1452. {$IFDEF VirtualPascal}
  1453. OS2Base.DosError (ferr_DisableHardErr);
  1454. {$ELSE VirtualPascal}
  1455. BseDos.DosError (0);
  1456. {$ENDIF VirtualPascal}
  1457. {$ENDIF FPC}
  1458. {$ENDIF}
  1459. {$IFDEF DOSSTUB}
  1460. if CheckOS2 then Halt;
  1461. {$ENDIF}
  1462. createlog:=false;
  1463. {$ifdef MAYBE_LFN}
  1464. locallfnsupport:=system.lfnsupport;
  1465. {$endif MAYBE_LFN}
  1466. for i:=1 to paramcount do
  1467. begin
  1468. if paramstr(i)='-l' then
  1469. createlog:=true
  1470. {$ifdef MAYBE_LFN}
  1471. else if paramstr(i)='--nolfn' then
  1472. locallfnsupport:=false
  1473. {$endif MAYBE_LFN}
  1474. else if paramstr(i)='-h' then
  1475. begin
  1476. writeln('FPC Installer Copyright (c) 1993-2001 Florian Klaempfl');
  1477. writeln('Command line options:');
  1478. writeln(' -l create log file');
  1479. {$ifdef MAYBE_LFN}
  1480. writeln(' --nolfn force installation with short file names');
  1481. {$endif MAYBE_LFN}
  1482. writeln;
  1483. writeln(' -h displays this help');
  1484. halt(0);
  1485. end
  1486. else
  1487. begin
  1488. writeln('Illegal command line parameter: ',paramstr(i));
  1489. halt(1);
  1490. end;
  1491. end;
  1492. if createlog then
  1493. begin
  1494. assign(log,'install.log');
  1495. rewrite(log);
  1496. {$ifdef MAYBE_LFN}
  1497. if not(locallfnsupport) then
  1498. writeln(log,'OS doesn''t have LFN support');
  1499. {$endif}
  1500. end;
  1501. getdir(0,startpath);
  1502. successfull:=false;
  1503. fillchar(cfg, SizeOf(cfg), 0);
  1504. fillchar(data, SizeOf(data), 0);
  1505. installapp.init;
  1506. FSplit (FExpand (ParamStr (0)), DStr, CfgName, EStr);
  1507. installapp.readcfg(CfgName + CfgExt);
  1508. installapp.checkavailpack;
  1509. { installapp.readcfg(startpath+dirsep+cfgfile);}
  1510. {$ifdef GO32V2}
  1511. if not(lfnsupport) then
  1512. MessageBox('The operating system doesn''t support LFN (long file names),'+
  1513. ' so some packages will get shorten filenames when installed',nil,mfinformation or mfokbutton);
  1514. {$endif}
  1515. installapp.do_installdialog;
  1516. installapp.done;
  1517. if createlog then
  1518. close(log);
  1519. end.
  1520. {
  1521. $Log$
  1522. Revision 1.3 2002-02-28 17:02:08 pierre
  1523. * fix win32 compilation if DEBUG cond is set
  1524. Revision 1.2 2002/01/29 22:01:17 peter
  1525. * support fvision
  1526. Revision 1.1 2002/01/29 17:59:15 peter
  1527. * moved installer
  1528. Revision 1.2.2.16 2001/11/24 14:29:54 carl
  1529. * ppc386.cfg -> fpc.cfg
  1530. Revision 1.2.2.15 2001/05/02 16:22:43 pierre
  1531. + Shorten file names to comply with Dos 8+3 limitation
  1532. Revision 1.2.2.14 2001/04/19 15:50:24 pierre
  1533. * remove use of reals so emu387 is not needed anymore
  1534. Revision 1.2.2.13 2001/01/02 09:43:12 florian
  1535. * vresion fixed
  1536. Revision 1.2.2.12 2001/01/02 09:35:50 florian
  1537. * targetname is now read from the .dat file too
  1538. Revision 1.2.2.11 2000/11/26 19:02:58 hajny
  1539. * English correction
  1540. Revision 1.2.2.10 2000/11/26 16:49:57 hajny
  1541. * removed unneeded OS/2 conditionals
  1542. Revision 1.2.2.9 2000/11/09 22:02:33 florian
  1543. * fixed bug 1226: wrong target for the win32 IDE
  1544. Revision 1.2.2.8 2000/10/11 18:08:45 peter
  1545. * lfnsupport is only for go32v2
  1546. Revision 1.2.2.7 2000/10/11 16:49:02 florian
  1547. + fixed a typo and the setting of haside and hashtmlhelp
  1548. Revision 1.2.2.6 2000/10/11 13:10:20 florian
  1549. + added preconfiguratioh of help files
  1550. Revision 1.2.2.5 2000/10/10 22:12:10 florian
  1551. + added a message how to start the IDE
  1552. Revision 1.2.2.4 2000/10/10 16:36:12 florian
  1553. + creation of IDE configuration files added
  1554. Revision 1.2.2.3 2000/09/24 10:52:14 peter
  1555. * window can now also be smaller again
  1556. Revision 1.2.2.2 2000/09/22 08:41:36 pierre
  1557. * add emulation for go32v2 and display currently extraced file
  1558. Revision 1.2.2.1 2000/09/21 10:57:11 pierre
  1559. changes by Gabor for scrolling support
  1560. Revision 1.2 2000/07/21 10:43:01 florian
  1561. + added for lfn support
  1562. Revision 1.1 2000/07/13 06:30:21 michael
  1563. + Initial import
  1564. Revision 1.20 2000/07/09 12:55:45 hajny
  1565. * updated for version 1.0
  1566. Revision 1.19 2000/06/18 18:27:32 hajny
  1567. + archive validity checking, progress indicator, better error checking
  1568. Revision 1.18 2000/02/24 17:47:47 peter
  1569. * last fixes for 0.99.14a release
  1570. Revision 1.17 2000/02/23 17:17:56 peter
  1571. * write ppc386.cfg for all found targets
  1572. Revision 1.16 2000/02/06 12:59:39 peter
  1573. * change upper -> upcase
  1574. * fixed stupid debugging leftover with diskspace check
  1575. Revision 1.15 2000/02/02 17:19:10 pierre
  1576. * avoid diskfree problem and get mouse visible
  1577. Revision 1.14 2000/02/02 15:21:31 peter
  1578. * show errorcode in message when error in unzipping
  1579. Revision 1.13 2000/01/26 21:49:33 peter
  1580. * install.pas compilable by FPC again
  1581. * removed some notes from unzip.pas
  1582. * support installer creation under linux (install has name conflict)
  1583. Revision 1.12 2000/01/26 21:15:59 hajny
  1584. * compilable with TP again (lines < 127install.pas, ifdef around findclose)
  1585. Revision 1.11 2000/01/24 22:21:48 peter
  1586. * new install version (keys not wrong correct yet)
  1587. Revision 1.10 2000/01/18 00:22:48 peter
  1588. * fixed uninited local var
  1589. Revision 1.9 1999/08/03 20:21:53 peter
  1590. * fixed sources mask which was not set correctly
  1591. Revision 1.7 1999/07/01 07:56:58 hajny
  1592. * installation to root fixed
  1593. Revision 1.6 1999/06/29 22:20:19 peter
  1594. * updated to use tab pages
  1595. Revision 1.5 1999/06/25 07:06:30 hajny
  1596. + searching for installation script updated
  1597. Revision 1.4 1999/06/10 20:01:23 peter
  1598. + fcl,fv,gtk support
  1599. Revision 1.3 1999/06/10 15:00:14 peter
  1600. * fixed to compile for not os2
  1601. * update install.dat
  1602. Revision 1.2 1999/06/10 07:28:27 hajny
  1603. * compilable with TP again
  1604. Revision 1.1 1999/02/19 16:45:26 peter
  1605. * moved to fpinst/ directory
  1606. + makefile
  1607. Revision 1.15 1999/02/17 22:34:08 peter
  1608. * updates from TH for OS2
  1609. Revision 1.14 1998/12/22 22:47:34 peter
  1610. * updates for OS2
  1611. * small fixes
  1612. Revision 1.13 1998/12/21 13:11:39 peter
  1613. * updates for 0.99.10
  1614. Revision 1.12 1998/12/16 00:25:34 peter
  1615. * updated for 0.99.10
  1616. * new end dialogbox
  1617. Revision 1.11 1998/11/01 20:32:25 peter
  1618. * packed record
  1619. Revision 1.10 1998/10/25 23:38:35 peter
  1620. * removed warnings
  1621. Revision 1.9 1998/10/23 16:57:40 pierre
  1622. * compiles without -So option
  1623. * the main dialog init was buggy !!
  1624. Revision 1.8 1998/09/22 21:10:31 jonas
  1625. * initialize cfg and data with 0 at startup
  1626. Revision 1.7 1998/09/16 16:46:37 peter
  1627. + updates
  1628. Revision 1.6 1998/09/15 13:11:14 pierre
  1629. small fix to cleanup if no package
  1630. Revision 1.5 1998/09/15 12:06:06 peter
  1631. * install updated to support w32 and dos and config file
  1632. Revision 1.4 1998/09/10 10:50:49 florian
  1633. * DOS install program updated
  1634. Revision 1.3 1998/09/09 13:39:58 peter
  1635. + internal unzip
  1636. * dialog is showed automaticly
  1637. Revision 1.2 1998/04/07 22:47:57 florian
  1638. + version/release/patch numbers as string added
  1639. }