source: trunk/installer/MainFormUnit.pas@ 145

Last change on this file since 145 was 144, checked in by RBRi, 18 years ago

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