source: trunk/installer/MainFormUnit.pas

Last change on this file was 494, checked in by ataylor, 20 months ago

Update version to 2.19.9; update installer, release notes, and build notes.
  • Property svn:eol-style set to native
File size: 40.0 KB
RevLine 
[144]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
[208]10 OS2Def,
11 PmWin,
12 Classes,
13 Forms,
14 Graphics,
15 ExtCtrls,
16 Buttons,
17 StdCtrls,
18 TabCtrls,
19 ComCtrls;
[144]20
21Const
22 Vendor = 'Aaron Lawrence';
23 Description = 'NewView Install';
24
[494]25 Version = 'V1.10.3'; // $SS_REQUIRE_NEW_VERSION$
26 BldLevelVersion = '1.10.3'; // Embedded for IBM BLDLEVEL tool
[144]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
[208]169 BseDos,
170 BseErr,
171 PmWp,
172 PmShl,
173 PmErr,
174 SysUtils,
175 Dos,
176 Dialogs,
177 ACLUtility,
178 ACLDialogs,
[144]179 ControlsUtility,
[208]180 ChooseFolderFormUnit,
181 FileUtilsUnit,
182 CharUtilsUnit,
183 StringUtilsUnit;
[144]184
[409]185{$R NewViewInstall}
[144]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>';
[434]201 WPNewViewObjectID = '<WP_NEWVIEW>';
[144]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
[208]407 Result := AddDirectorySeparator( Result );
[144]408end;
409
410Procedure TMainForm.CheckEnvironment;
411begin
412 FSourceDir := GetApplicationDir;
413
[208]414 FSystemDir := GetBootDriveLetter + ':\os2\';
415 FSystemDLLDir := FSystemDir + 'dll\';
[144]416
[425]417 // aos/ecs things
[144]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
[208]430 InstallFolderEdit.Text := AddDirectorySeparator(FEnv_Programs) + 'NewView'
[144]431 else
[208]432 InstallFolderEdit.Text := GetBootDriveLetter + ':\NewView';
[144]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',
[208]517 'The file ' + StrCRLF
518 + ' ' + DestinationPath + StrCRLF
[144]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',
[208]548 'This file is in use: ' + StrCRLF
549 + ' ' + DestinationPath + StrCRLF
[144]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',
[208]563 'Could not unlock ' + StrCRLF
564 + ' ' + DestinationPath + StrCRLF
[144]565 + SysErrorMessage( rc ) );
566
567 exit;
568 end;
569 end
570 else if rc <> 0 then
571 begin
572 DoErrorDlg( 'Install Error',
[425]573 'Unable to access ' + StrCRLF
[208]574 + ' ' + DestinationPath + StrCRLF
[144]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',
[208]593 'Could not backup ' + StrCRLF
594 + ' ' + DestinationPath + StrCRLF
595 + ' to' + StrCRLF
596 + ' ' + Backup + StrCRLF
597 + StrCRLF
[144]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',
[208]613 'Could not copy new file ' + StrCRLF
614 + ' ' + SourcePath + StrCRLF
615 + ' to' + StrCRLF
616 + ' ' + DestinationPath + StrCRLF
617 + StrCRLF
[144]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;
[208]636 ListFilesInDirectory( FSourceDir,
[144]637 Filter,
[208]638 false, // don't need subdirs
639 Files); // don't need subdirs
[144]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
[208]696 RemainingLength := PCharPointerDiff( pHandleListData + HandleListSize,
[144]697 pHandleString );
[208]698 HandleString := StrPasWithLength( pHandleString, RemainingLength );
[144]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
[208]758 ActualLength := PCharPointerDiff( pHandleString, pHandleListData );
[144]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
[208]804function MakeDefaultAssociations( const aMask: string;
[144]805 hDesktopObject: HOBJECT ): boolean;
806var
[208]807 tmpMask : String;
808 tmpMasks : TStringList;
809 i : longint;
[144]810begin
811 Result := false;
[208]812
813 tmpMasks := TStringList.Create;
814 StrExtractStrings(tmpMasks, aMask, [','], #0);
815
816 for i := 0 to tmpMasks.Count - 1 do
[144]817 begin
[208]818 tmpMask := tmpMasks[i];
819 if not makeDefaultAssociation(tmpMask, hDesktopObject ) then
820 begin
821 tmpMasks.Destroy;
[144]822 exit;
[208]823 end;
[144]824 end;
[208]825
826 tmpMasks.Destroy;
827
[144]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
[434]851 '<WP_TOOLS>',
852 CO_UPDATEIFEXISTS );
[144]853
854 if Result <> NULLHANDLE then
[434]855 begin
[144]856 // OK
[434]857 WinCreateObject( 'WPShadow', // class
858 Description,
859 'SHADOWID=' + ID, // setup string
860 '<WP_DESKTOP>',
861 CO_UPDATEIFEXISTS );
[144]862 exit;
[434]863 end;
[144]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',
[208]873 'Unable to create desktop icon:' + StrCRLF
[144]874 + IntToHex( PMError, 8 )
[434]875 + ': The target folder is not correctly installed '
876 + '(<WP_TOOLS> missing). ' );
[144]877
878 WPERR_NOT_WORKPLACE_CLASS:
879 DoErrorDlg( 'Warning',
[208]880 'Unable to create desktop icon:' + StrCRLF
[144]881 + IntToHex( PMError, 8 )
882 + ': WPProgram class is missing.' );
883
884 else
885 DoErrorDlg( 'Installation Error',
[208]886 'Unable to create desktop icon' + StrCRLF
[144]887 + IntToHex( PMError, 8 )
888 + ': There may be some problem with the desktop.' );
889 end;
[434]890
[144]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;
[208]907 tmpVarNames : TStringList;
[144]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 );
[208]917
918 tmpVarNames := TStringList.Create;
919 StrExtractStrings(tmpVarNames, VarNames, [';'], #0);
920 for i := 0 to tmpVarNames.Count - 1 do
[144]921 begin
[208]922 GetFilesInPath( tmpVarNames[i], FileName, Files );
[144]923 end;
[208]924 tmpVarNames.Destroy;
[144]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
[208]938 if StrEqualIgnoringCase( FileDir, CorrectDir )
939 or StrEqualIgnoringCase( FileDir, GetApplicationDir )
[144]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'
[208]950 + StrCRLF
[144]951 + ' ' + FileName
[208]952 + StrCRLF
[144]953 + 'will be installed to '
[208]954 + StrCRLF
[144]955 + ' ' + ExtractFilePath( CorrectPath )
[208]956 + StrCRLF
[144]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
[425]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
[144]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;
[425]1062 HelpMgrDllPath: string;
1063 HelpMgrOriginal: string;
[144]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 '
[208]1137 + DocDir+ StrCRLF
[144]1138 + SysErrorMessage( E.ErrorCode ) );
1139 exit;
1140 end;
1141 end;
1142 end;
1143
1144 // install viewer app to either x:\os2
[425]1145 // or on ArcaOS or eCS, %OSDIR%\bin
[144]1146 if FEnv_OSDir <> '' then
1147 begin
[425]1148 // aos/ecs - with a dir specified
[144]1149 AppDir := FEnv_OSDir + 'bin\';
1150 end
1151 else
1152 begin
1153 // OS/2
1154 AppDir := FSystemDir;
1155 end;
1156
[425]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;
[144]1165
1166 // Where shall we put the programs eh?
1167 FAppInstallPath := AppDir + 'NewView.exe';
1168 FStubInstallPath := FSystemDir + 'view.exe';
1169
[425]1170 if FEnv_OSDir <> '' then
1171 begin
1172 FDllInstallPath := FEnv_OSDir + 'dll\';
1173 end
1174 else
1175 begin
1176 FDllInstallPath := FSystemDLLDir;
1177 end;
1178
[144]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
[425]1277 HelpMgrDllPath := FDllInstallPath + 'HelpMgr.dll';
1278 HelpMgrOriginal := FSystemDLLDir + 'HelpMgr.dll';
[144]1279 HelpMgrBackupPath := FSystemDLLDir + 'HelpMgr.bak';
[425]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
[144]1294 if not InstallFile( 'HelpMgr.dll',
[425]1295 HelpMgrDllPath,
1296 '',
[144]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',
[425]1331 FDllInstallPath + 'newview.dll',
[144]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
[434]1386 begin
1387 ProgramObjectHandle :=
1388 WinQueryObject( WPNewViewObjectID );
1389 if ProgramObjectHandle <> NULLHANDLE then
1390 ObjectID := WPNewViewObjectID
1391 else
1392 ObjectID := NewViewObjectID;
1393 end;
[144]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
[208]1425 InstallDir := AddDirectorySeparator(InstallFolderEdit.Text);
[144]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 '
[208]1439 + InstallDir + StrCRLF
[144]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.