source: branches/2.20_branch/installer/MainFormUnit.pas

Last change on this file was 208, checked in by RBRi, 18 years ago

library updates
  • Property svn:eol-style set to native
File size: 37.1 KB
Line 
1Unit MainFormUnit;
2
3// NewView - a new OS/2 Help Viewer
4// Copyright 2003 Aaron Lawrence (aaronl at consultant dot com)
5// This software is released under the Gnu Public License - see readme.txt
6
7Interface
8
9Uses
10 OS2Def,
11 PmWin,
12 Classes,
13 Forms,
14 Graphics,
15 ExtCtrls,
16 Buttons,
17 StdCtrls,
18 TabCtrls,
19 ComCtrls;
20
21Const
22 Vendor = 'Aaron Lawrence';
23 Description = 'NewView Install';
24
25 Version = 'V1.10.0'; // $SS_REQUIRE_NEW_VERSION$
26 BldLevelVersion = '1.10.0'; // Embedded for IBM BLDLEVEL tool
27
28 // BLDLevel - compatible - mostly
29 EmbeddedVersion: string =
30 '@#'
31 + Vendor
32 + ':'
33 + BldLevelVersion
34 + '#@'
35 + Description
36 + #0;
37
38Type
39 TMainForm = Class (TForm)
40 CancelButton: TButton;
41 BackButton: TButton;
42 NextButton: TButton;
43 Notebook: TNoteBook;
44 Label2: TLabel;
45 Label8: TLabel;
46 Label9: TLabel;
47 Label10: TLabel;
48 Label11: TLabel;
49 InstallProgressBar: TProgressBar;
50 Label12: TLabel;
51 RunAppCheckBox: TCheckBox;
52 Label13: TLabel;
53 Bevel1: TBevel;
54 AssociateAsDefaultCheckBox: TCheckBox;
55 AssociateCheckBox: TCheckBox;
56 Image1: TImage;
57 InstallToSourceCheckbox: TCheckBox;
58 InstallTypeRadioGroup: TRadioGroup;
59 InstallFolderLabel: TLabel;
60 InstallFolderEdit: TEdit;
61 ChooseInstallFolderButton: TButton;
62 CreateIconCheckBox: TCheckBox;
63 InstallTypeHelpLabel: TLabel;
64 Label4: TLabel;
65 Label5: TLabel;
66 RestartRequiredLabel: TLabel;
67 RestartCheckBox: TCheckBox;
68 WelcomeLabel: TLabel;
69 Label7: TLabel;
70 Label15: TLabel;
71 Procedure AssociateCheckBoxOnClick (Sender: TObject);
72 Procedure CreateIconCheckBoxOnClick (Sender: TObject);
73 Procedure InstallToSourceCheckboxOnClick (Sender: TObject);
74 Procedure InstallTypeRadioGroupOnClick (Sender: TObject);
75 Procedure MainFormOnCreate (Sender: TObject);
76 Procedure MainFormOnCloseQuery (Sender: TObject; Var CanClose: Boolean);
77 Procedure RestartCheckBoxOnClick (Sender: TObject);
78 Procedure ChooseInstallFolderButtonOnClick (Sender: TObject);
79 Procedure BackButtonOnClick (Sender: TObject);
80 Procedure NextButtonOnClick (Sender: TObject);
81 Procedure MainFormOnShow (Sender: TObject);
82 Procedure Label5OnClick (Sender: TObject);
83 Procedure CancelButtonOnClick (Sender: TObject);
84 Protected
85 Procedure EnableButtons;
86 Function SkipPage( Page: longint ): boolean;
87 Function GetInstallType: longint;
88
89 FCancelled: boolean;
90 FAllowClose: boolean;
91 FAppInUse: boolean;
92 FDLLInUse: boolean;
93
94 FSourceDir: string;
95 FSystemDir: string;
96 FSystemDLLDir: string;
97
98 FEnv_OSDir: string;
99 FEnv_Programs: string;
100
101 FStubInstallPath: string;
102 FAppInstallPath: string;
103 FDllInstallPath: string;
104
105 Function Install: boolean;
106 Function FullInstall: boolean;
107 Function StandAloneInstall: boolean;
108
109 Function InstallFile( const SourceFilename: string;
110 const DestinationPath: string;
111 const Backup: string;
112 const IsModule: boolean; // true if an executeable module
113 var DestInUse: boolean ): boolean;
114
115 function InstallMultipleFiles( const Filter: string;
116 const DestDir: string ): boolean;
117
118 function CreateDesktopIcon( const ExePath: string;
119 const ID: string;
120 const Description: string;
121 const Associations: string ): HOBJECT;
122
123 Procedure RunNewView;
124 Procedure RefreshInstallTypeHelp;
125 Procedure CheckEnvironment;
126
127 function GetAssociations: string;
128 Procedure UpdateAssociate;
129 End;
130
131Var
132 MainForm: TMainForm;
133
134const
135 // RenameModule return codes
136 RM_PARAM_ERROR = 1;
137 RM_NAME_LENGTHS_DIFFERENT = 2;
138 RM_FILE_ERROR = 3;
139 RM_INVALID_FORMAT = 4;
140 RM_WRONG_FORMAT = 5;
141 RM_NAME_MISMATCH = 6;
142 RM_WRITE_ERROR = 7;
143
144 // RenameModule actions
145 RM_RENAME_MODULE = 0;
146 RM_RENAME_IMPORTED_MODULE = 1;
147 RM_LIST_NAMES = 2;
148
149imports
150 function RenameModule( Filename: pchar;
151 Action: longint;
152 OldModuleName: pchar;
153 NewModuleName: pchar ): longint;
154 APIENTRY;
155 'RENMODUL' Name 'RenameModule';
156
157 Function DosReplaceModule( pszOldModule: pchar;
158 pszNewModule: pchar;
159 pszBackupModule: pchar )
160 : APIRET;
161 apientry;
162 'DOSCALLS' index 417;
163
164end;
165
166Implementation
167
168uses
169 BseDos,
170 BseErr,
171 PmWp,
172 PmShl,
173 PmErr,
174 SysUtils,
175 Dos,
176 Dialogs,
177 ACLUtility,
178 ACLDialogs,
179 ControlsUtility,
180 ChooseFolderFormUnit,
181 FileUtilsUnit,
182 CharUtilsUnit,
183 StringUtilsUnit;
184
185{$R NewViewInstall}
186
187const
188 pgWelcome = 0;
189 pgInstallType = 1;
190 pgInstallFolder = 2;
191 pgReady = 3;
192 pgInstalling = 4;
193 pgDone = 5;
194
195const // install types
196 itComplete = 0;
197 itViewOnly = 1;
198 itStandAlone = 2;
199
200 ECSNewViewObjectID = '<ECS_NEWVIEW>';
201 NewViewObjectID = '<NEWVIEW>';
202 IPFFiles = '*.INF,*.HLP'; // NOTE: PM is case sensitive here
203
204Procedure TMainForm.AssociateCheckBoxOnClick (Sender: TObject);
205Begin
206 UpdateAssociate;
207End;
208
209Procedure TMainForm.CreateIconCheckBoxOnClick (Sender: TObject);
210Begin
211 UpdateAssociate;
212End;
213
214Procedure TMainForm.UpdateAssociate;
215Begin
216 AssociateCheckBox.Enabled := CreateIconCheckBox.Checked
217 and ( GetInstallType = itStandAlone );
218 AssociateAsDefaultCheckBox.Enabled := AssociateCheckBox.Enabled
219 and AssociateCheckBox.Checked;
220End;
221
222Procedure TMainForm.InstallToSourceCheckboxOnClick (Sender: TObject);
223Begin
224 if InstallToSourceCheckbox.Checked then
225 InstallFolderLabel.PenColor := clBtnShadow
226 else
227 InstallFolderLabel.ParentPenColor := true;
228
229 InstallFolderEdit.Enabled := not InstallToSourceCheckbox.Checked;
230 ChooseInstallFolderButton.Enabled := not InstallToSourceCheckbox.Checked;
231End;
232
233Function TMainForm.GetInstallType: longint;
234begin
235 Result := InstallTypeRadioGroup.ItemIndex;
236end;
237
238Procedure TMainForm.InstallTypeRadioGroupOnClick (Sender: TObject);
239Begin
240 RefreshInstallTypeHelp;
241 UpdateAssociate;
242End;
243
244Procedure TMainForm.RefreshInstallTypeHelp;
245var
246 Help: string;
247begin
248 case InstallTypeRadioGroup.ItemIndex of
249 itComplete:
250 Help := 'This option will replace both online help and help icons. '
251 + 'It will backup and replace View.exe and HelpMgr.dll.';
252 itViewOnly:
253 Help := 'This option will replace help icons only, by '
254 + 'backing up and replacing View.exe.';
255 itStandAlone:
256 Help := 'This option will not change the existing help system. '
257 + 'NewView will be installed as a normal application.';
258 end;
259
260 InstallTypeHelpLabel.Caption := Help;
261end;
262
263Procedure TMainForm.MainFormOnCreate (Sender: TObject);
264Begin
265 // set up form icons
266 Forms.FormIconResourceID := 1;
267 Font := GetNiceDefaultFont;
268 WelcomeLabel.Font := Screen.CreateCompatibleFont( Font );
269 WelcomeLabel.Font.Attributes := [ faBold ];
270
271 CheckEnvironment;
272End;
273
274Procedure TMainForm.MainFormOnCloseQuery (Sender: TObject;
275 Var CanClose: Boolean);
276Begin
277 if FAllowClose then
278 begin
279 Canclose := true;
280 exit;
281 end;
282
283 FCancelled := true;
284 CanClose := false;
285End;
286
287Procedure TMainForm.RestartCheckBoxOnClick (Sender: TObject);
288Begin
289 RunAppCheckBox.Enabled := not RestartCheckBox.Checked;
290 if RestartCheckbox.Checked then
291 RunAppCheckBox.Checked := false;
292End;
293
294Procedure TMainForm.ChooseInstallFolderButtonOnClick (Sender: TObject);
295Begin
296 ChooseFolderForm.Folder := InstallFolderEdit.Text;
297 if ChooseFolderForm.ShowModal <> mrOK then
298 exit;
299 InstallFolderEdit.Text := ChooseFolderForm.Folder;
300End;
301
302Procedure TMainForm.BackButtonOnClick (Sender: TObject);
303var
304 PreviousPage: longint;
305Begin
306 PreviousPage := Notebook.PageIndex - 1;
307 while SkipPage( PreviousPage ) do
308 dec( PreviousPage );
309
310 Notebook.PageIndex := PreviousPage;
311
312 EnableButtons;
313End;
314
315Function TMainForm.SkipPage( Page: longint ): boolean;
316begin
317 Result := false;
318 if Page = pgInstallFolder then
319 if GetInstallType <> itStandAlone then
320 result := true;
321end;
322
323Procedure TMainForm.NextButtonOnClick (Sender: TObject);
324var
325 NextPage: longint;
326Begin
327 FCancelled := false;
328
329 NextPage := Notebook.PageIndex + 1;
330 while SkipPage( NextPage ) do
331 inc( NextPage );
332
333 Notebook.PageIndex := NextPage;
334
335 EnableButtons;
336
337 case Notebook.PageIndex of
338 pgInstalling:
339 begin
340 FAllowClose := false;
341
342 if not Install then
343 begin
344 FAllowClose := true;
345 Close;
346 exit;
347 end;
348
349 FAllowClose := true;
350
351 RestartRequiredLabel.Visible := FDLLInUse or FAppInUse;
352
353 if FDLLInUse then
354 begin
355 RestartRequiredLabel.Caption :=
356 'NOTE: You will need to restart your computer for '
357 + 'the installation to take effect.';
358
359 RestartCheckBox.Visible := true;
360 end
361 else
362 begin
363 RestartCheckBox.Visible := false;
364
365 if FAppInUse then
366 begin
367 RestartRequiredLabel.Caption :=
368 'NewView is currently running. Restart it to activate the new version.';
369 RunAppCheckBox.Checked := false;
370 RunAppCheckBox.Enabled := false;
371
372 end;
373 end;
374
375 Notebook.PageIndex := Notebook.PageIndex + 1;
376
377 EnableButtons;
378
379 end;
380
381 pgDone:
382 begin
383 Close;
384 if RestartCheckBox.Checked then
385 begin
386 // prevent ourselves from hanging the shutdown
387 WinShutdownSystem( AppHandle, HMQ_CURRENT )
388 end
389 else if RunAppCheckBox.Checked then
390 begin
391 RunNewView;
392 end;
393 end;
394 end;
395End;
396
397Function GetEnvironmentFolder( const VariableName: string ): string;
398begin
399 Result := GetEnv( VariableName );
400 if Result <> '' then
401 if not DirectoryExists( Result ) then
402 Result := '';
403
404 // make sure it ends in a backslash
405 if Result <> '' then
406 Result := AddDirectorySeparator( Result );
407end;
408
409Procedure TMainForm.CheckEnvironment;
410begin
411 FSourceDir := GetApplicationDir;
412
413 FSystemDir := GetBootDriveLetter + ':\os2\';
414 FSystemDLLDir := FSystemDir + 'dll\';
415
416 // ecs things
417 FEnv_OSDir := GetEnvironmentFolder( 'OSDIR' );
418 FEnv_Programs := GetEnvironmentFolder( 'PROGRAMS' );
419end;
420
421Procedure TMainForm.MainFormOnShow (Sender: TObject);
422Begin
423 Notebook.PageIndex := 0;
424 EnableButtons;
425
426 // default standalone dir
427
428 if FEnv_Programs <> '' then
429 InstallFolderEdit.Text := AddDirectorySeparator(FEnv_Programs) + 'NewView'
430 else
431 InstallFolderEdit.Text := GetBootDriveLetter + ':\NewView';
432
433 CreateIconCheckBox.Checked := true;
434
435 RefreshInstallTypeHelp;
436 UpdateAssociate;
437
438 FAllowClose := true;
439End;
440
441Procedure TMainForm.EnableButtons;
442Begin
443 BackButton.Visible := ( Notebook.PageIndex > 0 )
444 and ( Notebook.PageIndex < pgInstalling );
445 NextButton.Enabled := ( Notebook.PageIndex < pgInstalling )
446 or ( Notebook.PageIndex = pgDone );
447
448 if Notebook.PageIndex < pgReady then
449 NextButton.Caption := '~Next >'
450 else if Notebook.PageIndex = pgReady then
451 NextButton.Caption := '~Install >'
452 else
453 NextButton.Caption := '~Close';
454
455 CancelButton.Enabled := Notebook.PageIndex < pgDone;
456
457End;
458
459Procedure TMainForm.Label5OnClick (Sender: TObject);
460Begin
461
462End;
463
464Procedure TMainForm.CancelButtonOnClick (Sender: TObject);
465Begin
466 Close;
467End;
468
469// Install specified module from source, to dest.
470// If backup is not '' then the original file will
471// be copied to Backup.
472// If the file is in use then:
473// If IsModule is false then the install will fail.
474// If IsModule is true then DosReplaceModule will
475// be used to unlock the module, and DestInUse will be set true.
476Function TMainForm.InstallFile( const SourceFilename: string;
477 const DestinationPath: string;
478 const Backup: string;
479 const IsModule: boolean; // true if an executeable module
480 var DestInUse: boolean ): boolean;
481var
482 rc: APIRET;
483 szDest: cstring;
484 szSource: cstring;
485 szBackup: cstring;
486 FileHandle: HFILE;
487 ActionTaken: ULONG;
488 SourcePath: string;
489begin
490 Result := false;
491 // DestInUse := false;
492
493 SourcePath := FSourceDir + SourceFilename;
494
495 // Check the source file exists.
496 if not FileExists( SourcePath ) then
497 begin
498 DoErrorDlg( 'Internal Error',
499 'The file '
500 + SourcePath
501 + ' was not found for installation' );
502 exit;
503 end;
504
505 // Convert to null-terminated strings
506 szDest := DestinationPath;
507 szSource := SourcePath;
508 szBackup := Backup;
509
510 // If the destination exists, unlock and back it up
511 if FileExists( DestinationPath ) then
512 begin
513 if FileIsReadOnly( DestinationPath ) then
514 begin
515 DoErrorDlg( 'Installation Error',
516 'The file ' + StrCRLF
517 + ' ' + DestinationPath + StrCRLF
518 + 'is read-only and cannot be replaced.' );
519 exit;
520 end;
521 // see if it's in use.
522 rc := DosOpen( szDest,
523 FileHandle,
524 ActionTaken,
525 0, // new size: not used
526 0, // attributes: not used
527 OPEN_ACTION_FAIL_IF_NEW
528 + OPEN_ACTION_OPEN_IF_EXISTS,
529 OPEN_FLAGS_FAIL_ON_ERROR
530 + OPEN_SHARE_DENYREADWRITE
531 + OPEN_ACCESS_READWRITE,
532 nil ); // e.a.s: not used
533 DosClose( FileHandle );
534
535 if rc = ERROR_SHARING_VIOLATION then
536 begin
537 // file in use
538 DestInUse := true;
539
540 if not IsModule then
541 begin
542 // Show error. It would be nicer to
543 // fall back on alternative update method e.g.
544 // locked file device driver IBMLANLK.SYS
545 // But that's overkill for NewView
546 DoErrorDlg( 'Installation Error',
547 'This file is in use: ' + StrCRLF
548 + ' ' + DestinationPath + StrCRLF
549 + 'and cannot be replaced.' );
550 exit;
551 end;
552
553 // unlock the module
554 rc := DosReplaceModule( Addr( szDest ),
555 nil,
556 nil );
557
558 if rc <> 0 then
559 begin
560 // error
561 DoErrorDlg( 'Install Error',
562 'Could not unlock ' + StrCRLF
563 + ' ' + DestinationPath + StrCRLF
564 + SysErrorMessage( rc ) );
565
566 exit;
567 end;
568 end
569 else if rc <> 0 then
570 begin
571 DoErrorDlg( 'Install Error',
572 'Unable to acces ' + StrCRLF
573 + ' ' + DestinationPath + StrCRLF
574 + SysErrorMessage( rc ) );
575 exit;
576 end;
577
578 // OK, done...
579
580 if Backup <> '' then
581 begin
582 // make backup if it doesn't already exist.
583 if not FileExists( Backup ) then
584 begin
585 rc := DosCopy( szDest,
586 szBackup,
587 0 ); // no special options (don't overwrite).
588 if rc <> 0 then
589 begin
590 // error
591 DoErrorDlg( 'Install Error',
592 'Could not backup ' + StrCRLF
593 + ' ' + DestinationPath + StrCRLF
594 + ' to' + StrCRLF
595 + ' ' + Backup + StrCRLF
596 + StrCRLF
597 + SysErrorMessage( rc ) );
598 exit;
599 end;
600 end;
601 end;
602 end;
603
604 // OK, now copy the new file on
605 rc := DosCopy( szSource,
606 szDest,
607 DCPY_EXISTING ); // overwrite
608 if rc <> 0 then
609 begin
610 // error
611 DoErrorDlg( 'Install Error',
612 'Could not copy new file ' + StrCRLF
613 + ' ' + SourcePath + StrCRLF
614 + ' to' + StrCRLF
615 + ' ' + DestinationPath + StrCRLF
616 + StrCRLF
617 + SysErrorMessage( rc ) );
618 exit;
619 end;
620
621 // done
622 result := true;
623end;
624
625function TMainForm.InstallMultipleFiles( const Filter: string;
626 const DestDir: string ): boolean;
627var
628 Files: TStringList;
629 i: longint;
630 InUse: boolean;
631begin
632 Result := false;
633
634 Files := TStringList.Create;
635 ListFilesInDirectory( FSourceDir,
636 Filter,
637 false, // don't need subdirs
638 Files); // don't need subdirs
639
640 for i := 0 to Files.Count - 1 do
641 begin
642 if not InstallFile( Files[ i ],
643 DestDir + Files[ i ],
644 '', // no backup
645 false, // not in use
646 InUse ) then
647 exit;
648 end;
649 Result := true;
650end;
651
652const
653 FilterAssociationsKey = 'PMWP_ASSOC_FILTER';
654 MAX_HANDLE_TEXT_SIZE = 10;
655
656function ReadAssociatedObjects( const Filter: string;
657 ObjectList: TList ): boolean;
658var
659
660 HandleListSize: ULONG;
661 pHandleListData: pchar;
662 pHandleString: pchar;
663 HandleString: string;
664 Handle: HOBJECT;
665 RemainingLength: longint;
666begin
667 Result := false;
668
669 if not PrfQueryProfileSize( HINI_USER,
670 FilterAssociationsKey,
671 Filter,
672 HandleListSize ) then
673 exit;
674
675 GetMem( pHandleListData, HandleListSize );
676
677 FillMem( pHandleListData, HandleListSize, $ff );
678
679 if not PrfQueryProfileData( HINI_USER,
680 FilterAssociationsKey,
681 Filter,
682 pHandleListData^,
683 HandleListSize ) then
684 begin
685 FreeMem( pHandleListData, HandleListSize );
686 exit;
687 end;
688
689 try
690 pHandleString := pHandleListData;
691 while ( pHandleString < pHandleListData + HandleListSize ) do
692 begin
693 // work out remaining length of buffer
694 // so we don't overrun it if the data is invalid, ie. non terminated
695 RemainingLength := PCharPointerDiff( pHandleListData + HandleListSize,
696 pHandleString );
697 HandleString := StrPasWithLength( pHandleString, RemainingLength );
698
699 // convert to integer object handle
700 Handle := StrToInt( HandleString );
701 ObjectList.Add( pointer( Handle ) );
702
703 // skip to next in data
704 pHandleString := pHandleString + Length( HandleString ) + 1;
705 end;
706 except
707 begin
708 FreeMem( pHandleListData, HandleListSize );
709 ObjectList.Destroy;
710 exit;
711 end;
712 end;
713
714 FreeMem( pHandleListData, HandleListSize );
715 Result := true;
716end;
717
718function WriteAssociatedObjects( const Filter: string;
719 ObjectList: TList ): boolean;
720var
721
722 HandleListSize: ULONG;
723 pHandleListData: pchar;
724 pHandleString: pchar;
725 HandleString: string;
726 Handle: HOBJECT;
727 i: longint;
728 ActualLength: longint;
729begin
730 Result := false;
731
732 HandleListSize := ObjectList.Count * MAX_HANDLE_TEXT_SIZE;
733 GetMem( pHandleListData, HandleListSize );
734
735 pHandleString := pHandleListData;
736
737 for i := 0 to ObjectList.Count - 1 do
738 begin
739 Handle := HOBJECT( ObjectList[ i ] );
740 HandleString := IntToStr( Handle );
741
742 MemCopy( Addr( HandleString[ 1 ] ),
743 pHandleString,
744 Length( HandleString ) );
745
746 pHandleString := pHandleString + Length( HandleString );
747
748 // zero terminate this entry
749 pHandleString^ := #0;
750 inc( pHandleString );
751 end;
752
753 // additional terminator... AssoEdit does this... is it needed?
754 pHandleString^ := #0;
755 inc( pHandleString );
756
757 ActualLength := PCharPointerDiff( pHandleString, pHandleListData );
758 result := PrfWriteProfileData( HINI_USER,
759 FilterAssociationsKey,
760 Filter,
761 pHandleListData^,
762 ActualLength );
763
764 FreeMem( pHandleListData, HandleListSize );
765end;
766
767function MakeDefaultAssociation( const Filter: string;
768 hDesktopObject: HObject ): boolean;
769var
770 ObjectList: TList;
771 i: longint;
772begin
773 ObjectList := TList.Create;
774 result := false;
775
776 if not ReadAssociatedObjects( Filter, ObjectList ) then
777 begin
778 DoErrorDlg( 'Association',
779 'Unable to read associations for ' + Filter );
780 ObjectList.Destroy;
781 exit;
782 end;
783
784 // find object in existing list
785 i := ObjectList.IndexOf( pointer( hDesktopObject ) );
786 if i <> - 1 then
787 // found, delete it
788 ObjectList.Delete( i );
789
790 ObjectList.Insert( 0, pointer( hDesktopObject ) );
791
792 result := WriteAssociatedObjects( Filter, ObjectList );
793
794 if not result then
795 DoErrorDlg( 'Association',
796 'Unable to update associations for ' + Filter );
797
798 ObjectList.Destroy;
799end;
800
801// association one of more file filters,
802// separated by commas, with the given object
803function MakeDefaultAssociations( const aMask: string;
804 hDesktopObject: HOBJECT ): boolean;
805var
806 tmpMask : String;
807 tmpMasks : TStringList;
808 i : longint;
809begin
810 Result := false;
811
812 tmpMasks := TStringList.Create;
813 StrExtractStrings(tmpMasks, aMask, [','], #0);
814
815 for i := 0 to tmpMasks.Count - 1 do
816 begin
817 tmpMask := tmpMasks[i];
818 if not makeDefaultAssociation(tmpMask, hDesktopObject ) then
819 begin
820 tmpMasks.Destroy;
821 exit;
822 end;
823 end;
824
825 tmpMasks.Destroy;
826
827 Result := true;
828end;
829
830function TMainForm.CreateDesktopIcon( const ExePath: string;
831 const ID: string;
832 const Description: string;
833 const Associations: string ): HOBJECT;
834var
835 szSetupString: cstring;
836 PMError: ERRORID;
837begin
838 szSetupString := 'PROGTYPE=PM;EXENAME='
839 + ExePath
840 + ';OBJECTID='
841 + ID;
842 if Associations <> '' then
843 szSetupString := szSetupString
844 + ';ASSOCFILTER='
845 + Associations;
846 Result :=
847 WinCreateObject( 'WPProgram', // class
848 Description,
849 szSetupString, // setup string
850 '<WP_DESKTOP>',
851 CO_REPLACEIFEXISTS );
852
853 if Result <> NULLHANDLE then
854 // OK
855 exit;
856
857 // error
858 PMError := WinGetLastError( AppHandle );
859
860 // Handle a few specific errors
861
862 case ( PMError and $ffff ) of
863 WPERR_INVALID_FOLDER:
864 DoErrorDlg( 'Warning',
865 'Unable to create desktop icon:' + StrCRLF
866 + IntToHex( PMError, 8 )
867 + ': The desktop is not correctly installed '
868 + '(<WP_DESKTOP> missing). ' );
869
870 WPERR_NOT_WORKPLACE_CLASS:
871 DoErrorDlg( 'Warning',
872 'Unable to create desktop icon:' + StrCRLF
873 + IntToHex( PMError, 8 )
874 + ': WPProgram class is missing.' );
875
876 else
877 DoErrorDlg( 'Installation Error',
878 'Unable to create desktop icon' + StrCRLF
879 + IntToHex( PMError, 8 )
880 + ': There may be some problem with the desktop.' );
881 end;
882end;
883
884Function TMainForm.Install: boolean;
885begin
886 if GetInstallType = itStandAlone then
887 result := StandAloneInstall
888 else
889 result := FullInstall;
890end;
891
892function CheckConflicts( const VarNames: string;
893 const CorrectPath: string ): boolean;
894var
895 Files: TStringList;
896 i: longint;
897 FileName: string;
898 tmpVarNames : TStringList;
899 FileDir: string;
900 CorrectDir: string;
901begin
902 Files := TStringList.Create;
903
904 // ignore duplicates if found by multiple path vars
905 Files.Duplicates := dupIgnore;
906
907 FileName := ExtractFileName( CorrectPath );
908
909 tmpVarNames := TStringList.Create;
910 StrExtractStrings(tmpVarNames, VarNames, [';'], #0);
911 for i := 0 to tmpVarNames.Count - 1 do
912 begin
913 GetFilesInPath( tmpVarNames[i], FileName, Files );
914 end;
915 tmpVarNames.Destroy;
916
917 CorrectDir := ExtractFilePath( CorrectPath );
918
919 // delete the correct path, if found
920 // or files in the current (install) directory
921 // - found if . is in path
922 i := 0;
923 while i < Files.Count do
924 begin
925 // where is the file?
926 FileDir := ExtractFilePath( Files[ i ] );
927
928 // if it's where we're aiming for then that's fine
929 if StrEqualIgnoringCase( FileDir, CorrectDir )
930 or StrEqualIgnoringCase( FileDir, GetApplicationDir )
931 then
932 Files.Delete( i )
933 else
934 inc( i );
935 end;
936
937 if Files.Count > 0 then
938 Result :=
939 DoConfirmListDlg( 'Duplicates Warning',
940 'The file'
941 + StrCRLF
942 + ' ' + FileName
943 + StrCRLF
944 + 'will be installed to '
945 + StrCRLF
946 + ' ' + ExtractFilePath( CorrectPath )
947 + StrCRLF
948 + 'but there are other copies on your computer. '
949 + 'The wrong file might be used. '
950 + 'Continue?',
951 Files )
952 else
953 Result := true;
954 Files.Destroy;
955end;
956
957function TMainForm.GetAssociations: string;
958begin
959 if AssociateCheckBox.Checked then
960 Result := IPFFiles
961 else
962 Result := '';
963end;
964
965function CopyFileError( const Source: string;
966 const Dest: string ): boolean;
967begin
968 Result := CopyFile( Source,
969 Dest );
970 if not result then
971 DoErrorDlg( 'Copy Error',
972 'Error copying '
973 + Source
974 + ' to '
975 + Dest );
976end;
977
978// Do a full install, replacing parts of the operating system
979// as needed.
980// Either view only, or view and helpmgr
981Function TMainForm.FullInstall: boolean;
982var
983 LanguageDir: string;
984 HelpDir: string;
985 BookDir: string;
986 DocDir: string;
987 AppDir: string;
988 Dummy: boolean;
989 ProgramObjectHandle: HOBJECT;
990 ObjectID: string;
991 rc: longint;
992 HelpMgrBackupPath: string;
993 StubBackupPath: string;
994 IBMHelpMgrPath: cstring;
995 IBMStubPath: cstring;
996 ViewDocPath: cstring;
997 ViewDocBackupPath: cstring;
998begin
999 Result := false;
1000
1001 FAppInUse := false;
1002 FDLLInUse := false;
1003
1004 InstallProgressBar.Position := 0;
1005 Application.ProcessMessages;
1006
1007 // validate system path
1008 if not DirectoryExists( FSystemDir ) then
1009 begin
1010 DoErrorDlg( 'System Folder Error',
1011 'The system folder '
1012 + FSystemDir
1013 + ' does not exist!' );
1014 exit;
1015 end;
1016
1017 if GetInstallType = itComplete then
1018 begin
1019 // validate system DLL path
1020 if not DirectoryExists( FSystemDLLDir ) then
1021 begin
1022 DoErrorDlg( 'System Folder Error',
1023 'The system DLL folder '
1024 + FSystemDLLDir
1025 + ' does not exist!' );
1026 exit;
1027 end;
1028 end;
1029
1030 // Validate help directory...
1031 if FEnv_OSDir <> '' then
1032 HelpDir := FEnv_OSDir + 'help\'
1033 else
1034 HelpDir := FSystemDir + 'help\';
1035
1036 if not DirectoryExists( HelpDir ) then
1037 begin
1038 DoErrorDlg( 'System Folder Error',
1039 'The system help folder '
1040 + HelpDir
1041 + ' does not exist!' );
1042 exit;
1043 end;
1044
1045 if FEnv_OSDir <> '' then
1046 BookDir := FEnv_OSDir + 'book\'
1047 else
1048 BookDir := FSystemDir + 'book\';
1049
1050 // Docs: Use a subdirectory
1051 if FEnv_OSDir <> '' then
1052 DocDir := FEnv_OSDir + 'doc\NewView\'
1053 else
1054 DocDir := BookDir + 'NewView\';
1055
1056 if not DirectoryExists( DocDir ) then
1057 begin
1058 try
1059 MakeDirs( DocDir );
1060 except
1061 on E: EInOutError do
1062 begin
1063 DoErrorDlg( 'Folder Error',
1064 'Could not create the NewView doc folder '
1065 + DocDir+ StrCRLF
1066 + SysErrorMessage( E.ErrorCode ) );
1067 exit;
1068 end;
1069 end;
1070 end;
1071
1072 // install viewer app to either x:\os2
1073 // or on eCS, %OSDIR%\bin
1074 if FEnv_OSDir <> '' then
1075 begin
1076 // ecs - with a dir specified
1077 AppDir := FEnv_OSDir + 'bin\';
1078 end
1079 else
1080 begin
1081 // OS/2
1082 AppDir := FSystemDir;
1083 end;
1084
1085 LanguageDir := AppDir; // for now.
1086
1087 // Where shall we put the programs eh?
1088 FAppInstallPath := AppDir + 'NewView.exe';
1089 FStubInstallPath := FSystemDir + 'view.exe';
1090 FDllInstallPath := FSystemDLLDir + 'newview.dll';
1091
1092 // check for existing files that might conflict
1093 if not CheckConflicts( 'PATH',
1094 FAppInstallPath ) then
1095 exit;
1096
1097 if not CheckConflicts( 'PATH',
1098 FStubInstallPath ) then
1099 exit;
1100
1101 if not CheckConflicts( 'HELP;BOOKSHELF',
1102 HelpDir + 'newview*.hlp' ) then
1103 exit;
1104
1105 {
1106 // Doh! Not possible as LIBPATH is not an environment variable,
1107 // and there is no API to get it. Primitive... :/
1108 if not CheckConflicts( 'LIBPATH',
1109 FDllInstallPath ) then
1110 exit;
1111 }
1112
1113 InstallProgressBar.Position := 10;
1114 // ------------------------------------------
1115
1116 // Main program
1117 if not InstallFile( 'NewView.exe',
1118 FAppInstallPath,
1119 '', // no backup
1120 true,
1121 FAppInUse ) then
1122 exit;
1123
1124 InstallProgressBar.Position := 20;
1125 // ------------------------------------------
1126
1127 // Stub (View.exe)
1128 StubBackupPath := ChangeFileExt( FStubInstallPath, '.bak' );
1129 if not InstallFile( 'ViewStub.exe',
1130 FStubInstallPath,
1131 StubBackupPath,
1132 true,
1133 FAppInUse ) then
1134 exit;
1135
1136 IBMStubPath := FSystemDir + 'ibmview.exe';
1137 if not FileExists( IBMStubPath ) then
1138 begin
1139 // copy view.bak to ibmview.exe
1140 if not CopyFileError( StubBackupPath,
1141 IBMStubPath ) then
1142 exit;
1143
1144 rc := RenameModule( Addr( IBMStubPath ),
1145 RM_RENAME_IMPORTED_MODULE,
1146 'HELPMGR',
1147 'IBMHMGR' );
1148 if rc <> 0 then
1149 begin
1150 DoErrorDlg( 'Rename Module Error',
1151 'Error changing references to HelpMgr DLL in '
1152 + IBMStubPath
1153 + ': '
1154 + IntToStr( rc ) );
1155 exit;
1156 end;
1157 end;;
1158
1159 // backup viewdoc.exe
1160 ViewDocPath := FSystemDir + 'viewdoc.exe';
1161 ViewDocBackupPath := FSystemDir + 'viewdoc.bak';
1162 if not FileExists( ViewDocBackupPath ) then
1163 if not CopyFileError( ViewDocPath,
1164 ViewDocBackupPath ) then
1165 exit;
1166
1167 // In this case we do actually have to modify the
1168 // original file; because original View is hardcoded
1169 // with the name of viewdoc.exe (AFAIK)
1170 rc := RenameModule( Addr( ViewDocPath ),
1171 RM_RENAME_IMPORTED_MODULE,
1172 'HELPMGR',
1173 'IBMHMGR' );
1174 if rc <> 0 then
1175 begin
1176 DoErrorDlg( 'Rename Module Error',
1177 'Error changing references to HelpMgr DLL in '
1178 + ViewDocPath
1179 + ': '
1180 + IntToStr( rc ) );
1181 exit;
1182 end;
1183
1184 InstallProgressBar.Position := 30;
1185 // ------------------------------------------
1186
1187 // Help Manager DLL
1188 if GetInstallType = itComplete then
1189 begin
1190 HelpMgrBackupPath := FSystemDLLDir + 'HelpMgr.bak';
1191 if not InstallFile( 'HelpMgr.dll',
1192 FSystemDLLDir + 'HelpMgr.dll',
1193 HelpMgrBackupPath,
1194 true,
1195 FDLLInUse ) then
1196 exit;
1197
1198 // if needed, copy backed up file to ibmhmgr.dll,
1199 // do internal rename
1200 IBMHelpMgrPath := FSystemDLLDir + 'ibmhmgr.dll';
1201
1202 if not FileExists( IBMHelpMgrPath ) then
1203 begin
1204 if not CopyFileError( HelpMgrBackupPath,
1205 IBMHelpMgrPath ) then
1206 exit;
1207
1208 rc := RenameModule( Addr( IBMHelpMgrPath ),
1209 RM_RENAME_MODULE,
1210 'HELPMGR',
1211 'IBMHMGR' );
1212 if rc <> 0 then
1213 begin
1214 DoErrorDlg( 'Rename Module Error',
1215 'Error changing old HelpMgr DLL module name: '
1216 + IntToStr( rc ) );
1217 exit;
1218 end;
1219 end;
1220
1221 end;
1222
1223 InstallProgressBar.Position := 35;
1224 // ------------------------------------------
1225
1226 // newview.dll
1227 if not InstallFile( 'NewView.dll',
1228 FDllInstallPath,
1229 '', // no backup
1230 false, // not in use
1231 Dummy ) then
1232 exit;
1233
1234 InstallProgressBar.Position := 40;
1235 // ------------------------------------------
1236
1237 // Help files
1238 if not InstallMultipleFiles( '*.hlp',
1239 HelpDir ) then
1240 exit;
1241
1242 // delete old newview.inf help files
1243
1244 // shouldn't have gone in the \os2\ dir
1245 if FileExists( FSystemDir + 'newview.inf' ) then
1246 DeleteFile( FSystemDir + 'newview.inf' );
1247
1248 // and we no longer want the .inf file at all
1249 if FileExists( BookDir + 'newview.inf' ) then
1250 DeleteFile( BookDir + 'newview.inf' );
1251
1252 InstallProgressBar.Position := 50;
1253 // ------------------------------------------
1254
1255 // Text files
1256 if not InstallMultipleFiles( '*.txt',
1257 DocDir ) then
1258 exit;
1259
1260 InstallProgressBar.Position := 60;
1261 // ------------------------------------------
1262
1263 // Language files
1264 if not InstallMultipleFiles( '*.lng',
1265 LanguageDir ) then
1266 exit;
1267
1268 InstallProgressBar.Position := 80;
1269 // ------------------------------------------
1270
1271 // Desktop icon
1272 // create new object
1273 if CreateIconCheckBox.Checked then
1274 begin
1275 // see if this is ECS with NewView
1276 ProgramObjectHandle :=
1277 WinQueryObject( ECSNewViewObjectID );
1278
1279 if ProgramObjectHandle <> NULLHANDLE then
1280 // yes, replace that
1281 ObjectID := ECSNewViewObjectID
1282 else
1283 // no, create our own
1284 ObjectID := NewViewObjectID;
1285
1286 if CreateDesktopIcon( FAppInstallPath,
1287 ObjectID,
1288 'Help Viewer',
1289 IPFFiles // always associate
1290 ) = NULLHANDLE then
1291 exit;
1292 end;
1293
1294 InstallProgressBar.Position := 100;
1295
1296 Result := true;
1297
1298end;
1299
1300// Do a standalone install. Don't touch the operating system.
1301Function TMainForm.StandAloneInstall: boolean;
1302var
1303 InstallDir: string;
1304 Dummy: boolean;
1305 hDesktopObject: HOBJECT;
1306begin
1307 Result := false;
1308
1309 FAppInUse := false;
1310 FDLLInUse := false;
1311
1312 InstallProgressBar.Position := 0;
1313 Application.ProcessMessages;
1314
1315 // validate/create install dir
1316 InstallDir := AddDirectorySeparator(InstallFolderEdit.Text);
1317 if InstallToSourceCheckbox.Checked then
1318 begin
1319 InstallDir := FSourceDir;
1320 end
1321 else if not DirectoryExists( InstallDir ) then
1322 begin
1323 try
1324 MakeDirs( InstallDir );
1325 except
1326 on E: EInOutError do
1327 begin
1328 DoErrorDlg( 'Folder Error',
1329 'Could not create the installation folder '
1330 + InstallDir + StrCRLF
1331 + SysErrorMessage( E.ErrorCode ) );
1332 exit;
1333 end;
1334 end;
1335 end;
1336
1337 // Where to put programs
1338 FAppInstallPath := InstallDir + 'NewView.exe';
1339 FStubInstallPath := InstallDir + 'ViewStub.exe';
1340 FDllInstallPath := InstallDir + 'newview.dll';
1341
1342 // check for existing files that might conflict
1343 if not CheckConflicts( 'PATH',
1344 FAppInstallPath ) then
1345 exit;
1346
1347 if not CheckConflicts( 'PATH',
1348 FStubInstallPath ) then
1349 exit;
1350
1351 if not CheckConflicts( 'HELP;BOOKSHELF',
1352 InstallDir + 'newview*.hlp' ) then
1353 exit;
1354
1355 // if not installing as-is...
1356 if UpperCase( FSourceDir ) <> UpperCase( InstallDir ) then
1357 begin
1358 // Main program
1359 if not InstallFile( 'NewView.exe',
1360 FAppInstallPath,
1361 '', // no backup
1362 true,
1363 FAppInUse ) then
1364 exit;
1365
1366 InstallProgressBar.Position := 20;
1367 // ------------------------------------------
1368
1369 // Stub
1370 if not InstallFile( 'ViewStub.exe',
1371 FStubInstallPath,
1372 '', // no backup
1373 true,
1374 FAppInUse ) then
1375 exit;
1376
1377 InstallProgressBar.Position := 40;
1378 // ------------------------------------------
1379
1380 // newview.dll
1381 if not InstallFile( 'NewView.dll',
1382 FDllInstallPath,
1383 '', // no backup
1384 false, // not in use
1385 Dummy ) then
1386 exit;
1387
1388 if FileExists( InstallDir + 'newview.inf' ) then
1389 DeleteFile( InstallDir + 'newview.inf' );
1390
1391 // Help files
1392 if not InstallMultipleFiles( '*.hlp',
1393 InstallDir ) then
1394 exit;
1395
1396 InstallProgressBar.Position := 50;
1397 // ------------------------------------------
1398
1399 // Text files
1400 if not InstallMultipleFiles( '*.txt',
1401 InstallDir ) then
1402 exit;
1403
1404 InstallProgressBar.Position := 60;
1405 // ------------------------------------------
1406
1407 // Language files
1408 if not InstallMultipleFiles( '*.lng',
1409 InstallDir ) then
1410 exit;
1411 end;
1412
1413 InstallProgressBar.Position := 80;
1414 // ------------------------------------------
1415
1416 // Desktop icon
1417 if CreateIconCheckBox.Checked then
1418 begin
1419 hDesktopObject := CreateDesktopIcon( FAppInstallPath,
1420 NewViewObjectID,
1421 'NewView',
1422 GetAssociations );
1423 if hDesktopObject = NULLHANDLE then
1424 exit;
1425 if AssociateCheckBox.Checked then
1426 if AssociateAsDefaultCheckBox.Checked then
1427 if not MakeDefaultAssociations( IPFFiles,
1428 hDesktopObject ) then
1429 exit;
1430 end;
1431
1432 InstallProgressBar.Position := 100;
1433
1434 Result := true;
1435end;
1436
1437Procedure TMainForm.RunNewView;
1438begin
1439 Exec( FAppInstallPath, '' );
1440end;
1441
1442Initialization
1443 RegisterClasses ([TMainForm, TLabel, TButton, TNoteBook,
1444 TCheckBox, TProgressBar, TBevel, TRadioGroup, TEdit, TImage]);
1445End.
Note: See TracBrowser for help on using the repository browser.