source: trunk/installer/MainFormUnit.pas@ 462

Last change on this file since 462 was 434, checked in by ataylor, 6 years ago

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