source: trunk/installer/MainFormUnit.pas@ 425

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

Updated old-style installer for compatibility with existing installations on ArcaOS etc.
  • Property svn:eol-style set to native
File size: 39.6 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.1'; // $SS_REQUIRE_NEW_VERSION$
26 BldLevelVersion = '1.10.1'; // 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 // aos/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 access ' + 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
978function MoveFileError( const Source: string;
979 const Dest: string;
980 const IsModule: boolean;
981 var SourceInUse: boolean ): boolean;
982var
983 rc: APIRET;
984 szSource: cstring;
985 FileHandle: HFILE;
986 ActionTaken: ULONG;
987begin
988 // First copy the file
989 Result := CopyFileError( Source,
990 Dest );
991 if not Result then exit;
992
993 // Now delete the original
994 szSource := Source;
995 // see if it's in use.
996 rc := DosOpen( szSource,
997 FileHandle,
998 ActionTaken,
999 0, // new size: not used
1000 0, // attributes: not used
1001 OPEN_ACTION_FAIL_IF_NEW + OPEN_ACTION_OPEN_IF_EXISTS,
1002 OPEN_FLAGS_FAIL_ON_ERROR + OPEN_SHARE_DENYREADWRITE
1003 + OPEN_ACCESS_READWRITE,
1004 nil ); // e.a.s: not used
1005 DosClose( FileHandle );
1006 if rc = ERROR_SHARING_VIOLATION then
1007 begin
1008 // file in use
1009 if not IsModule then
1010 begin
1011 Result := false;
1012 DoErrorDlg( 'Installation Error',
1013 'This file is in use: ' + StrCRLF
1014 + ' ' + Source + StrCRLF
1015 + 'and cannot be moved.' );
1016 exit;
1017 end;
1018
1019 // unlock the module
1020 SourceInUse := true;
1021 rc := DosReplaceModule( Addr( szSource ),
1022 nil,
1023 nil );
1024 if rc <> 0 then
1025 begin
1026 // error
1027 Result := false;
1028 DoErrorDlg( 'Install Error',
1029 'Could not unlock ' + StrCRLF
1030 + ' ' + Source + StrCRLF
1031 + SysErrorMessage( rc ) );
1032
1033 exit;
1034 end;
1035 end;
1036 Result := DeleteFile( Source );
1037end;
1038
1039// Do a full install, replacing parts of the operating system
1040// as needed.
1041// Either view only, or view and helpmgr
1042Function TMainForm.FullInstall: boolean;
1043var
1044 LanguageDir: string;
1045 HelpDir: string;
1046 BookDir: string;
1047 DocDir: string;
1048 AppDir: string;
1049 Dummy: boolean;
1050 ProgramObjectHandle: HOBJECT;
1051 ObjectID: string;
1052 rc: longint;
1053 HelpMgrDllPath: string;
1054 HelpMgrOriginal: string;
1055 HelpMgrBackupPath: string;
1056 StubBackupPath: string;
1057 IBMHelpMgrPath: cstring;
1058 IBMStubPath: cstring;
1059 ViewDocPath: cstring;
1060 ViewDocBackupPath: cstring;
1061begin
1062 Result := false;
1063
1064 FAppInUse := false;
1065 FDLLInUse := false;
1066
1067 InstallProgressBar.Position := 0;
1068 Application.ProcessMessages;
1069
1070 // validate system path
1071 if not DirectoryExists( FSystemDir ) then
1072 begin
1073 DoErrorDlg( 'System Folder Error',
1074 'The system folder '
1075 + FSystemDir
1076 + ' does not exist!' );
1077 exit;
1078 end;
1079
1080 if GetInstallType = itComplete then
1081 begin
1082 // validate system DLL path
1083 if not DirectoryExists( FSystemDLLDir ) then
1084 begin
1085 DoErrorDlg( 'System Folder Error',
1086 'The system DLL folder '
1087 + FSystemDLLDir
1088 + ' does not exist!' );
1089 exit;
1090 end;
1091 end;
1092
1093 // Validate help directory...
1094 if FEnv_OSDir <> '' then
1095 HelpDir := FEnv_OSDir + 'help\'
1096 else
1097 HelpDir := FSystemDir + 'help\';
1098
1099 if not DirectoryExists( HelpDir ) then
1100 begin
1101 DoErrorDlg( 'System Folder Error',
1102 'The system help folder '
1103 + HelpDir
1104 + ' does not exist!' );
1105 exit;
1106 end;
1107
1108 if FEnv_OSDir <> '' then
1109 BookDir := FEnv_OSDir + 'book\'
1110 else
1111 BookDir := FSystemDir + 'book\';
1112
1113 // Docs: Use a subdirectory
1114 if FEnv_OSDir <> '' then
1115 DocDir := FEnv_OSDir + 'doc\NewView\'
1116 else
1117 DocDir := BookDir + 'NewView\';
1118
1119 if not DirectoryExists( DocDir ) then
1120 begin
1121 try
1122 MakeDirs( DocDir );
1123 except
1124 on E: EInOutError do
1125 begin
1126 DoErrorDlg( 'Folder Error',
1127 'Could not create the NewView doc folder '
1128 + DocDir+ StrCRLF
1129 + SysErrorMessage( E.ErrorCode ) );
1130 exit;
1131 end;
1132 end;
1133 end;
1134
1135 // install viewer app to either x:\os2
1136 // or on ArcaOS or eCS, %OSDIR%\bin
1137 if FEnv_OSDir <> '' then
1138 begin
1139 // aos/ecs - with a dir specified
1140 AppDir := FEnv_OSDir + 'bin\';
1141 end
1142 else
1143 begin
1144 // OS/2
1145 AppDir := FSystemDir;
1146 end;
1147
1148 if FEnv_OSDir <> '' then
1149 begin
1150 LanguageDir := FEnv_OSDir + 'lang\';
1151 end
1152 else
1153 begin
1154 LanguageDir := AppDir; // for now.
1155 end;
1156
1157 // Where shall we put the programs eh?
1158 FAppInstallPath := AppDir + 'NewView.exe';
1159 FStubInstallPath := FSystemDir + 'view.exe';
1160
1161 if FEnv_OSDir <> '' then
1162 begin
1163 FDllInstallPath := FEnv_OSDir + 'dll\';
1164 end
1165 else
1166 begin
1167 FDllInstallPath := FSystemDLLDir;
1168 end;
1169
1170 // check for existing files that might conflict
1171 if not CheckConflicts( 'PATH',
1172 FAppInstallPath ) then
1173 exit;
1174
1175 if not CheckConflicts( 'PATH',
1176 FStubInstallPath ) then
1177 exit;
1178
1179 if not CheckConflicts( 'HELP;BOOKSHELF',
1180 HelpDir + 'newview*.hlp' ) then
1181 exit;
1182
1183 {
1184 // Doh! Not possible as LIBPATH is not an environment variable,
1185 // and there is no API to get it. Primitive... :/
1186 if not CheckConflicts( 'LIBPATH',
1187 FDllInstallPath ) then
1188 exit;
1189 }
1190
1191 InstallProgressBar.Position := 10;
1192 // ------------------------------------------
1193
1194 // Main program
1195 if not InstallFile( 'NewView.exe',
1196 FAppInstallPath,
1197 '', // no backup
1198 true,
1199 FAppInUse ) then
1200 exit;
1201
1202 InstallProgressBar.Position := 20;
1203 // ------------------------------------------
1204
1205 // Stub (View.exe)
1206 StubBackupPath := ChangeFileExt( FStubInstallPath, '.bak' );
1207 if not InstallFile( 'ViewStub.exe',
1208 FStubInstallPath,
1209 StubBackupPath,
1210 true,
1211 FAppInUse ) then
1212 exit;
1213
1214 IBMStubPath := FSystemDir + 'ibmview.exe';
1215 if not FileExists( IBMStubPath ) then
1216 begin
1217 // copy view.bak to ibmview.exe
1218 if not CopyFileError( StubBackupPath,
1219 IBMStubPath ) then
1220 exit;
1221
1222 rc := RenameModule( Addr( IBMStubPath ),
1223 RM_RENAME_IMPORTED_MODULE,
1224 'HELPMGR',
1225 'IBMHMGR' );
1226 if rc <> 0 then
1227 begin
1228 DoErrorDlg( 'Rename Module Error',
1229 'Error changing references to HelpMgr DLL in '
1230 + IBMStubPath
1231 + ': '
1232 + IntToStr( rc ) );
1233 exit;
1234 end;
1235 end;;
1236
1237 // backup viewdoc.exe
1238 ViewDocPath := FSystemDir + 'viewdoc.exe';
1239 ViewDocBackupPath := FSystemDir + 'viewdoc.bak';
1240 if not FileExists( ViewDocBackupPath ) then
1241 if not CopyFileError( ViewDocPath,
1242 ViewDocBackupPath ) then
1243 exit;
1244
1245 // In this case we do actually have to modify the
1246 // original file; because original View is hardcoded
1247 // with the name of viewdoc.exe (AFAIK)
1248 rc := RenameModule( Addr( ViewDocPath ),
1249 RM_RENAME_IMPORTED_MODULE,
1250 'HELPMGR',
1251 'IBMHMGR' );
1252 if rc <> 0 then
1253 begin
1254 DoErrorDlg( 'Rename Module Error',
1255 'Error changing references to HelpMgr DLL in '
1256 + ViewDocPath
1257 + ': '
1258 + IntToStr( rc ) );
1259 exit;
1260 end;
1261
1262 InstallProgressBar.Position := 30;
1263 // ------------------------------------------
1264
1265 // Help Manager DLL
1266 if GetInstallType = itComplete then
1267 begin
1268 HelpMgrDllPath := FDllInstallPath + 'HelpMgr.dll';
1269 HelpMgrOriginal := FSystemDLLDir + 'HelpMgr.dll';
1270 HelpMgrBackupPath := FSystemDLLDir + 'HelpMgr.bak';
1271
1272 // Back up the original HELPMGR.DLL. We have to do this separately
1273 // (rather than in Installfile) because it might not be in the same
1274 // place as our replacement.
1275 if FileExists( HelpMgrOriginal ) and
1276 not FileExists( HelpMgrBackupPath ) then
1277 begin
1278 if not MoveFileError( HelpMgrOriginal,
1279 HelpMgrBackupPath,
1280 true, FDLLInUse ) then
1281 exit;
1282 end;
1283
1284 // Now install the new HelpMgr
1285 if not InstallFile( 'HelpMgr.dll',
1286 HelpMgrDllPath,
1287 '',
1288 true,
1289 FDLLInUse ) then
1290 exit;
1291
1292 // if needed, copy backed up file to ibmhmgr.dll,
1293 // do internal rename
1294 IBMHelpMgrPath := FSystemDLLDir + 'ibmhmgr.dll';
1295
1296 if not FileExists( IBMHelpMgrPath ) then
1297 begin
1298 if not CopyFileError( HelpMgrBackupPath,
1299 IBMHelpMgrPath ) then
1300 exit;
1301
1302 rc := RenameModule( Addr( IBMHelpMgrPath ),
1303 RM_RENAME_MODULE,
1304 'HELPMGR',
1305 'IBMHMGR' );
1306 if rc <> 0 then
1307 begin
1308 DoErrorDlg( 'Rename Module Error',
1309 'Error changing old HelpMgr DLL module name: '
1310 + IntToStr( rc ) );
1311 exit;
1312 end;
1313 end;
1314
1315 end;
1316
1317 InstallProgressBar.Position := 35;
1318 // ------------------------------------------
1319
1320 // newview.dll
1321 if not InstallFile( 'NewView.dll',
1322 FDllInstallPath + 'newview.dll',
1323 '', // no backup
1324 false, // not in use
1325 Dummy ) then
1326 exit;
1327
1328 InstallProgressBar.Position := 40;
1329 // ------------------------------------------
1330
1331 // Help files
1332 if not InstallMultipleFiles( '*.hlp',
1333 HelpDir ) then
1334 exit;
1335
1336 // delete old newview.inf help files
1337
1338 // shouldn't have gone in the \os2\ dir
1339 if FileExists( FSystemDir + 'newview.inf' ) then
1340 DeleteFile( FSystemDir + 'newview.inf' );
1341
1342 // and we no longer want the .inf file at all
1343 if FileExists( BookDir + 'newview.inf' ) then
1344 DeleteFile( BookDir + 'newview.inf' );
1345
1346 InstallProgressBar.Position := 50;
1347 // ------------------------------------------
1348
1349 // Text files
1350 if not InstallMultipleFiles( '*.txt',
1351 DocDir ) then
1352 exit;
1353
1354 InstallProgressBar.Position := 60;
1355 // ------------------------------------------
1356
1357 // Language files
1358 if not InstallMultipleFiles( '*.lng',
1359 LanguageDir ) then
1360 exit;
1361
1362 InstallProgressBar.Position := 80;
1363 // ------------------------------------------
1364
1365 // Desktop icon
1366 // create new object
1367 if CreateIconCheckBox.Checked then
1368 begin
1369 // see if this is ECS with NewView
1370 ProgramObjectHandle :=
1371 WinQueryObject( ECSNewViewObjectID );
1372
1373 if ProgramObjectHandle <> NULLHANDLE then
1374 // yes, replace that
1375 ObjectID := ECSNewViewObjectID
1376 else
1377 // no, create our own
1378 ObjectID := NewViewObjectID;
1379
1380 if CreateDesktopIcon( FAppInstallPath,
1381 ObjectID,
1382 'Help Viewer',
1383 IPFFiles // always associate
1384 ) = NULLHANDLE then
1385 exit;
1386 end;
1387
1388 InstallProgressBar.Position := 100;
1389
1390 Result := true;
1391
1392end;
1393
1394// Do a standalone install. Don't touch the operating system.
1395Function TMainForm.StandAloneInstall: boolean;
1396var
1397 InstallDir: string;
1398 Dummy: boolean;
1399 hDesktopObject: HOBJECT;
1400begin
1401 Result := false;
1402
1403 FAppInUse := false;
1404 FDLLInUse := false;
1405
1406 InstallProgressBar.Position := 0;
1407 Application.ProcessMessages;
1408
1409 // validate/create install dir
1410 InstallDir := AddDirectorySeparator(InstallFolderEdit.Text);
1411 if InstallToSourceCheckbox.Checked then
1412 begin
1413 InstallDir := FSourceDir;
1414 end
1415 else if not DirectoryExists( InstallDir ) then
1416 begin
1417 try
1418 MakeDirs( InstallDir );
1419 except
1420 on E: EInOutError do
1421 begin
1422 DoErrorDlg( 'Folder Error',
1423 'Could not create the installation folder '
1424 + InstallDir + StrCRLF
1425 + SysErrorMessage( E.ErrorCode ) );
1426 exit;
1427 end;
1428 end;
1429 end;
1430
1431 // Where to put programs
1432 FAppInstallPath := InstallDir + 'NewView.exe';
1433 FStubInstallPath := InstallDir + 'ViewStub.exe';
1434 FDllInstallPath := InstallDir + 'newview.dll';
1435
1436 // check for existing files that might conflict
1437 if not CheckConflicts( 'PATH',
1438 FAppInstallPath ) then
1439 exit;
1440
1441 if not CheckConflicts( 'PATH',
1442 FStubInstallPath ) then
1443 exit;
1444
1445 if not CheckConflicts( 'HELP;BOOKSHELF',
1446 InstallDir + 'newview*.hlp' ) then
1447 exit;
1448
1449 // if not installing as-is...
1450 if UpperCase( FSourceDir ) <> UpperCase( InstallDir ) then
1451 begin
1452 // Main program
1453 if not InstallFile( 'NewView.exe',
1454 FAppInstallPath,
1455 '', // no backup
1456 true,
1457 FAppInUse ) then
1458 exit;
1459
1460 InstallProgressBar.Position := 20;
1461 // ------------------------------------------
1462
1463 // Stub
1464 if not InstallFile( 'ViewStub.exe',
1465 FStubInstallPath,
1466 '', // no backup
1467 true,
1468 FAppInUse ) then
1469 exit;
1470
1471 InstallProgressBar.Position := 40;
1472 // ------------------------------------------
1473
1474 // newview.dll
1475 if not InstallFile( 'NewView.dll',
1476 FDllInstallPath,
1477 '', // no backup
1478 false, // not in use
1479 Dummy ) then
1480 exit;
1481
1482 if FileExists( InstallDir + 'newview.inf' ) then
1483 DeleteFile( InstallDir + 'newview.inf' );
1484
1485 // Help files
1486 if not InstallMultipleFiles( '*.hlp',
1487 InstallDir ) then
1488 exit;
1489
1490 InstallProgressBar.Position := 50;
1491 // ------------------------------------------
1492
1493 // Text files
1494 if not InstallMultipleFiles( '*.txt',
1495 InstallDir ) then
1496 exit;
1497
1498 InstallProgressBar.Position := 60;
1499 // ------------------------------------------
1500
1501 // Language files
1502 if not InstallMultipleFiles( '*.lng',
1503 InstallDir ) then
1504 exit;
1505 end;
1506
1507 InstallProgressBar.Position := 80;
1508 // ------------------------------------------
1509
1510 // Desktop icon
1511 if CreateIconCheckBox.Checked then
1512 begin
1513 hDesktopObject := CreateDesktopIcon( FAppInstallPath,
1514 NewViewObjectID,
1515 'NewView',
1516 GetAssociations );
1517 if hDesktopObject = NULLHANDLE then
1518 exit;
1519 if AssociateCheckBox.Checked then
1520 if AssociateAsDefaultCheckBox.Checked then
1521 if not MakeDefaultAssociations( IPFFiles,
1522 hDesktopObject ) then
1523 exit;
1524 end;
1525
1526 InstallProgressBar.Position := 100;
1527
1528 Result := true;
1529end;
1530
1531Procedure TMainForm.RunNewView;
1532begin
1533 Exec( FAppInstallPath, '' );
1534end;
1535
1536Initialization
1537 RegisterClasses ([TMainForm, TLabel, TButton, TNoteBook,
1538 TCheckBox, TProgressBar, TBevel, TRadioGroup, TEdit, TImage]);
1539End.
Note: See TracBrowser for help on using the repository browser.