install.pas 24 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984
  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 version 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 FV} (* TH - added to make use of the original Turbo Vision possible. *)
  15. { $DEFINE DLL} (* TH - if defined, UNZIP32.DLL library is used to unpack. *)
  16. { $DEFINE DOSSTUB} (* TH - should _not_ be defined unless creating a bound DOS and OS/2 installer!!! *)
  17. (* Defining DOSSTUB causes adding a small piece of code *)
  18. (* for starting the OS/2 part from the DOS part of a bound *)
  19. (* application if running in OS/2 VDM (DOS) window. Used *)
  20. (* only if compiling with TP/BP (see conditionals below). *)
  21. {$IFDEF VER60}
  22. {$DEFINE TP}
  23. {$ENDIF}
  24. {$IFDEF VER70}
  25. {$DEFINE TP}
  26. {$ENDIF}
  27. {$IFDEF OS2}
  28. {$UNDEF FV}
  29. {$IFDEF DOSSTUB}
  30. {$UNDEF DOSSTUB}
  31. {$ENDIF}
  32. {$IFDEF VIRTUALPASCAL}
  33. {$DEFINE DLL}
  34. {$ENDIF}
  35. {$ENDIF}
  36. {$IFDEF WIN32}
  37. {$IFDEF DOSSTUB}
  38. {$UNDEF DOSSTUB}
  39. {$ENDIF}
  40. {$ENDIF}
  41. {$IFDEF FPC}
  42. {$IFDEF DOSSTUB}
  43. {$UNDEF DOSSTUB}
  44. {$ENDIF}
  45. {$ENDIF}
  46. {$IFDEF DPMI}
  47. {$IFDEF DOSSTUB}
  48. {$UNDEF DOSSTUB}
  49. {$ENDIF}
  50. {$ENDIF}
  51. uses
  52. {$IFDEF OS2}
  53. {$IFDEF FPC}
  54. DosCalls,
  55. {$ELSE FPC}
  56. {$IFDEF VirtualPascal}
  57. OS2Base,
  58. {$ELSE VirtualPascal}
  59. BseDos,
  60. {$ENDIF VirtualPascal}
  61. {$ENDIF FPC}
  62. {$ENDIF OS2}
  63. {$ifdef HEAPTRC}
  64. heaptrc,
  65. {$endif HEAPTRC}
  66. strings,dos,objects,drivers,
  67. {$IFDEF FV}
  68. commands,
  69. {$ENDIF}
  70. unzip,ziptypes,
  71. {$IFDEF DLL}
  72. unzipdll,
  73. {$ENDIF}
  74. app,dialogs,views,menus,msgbox;
  75. const
  76. maxpackages=20;
  77. maxdefcfgs=1024;
  78. cfgfile='install.dat';
  79. {$ifdef linux}
  80. DirSep='/';
  81. {$else}
  82. DirSep='\';
  83. {$endif}
  84. type
  85. tpackage=record
  86. name : string[60];
  87. zip : string[12];
  88. end;
  89. cfgrec=record
  90. title : string[80];
  91. version : string[20];
  92. basepath : DirStr;
  93. binsub : string[12];
  94. ppc386 : string[12];
  95. packages : longint;
  96. package : array[1..maxpackages] of tpackage;
  97. defcfgfile : string[12];
  98. defcfgs : longint;
  99. defcfg : array[1..maxdefcfgs] of pstring;
  100. end;
  101. datarec=packed record
  102. basepath : DirStr;
  103. mask : word;
  104. end;
  105. punzipdialog=^tunzipdialog;
  106. tunzipdialog=object(tdialog)
  107. filetext : pstatictext;
  108. constructor Init(var Bounds: TRect; ATitle: TTitleStr);
  109. procedure do_unzip(s,topath:string);
  110. end;
  111. penddialog = ^tenddialog;
  112. tenddialog = object(tdialog)
  113. constructor init;
  114. end;
  115. pinstalldialog = ^tinstalldialog;
  116. tinstalldialog = object(tdialog)
  117. constructor init;
  118. end;
  119. tapp = object(tapplication)
  120. procedure initmenubar;virtual;
  121. procedure handleevent(var event : tevent);virtual;
  122. procedure do_installdialog;
  123. procedure readcfg(const fn:string);
  124. end;
  125. {$IFDEF DOSSTUB}
  126. PByte = ^byte;
  127. PRunBlock = ^TRunBlock;
  128. TRunBlock = record
  129. Length: word;
  130. Dependent: word;
  131. Background: word;
  132. TraceLevel: word;
  133. PrgTitle: PChar;
  134. PrgName: PChar;
  135. Args: PChar;
  136. TermQ: longint;
  137. Environment: pointer;
  138. Inheritance: word;
  139. SesType: word;
  140. Icon: pointer;
  141. PgmHandle: longint;
  142. PgmControl: word;
  143. Column: word;
  144. Row: word;
  145. Width: word;
  146. Height: word;
  147. end;
  148. {$ENDIF}
  149. var
  150. installapp : tapp;
  151. startpath : string;
  152. successfull : boolean;
  153. cfg : cfgrec;
  154. data : datarec;
  155. {*****************************************************************************
  156. Helpers
  157. *****************************************************************************}
  158. procedure errorhalt;
  159. begin
  160. installapp.done;
  161. halt(1);
  162. end;
  163. function packagemask(i:longint):longint;
  164. begin
  165. packagemask:=1 shl (i-1);
  166. end;
  167. function upper(const s : string):string;
  168. var
  169. i : integer;
  170. begin
  171. for i:=1 to length(s) do
  172. if s[i] in ['a'..'z'] then
  173. upper[i]:=chr(ord(s[i])-32)
  174. else
  175. upper[i]:=s[i];
  176. upper[0]:=s[0];
  177. end;
  178. (* TH - not needed any more
  179. function lower(const s : string):string;
  180. var
  181. i : integer;
  182. begin
  183. for i:=1 to length(s) do
  184. if s[i] in ['A'..'Z'] then
  185. lower[i]:=chr(ord(s[i])+32)
  186. else
  187. lower[i]:=s[i];
  188. lower[0]:=s[0];
  189. end;
  190. *)
  191. procedure Replace(var s:string;const s1,s2:string);
  192. var
  193. i : longint;
  194. begin
  195. repeat
  196. i:=pos(s1,s);
  197. if i>0 then
  198. begin
  199. Delete(s,i,length(s1));
  200. Insert(s2,s,i);
  201. end;
  202. until i=0;
  203. end;
  204. function file_exists(const f : string;const path : string) : boolean;
  205. begin
  206. file_exists:=fsearch(f,path)<>'';
  207. end;
  208. function DiskSpaceN(const zipfile : string) : longint;
  209. var
  210. compressed,uncompressed : longint;
  211. s : string;
  212. begin
  213. s:=zipfile+#0;
  214. uncompressed:=UnzipSize(@s[1],compressed);
  215. DiskSpaceN:=uncompressed shr 10;
  216. end;
  217. function diskspace(const zipfile : string) : string;
  218. var
  219. uncompressed : longint;
  220. s : string;
  221. begin
  222. uncompressed:=DiskSpaceN (zipfile);
  223. str(uncompressed,s);
  224. diskspace:=' ('+s+' KB)';
  225. end;
  226. function createdir(s : string) : boolean;
  227. var
  228. start,
  229. s1 : string;
  230. i : longint;
  231. err : boolean;
  232. dir : searchrec;
  233. params : array[0..0] of pointer;
  234. begin
  235. if s[length(s)]=DirSep then
  236. dec(s[0]);
  237. FindFirst(s,AnyFile,dir);
  238. if doserror=0 then
  239. begin
  240. (* TH - check the directory attribute! *)
  241. if Dir.Attr and Directory = 0 then
  242. begin
  243. messagebox('A file with the name chosen as the installation '+
  244. 'directory exists already. Cannot create this directory!',nil,
  245. mferror+mfokbutton);
  246. createdir:=false;
  247. end else
  248. createdir:=messagebox('The installation directory exists already. '+
  249. 'Do you want to enter a new installation directory ?',nil,
  250. mferror+mfyesbutton+mfnobutton)=cmNo;
  251. exit;
  252. end;
  253. err:=false;
  254. {$I-}
  255. getdir(0,start);
  256. {$ifndef linux}
  257. if (s[2]=':') and (s[3]=DirSep) then
  258. begin
  259. chdir(Copy(s,1,3));
  260. Delete(S,1,3);
  261. end;
  262. {$endif}
  263. repeat
  264. i:=Pos(DirSep,s);
  265. if i=0 then
  266. i:=255;
  267. s1:=Copy(s,1,i-1);
  268. Delete(s,1,i);
  269. ChDir(s1);
  270. if ioresult<>0 then
  271. begin
  272. mkdir(s1);
  273. chdir(s1);
  274. if ioresult<>0 then
  275. begin
  276. err:=true;
  277. break;
  278. end;
  279. end;
  280. until s='';
  281. chdir(start);
  282. {$I+}
  283. if err then
  284. begin
  285. params[0]:=@s;
  286. messagebox('The installation directory %s couldn''t be created',
  287. @params,mferror+mfokbutton);
  288. createdir:=false;
  289. exit;
  290. end;
  291. {$ifndef TP}
  292. {$IFNDEF OS2}
  293. FindClose (dir);
  294. {$ENDIF}
  295. {$endif}
  296. createdir:=true;
  297. end;
  298. function GetProgDir: DirStr;
  299. var
  300. D: DirStr;
  301. N: NameStr;
  302. E: ExtStr;
  303. begin
  304. FSplit (FExpand (ParamStr (0)), D, N, E);
  305. if (D [0] <> #0) and (D [byte (D [0])] = '\') then Dec (D [0]);
  306. GetProgDir := D;
  307. end;
  308. {*****************************************************************************
  309. Writing of ppc386.cfg
  310. *****************************************************************************}
  311. procedure writedefcfg(const fn:string);
  312. var
  313. t : text;
  314. i : longint;
  315. s : string;
  316. dir : searchrec;
  317. params : array[0..0] of pointer;
  318. begin
  319. findfirst(fn,AnyFile,dir);
  320. if doserror=0 then
  321. begin
  322. params[0]:=@fn;
  323. MessageBox(#3'Default config not written.'#13#3'%s'#13#3'already exists',@params,mfinformation+mfokbutton);
  324. exit;
  325. end;
  326. assign(t,fn);
  327. {$I-}
  328. rewrite(t);
  329. {$I+}
  330. if ioresult<>0 then
  331. begin
  332. params[0]:=@fn;
  333. MessageBox(#3'Default config not written.'#13#3'%s'#13#3'couldn''t be created',@params,mfinformation+mfokbutton);
  334. exit;
  335. end;
  336. for i:=1 to cfg.defcfgs do
  337. if assigned(cfg.defcfg[i]) then
  338. begin
  339. s:=cfg.defcfg[i]^;
  340. Replace(s,'$1',data.basepath);
  341. writeln(t,s);
  342. end
  343. else
  344. writeln(t,'');
  345. close(t);
  346. end;
  347. {*****************************************************************************
  348. TUnZipDialog
  349. *****************************************************************************}
  350. constructor tunzipdialog.Init(var Bounds: TRect; ATitle: TTitleStr);
  351. var
  352. r : trect;
  353. begin
  354. inherited init(bounds,atitle);
  355. R.Assign(11, 4, 38, 5);
  356. filetext:=new(pstatictext,init(r,'File: '));
  357. insert(filetext);
  358. end;
  359. procedure tunzipdialog.do_unzip(s,topath : string);
  360. var
  361. fn,dir,wild : string;
  362. begin
  363. Disposestr(filetext^.text);
  364. filetext^.Text:=NewStr('File: '+s);
  365. filetext^.drawview;
  366. if not(file_exists(s,startpath)) then
  367. begin
  368. messagebox('File: '+s+' missed for the selected installation. '+
  369. 'Installation doesn''t becomes complete',nil,mferror+mfokbutton);
  370. errorhalt;
  371. end;
  372. fn:=startpath+DirSep+s+#0;
  373. dir:=topath+#0;
  374. wild:=AllFiles + #0;
  375. (* TH - added to clear the previous state of DosError *)
  376. DosError := 0;
  377. {$IFDEF DLL}
  378. if
  379. {$ENDIF}
  380. FileUnzipEx(@fn[1],@dir[1],@wild[1])
  381. {$IFDEF DLL}
  382. = 0 then
  383. {$ELSE}
  384. ;
  385. if doserror<>0 then
  386. {$ENDIF}
  387. begin
  388. messagebox('Error when extracting. Disk full?',nil,mferror+mfokbutton);
  389. errorhalt;
  390. end;
  391. end;
  392. {*****************************************************************************
  393. TEndDialog
  394. *****************************************************************************}
  395. constructor tenddialog.init;
  396. var
  397. R : TRect;
  398. P : PStaticText;
  399. Control : PButton;
  400. YB: word;
  401. {$IFNDEF LINUX}
  402. S: string;
  403. WPath: boolean;
  404. {$ENDIF}
  405. {$IFDEF OS2}
  406. ErrPath: array [0..259] of char;
  407. Handle: longint;
  408. WLibPath: boolean;
  409. const
  410. EMXName: array [1..4] of char = 'EMX'#0;
  411. {$ENDIF}
  412. begin
  413. YB := 14;
  414. {$IFNDEF LINUX}
  415. S := Data.BasePath + Cfg.BinSub;
  416. if Pos (Upper (S), Upper (GetEnv ('PATH'))) = 0 then
  417. begin
  418. WPath := true;
  419. Inc (YB, 2);
  420. end else WPath := false;
  421. {$IFDEF OS2}
  422. if DosLoadModule (@ErrPath, SizeOf (ErrPath), @EMXName, Handle) = 0 then
  423. begin
  424. WLibPath := false;
  425. DosFreeModule (Handle);
  426. end else
  427. begin
  428. WLibPath := true;
  429. Inc (YB, 2);
  430. end;
  431. {$ENDIF}
  432. {$ENDIF}
  433. R.Assign(6, 6, 74, YB);
  434. inherited init(r,'Installation Successfull');
  435. {$IFNDEF LINUX}
  436. if WPath then
  437. begin
  438. R.Assign(2, 3, 64, 5);
  439. P:=new(pstatictext,init(r,'Extend your PATH variable with '''+S+''''));
  440. insert(P);
  441. end;
  442. {$IFDEF OS2}
  443. if WLibPath then
  444. begin
  445. if WPath then S := 'and your LIBPATH with ''' + S + '\dll''' else
  446. S := 'Extend your LIBPATH with ''' + S + '\dll''';
  447. R.Assign (2, YB - 13, 64, YB - 11);
  448. P := New (PStaticText, Init (R, S));
  449. Insert (P);
  450. end;
  451. {$ENDIF}
  452. {$ENDIF}
  453. R.Assign(2, YB - 11, 64, YB - 10);
  454. P:=new(pstatictext,init(r,'To compile files enter '''+cfg.ppc386+' [file]'''));
  455. insert(P);
  456. R.Assign (29, YB - 9, 39, YB - 7);
  457. Control := New (PButton, Init (R,'~O~k', cmOK, bfDefault));
  458. Insert (Control);
  459. end;
  460. {*****************************************************************************
  461. TInstallDialog
  462. *****************************************************************************}
  463. constructor tinstalldialog.init;
  464. var
  465. r : trect;
  466. mask_components : longint;
  467. i,line : integer;
  468. items : psitem;
  469. p,f : pview;
  470. const
  471. width = 76;
  472. height = 20;
  473. x1 = (79-width) div 2;
  474. y1 = (23-height) div 2;
  475. x2 = x1+width;
  476. y2 = y1+height;
  477. begin
  478. r.assign(x1,y1,x2,y2);
  479. inherited init(r,cfg.title+' Installation');
  480. line:=2;
  481. r.assign(3,line+1,28,line+2);
  482. f:=new(pinputline,init(r,high(DirStr)));
  483. insert(f);
  484. r.assign(3,line,8,line+1);
  485. insert(new(plabel,init(r,'~P~ath',f)));
  486. { walk packages reverse and insert a newsitem for each, and set the mask }
  487. items:=nil;
  488. mask_components:=0;
  489. for i:=cfg.packages downto 1 do
  490. begin
  491. if file_exists(cfg.package[i].zip,startpath) then
  492. begin
  493. items:=newsitem(cfg.package[i].name+diskspace(startpath+DirSep+cfg.package[i].zip),items);
  494. mask_components:=mask_components or packagemask(i);
  495. end
  496. else
  497. begin
  498. items:=newsitem(cfg.package[i].name,items);
  499. end;
  500. end;
  501. { If no component found abort }
  502. if mask_components=0 then
  503. begin
  504. messagebox('No components found to install, aborting.',nil,mferror+mfokbutton);
  505. errorhalt;
  506. end;
  507. inc(line,3);
  508. r.assign(3,line+1,width-3,line+cfg.packages+1);
  509. p:=new(pcheckboxes,init(r,items));
  510. r.assign(3,line,14,line+1);
  511. insert(new(plabel,init(r,'~C~omponents',p)));
  512. pcluster(p)^.enablemask:=mask_components;
  513. insert(p);
  514. inc(line,cfg.packages+2);
  515. r.assign((width div 2)-14,line,(width div 2)-4,line+2);
  516. insert(new(pbutton,init(r,'~O~k',cmok,bfdefault)));
  517. r.assign((width div 2)+4,line,(width div 2)+14,line+2);
  518. insert(new(pbutton,init(r,'~C~ancel',cmcancel,bfnormal)));
  519. f^.select;
  520. end;
  521. {*****************************************************************************
  522. TApp
  523. *****************************************************************************}
  524. const
  525. cmstart = 1000;
  526. procedure tapp.do_installdialog;
  527. var
  528. p : pinstalldialog;
  529. p2 : punzipdialog;
  530. p3 : penddialog;
  531. r : trect;
  532. result,
  533. c : word;
  534. i, DSize, Space : longint;
  535. S: DirStr;
  536. begin
  537. data.basepath:=cfg.basepath;
  538. data.mask:=0;
  539. repeat
  540. { select components }
  541. p:=new(pinstalldialog,init);
  542. c:=executedialog(p,@data);
  543. if (c=cmok) then
  544. begin
  545. if Data.BasePath = '' then
  546. messagebox('Please, choose the directory for installation first.',nil,
  547. mferror+mfokbutton) else
  548. begin
  549. if (data.mask>0) then
  550. begin
  551. (* TH - check the available disk space here *)
  552. {$IFNDEF LINUX}
  553. DSize := 0;
  554. for i:=1 to cfg.packages do
  555. begin
  556. if data.mask and packagemask(i)<>0 then
  557. Inc (DSize, DiskSpaceN(cfg.package[i].zip));
  558. end;
  559. S := FExpand (Data.BasePath);
  560. Space := DiskFree (byte (S [1]) - 64) shr 10;
  561. if Space < DSize then S := 'is not' else S := '';
  562. if Space < DSize + 500 then
  563. begin
  564. if S = '' then S := 'might not be';
  565. if messagebox('There ' + S + ' enough space on the target ' +
  566. 'drive for all the selected components. Do you ' +
  567. 'want to change the installation path?',nil,
  568. mferror+mfyesbutton+mfnobutton) = cmYes then Continue;
  569. end;
  570. {$ENDIF}
  571. if createdir(data.basepath) then
  572. break;
  573. end
  574. else
  575. begin
  576. result:=messagebox('No components selected.'#13#13'Abort installation?',nil,
  577. mferror+mfyesbutton+mfnobutton);
  578. if result=cmYes then
  579. exit;
  580. end;
  581. end;
  582. end
  583. else
  584. exit;
  585. until false;
  586. { extract }
  587. r.assign(20,7,60,16);
  588. p2:=new(punzipdialog,init(r,'Extracting files'));
  589. desktop^.insert(p2);
  590. for i:=1 to cfg.packages do
  591. begin
  592. if data.mask and packagemask(i)<>0 then
  593. p2^.do_unzip(cfg.package[i].zip,data.basepath);
  594. end;
  595. desktop^.delete(p2);
  596. dispose(p2,done);
  597. { write config }
  598. writedefcfg(data.basepath+cfg.binsub+DirSep+cfg.defcfgfile);
  599. { show end message }
  600. p3:=new(penddialog,init);
  601. executedialog(p3,nil);
  602. end;
  603. procedure tapp.readcfg(const fn:string);
  604. var
  605. t : text;
  606. i,j,
  607. line : longint;
  608. item,
  609. s : string;
  610. params : array[0..0] of pointer;
  611. {$ifndef FPC}
  612. procedure readln(var t:text;var s:string);
  613. var
  614. c : char;
  615. i : longint;
  616. begin
  617. c:=#0;
  618. i:=0;
  619. while (not eof(t)) and (c<>#10) do
  620. begin
  621. read(t,c);
  622. if c<>#10 then
  623. begin
  624. inc(i);
  625. s[i]:=c;
  626. end;
  627. end;
  628. if (i>0) and (s[i]=#13) then
  629. dec(i);
  630. s[0]:=chr(i);
  631. end;
  632. {$endif}
  633. begin
  634. assign(t,StartPath + DirSep + fn);
  635. {$I-}
  636. reset(t);
  637. {$I+}
  638. if ioresult<>0 then
  639. begin
  640. StartPath := GetProgDir;
  641. assign(t,StartPath + DirSep + fn);
  642. {$I-}
  643. reset(t);
  644. {$I+}
  645. if ioresult<>0 then
  646. begin
  647. params[0]:=@fn;
  648. messagebox('File %s not found!',@params,mferror+mfokbutton);
  649. errorhalt;
  650. end;
  651. end;
  652. line:=0;
  653. while not eof(t) do
  654. begin
  655. readln(t,s);
  656. inc(line);
  657. if (s<>'') and not(s[1] in ['#',';']) then
  658. begin
  659. i:=pos('=',s);
  660. if i>0 then
  661. begin
  662. item:=upper(Copy(s,1,i-1));
  663. system.delete(s,1,i);
  664. if item='VERSION' then
  665. cfg.version:=s
  666. else
  667. if item='TITLE' then
  668. cfg.title:=s
  669. else
  670. if item='BASEPATH' then
  671. cfg.basepath:=s
  672. else
  673. if item='PPC386' then
  674. cfg.ppc386:=s
  675. else
  676. if item='BINSUB' then
  677. cfg.binsub:=s
  678. else
  679. if item='CFGFILE' then
  680. cfg.defcfgfile:=s
  681. else
  682. if item='DEFAULTCFG' then
  683. begin
  684. repeat
  685. readln(t,s);
  686. if upper(s)='ENDCFG' then
  687. break;
  688. if cfg.defcfgs<maxdefcfgs then
  689. begin
  690. inc(cfg.defcfgs);
  691. cfg.defcfg[cfg.defcfgs]:=newstr(s);
  692. end;
  693. until false;
  694. end
  695. else
  696. if item='PACKAGE' then
  697. begin
  698. j:=pos(',',s);
  699. if (j>0) and (cfg.packages<maxpackages) then
  700. begin
  701. inc(cfg.packages);
  702. cfg.package[cfg.packages].zip:=copy(s,1,j-1);
  703. cfg.package[cfg.packages].name:=copy(s,j+1,255);
  704. end;
  705. end;
  706. end;
  707. end;
  708. end;
  709. close(t);
  710. end;
  711. procedure tapp.initmenubar;
  712. var
  713. r : trect;
  714. begin
  715. getextent(r);
  716. r.b.y:=r.a.y+1;
  717. menubar:=new(pmenubar,init(r,newmenu(
  718. newsubmenu('~F~ree Pascal '+cfg.version,hcnocontext,newmenu(nil
  719. ),
  720. nil))));
  721. end;
  722. procedure tapp.handleevent(var event : tevent);
  723. begin
  724. inherited handleevent(event);
  725. if event.what=evcommand then
  726. if event.command=cmstart then
  727. begin
  728. clearevent(event);
  729. do_installdialog;
  730. if successfull then
  731. begin
  732. event.what:=evcommand;
  733. event.command:=cmquit;
  734. handleevent(event);
  735. end;
  736. end;
  737. end;
  738. {$IFDEF DOSSTUB}
  739. function CheckOS2: boolean;
  740. var
  741. OwnName: PathStr;
  742. OwnDir: DirStr;
  743. Name: NameStr;
  744. Ext: ExtStr;
  745. DosV, W: word;
  746. P: PChar;
  747. const
  748. Title: string [15] = 'FPC Installer'#0;
  749. RunBlock: TRunBlock = (Length: $32;
  750. Dependent: 0;
  751. Background: 0;
  752. TraceLevel: 0;
  753. PrgTitle: @Title [1];
  754. PrgName: nil;
  755. Args: nil;
  756. TermQ: 0;
  757. Environment: nil;
  758. Inheritance: 0;
  759. SesType: 2;
  760. Icon: nil;
  761. PgmHandle: 0;
  762. PgmControl: 2;
  763. Column: 0;
  764. Row: 0;
  765. Width: 80;
  766. Height: 25);
  767. begin
  768. CheckOS2 := false;
  769. asm
  770. mov ah, 30h
  771. int 21h
  772. xchg ah, al
  773. mov DosV, ax
  774. mov ax, 4010h
  775. int 2Fh
  776. cmp ax, 4010h
  777. jnz @0
  778. xor bx, bx
  779. @0:
  780. mov W, bx
  781. end;
  782. if DosV > 3 shl 8 then
  783. begin
  784. OwnName := FExpand (ParamStr (0));
  785. FSplit (OwnName, OwnDir, Name, Ext);
  786. if (DosV >= 20 shl 8 + 10) and (W >= 20 shl 8 + 10) then
  787. (* OS/2 version 2.1 or later running (double-checked) *)
  788. begin
  789. OwnName [Succ (byte (OwnName [0]))] := #0;
  790. RunBlock.PrgName := @OwnName [1];
  791. P := Ptr (PrefixSeg, $80);
  792. if PByte (P)^ <> 0 then
  793. begin
  794. Inc (P);
  795. RunBlock.Args := Ptr (PrefixSeg, $81);
  796. end;
  797. asm
  798. mov ax, 6400h
  799. mov bx, 0025h
  800. mov cx, 636Ch
  801. mov si, offset RunBlock
  802. int 21h
  803. jc @0
  804. mov DosV, 0
  805. @0:
  806. end;
  807. CheckOS2 := DosV = 0;
  808. end;
  809. end;
  810. end;
  811. {$ENDIF}
  812. begin
  813. (* TH - no error boxes if checking an inaccessible disk etc. *)
  814. {$IFDEF OS2}
  815. {$IFDEF FPC}
  816. DosCalls.DosError (0);
  817. {$ELSE FPC}
  818. {$IFDEF VirtualPascal}
  819. OS2Base.DosError (ferr_DisableHardErr);
  820. {$ELSE VirtualPascal}
  821. BseDos.DosError (0);
  822. {$ENDIF VirtualPascal}
  823. {$ENDIF FPC}
  824. {$ENDIF}
  825. {$IFDEF DOSSTUB}
  826. if CheckOS2 then Halt;
  827. {$ENDIF}
  828. getdir(0,startpath);
  829. successfull:=false;
  830. fillchar(cfg, SizeOf(cfg), 0);
  831. fillchar(data, SizeOf(data), 0);
  832. installapp.init;
  833. installapp.readcfg(cfgfile);
  834. { installapp.readcfg(startpath+dirsep+cfgfile);}
  835. installapp.do_installdialog;
  836. installapp.done;
  837. end.
  838. {
  839. $Log$
  840. Revision 1.1 1999-02-19 16:45:26 peter
  841. * moved to fpinst/ directory
  842. + makefile
  843. Revision 1.15 1999/02/17 22:34:08 peter
  844. * updates from TH for OS2
  845. Revision 1.14 1998/12/22 22:47:34 peter
  846. * updates for OS2
  847. * small fixes
  848. Revision 1.13 1998/12/21 13:11:39 peter
  849. * updates for 0.99.10
  850. Revision 1.12 1998/12/16 00:25:34 peter
  851. * updated for 0.99.10
  852. * new end dialogbox
  853. Revision 1.11 1998/11/01 20:32:25 peter
  854. * packed record
  855. Revision 1.10 1998/10/25 23:38:35 peter
  856. * removed warnings
  857. Revision 1.9 1998/10/23 16:57:40 pierre
  858. * compiles without -So option
  859. * the main dialog init was buggy !!
  860. Revision 1.8 1998/09/22 21:10:31 jonas
  861. * initialize cfg and data with 0 at startup
  862. Revision 1.7 1998/09/16 16:46:37 peter
  863. + updates
  864. Revision 1.6 1998/09/15 13:11:14 pierre
  865. small fix to cleanup if no package
  866. Revision 1.5 1998/09/15 12:06:06 peter
  867. * install updated to support w32 and dos and config file
  868. Revision 1.4 1998/09/10 10:50:49 florian
  869. * DOS install program updated
  870. Revision 1.3 1998/09/09 13:39:58 peter
  871. + internal unzip
  872. * dialog is showed automaticly
  873. Revision 1.2 1998/04/07 22:47:57 florian
  874. + version/release/patch numbers as string added
  875. }
  876.