source: cprs/trunk/CPRS-Lib/ORSystem.pas@ 1676

Last change on this file since 1676 was 829, checked in by Kevin Toppenberg, 14 years ago

Upgrade to version 27

File size: 16.9 KB
Line 
1unit ORSystem;
2
3{$O-}
4{$WARN SYMBOL_PLATFORM OFF}
5
6interface
7
8uses SysUtils, Windows, Classes, Forms, Registry, ORFn;
9
10const
11 CPRS_ROOT_KEY = HKEY_LOCAL_MACHINE;
12 CPRS_USER_KEY = HKEY_CURRENT_USER;
13 CPRS_SOFTWARE = 'Software\Vista\CPRS';
14 CPRS_REG_AUTO = 'AutoUpdate';
15 CPRS_REG_GOLD = 'GoldCopyPath';
16 CPRS_REG_ONLY = 'LimitUpdate';
17 CPRS_REG_ASK = 'AskFirst';
18 CPRS_REG_LAST = 'LastUpdate-';
19 CPRS_USER_LAST = 'Software\Vista\CPRS\LastUpdate';
20 CPRS_LAST_DATE = 'Software\Vista\CPRS\DateUpdated';
21
22function AppOutOfDate(AppName: string): Boolean;
23function ClientVersion(const AFileName: string): string;
24function CompareVersion(const A, B: string): Integer;
25procedure CopyFileDate(const Source, Dest: string);
26procedure CopyLastWriteTime(const Source, Dest: string);
27//procedure CopyFileWithDate(const FromFileName, ToFileName: string);
28procedure Delay(i: Integer);
29//procedure FileCopy(const FromFileName, ToFileName: string);
30//procedure FileCopyWithDate(const FromFileName, ToFileName: string);
31function FullToFilePart(const AFileName: string): string;
32function FullToPathPart(const AFileName: string): string;
33function IsWin95Style: Boolean;
34function ParamIndex(const AName: string): Integer;
35function ParamSearch(const AName: string): string;
36function QuotedExeName: string;
37function RegKeyExists(ARoot: HKEY; const AKey: string): Boolean;
38function RegReadInt(const AName: string): Integer;
39function RegReadStr(const AName: string): string;
40function RegReadBool(const AName: string): Boolean;
41procedure RegWriteInt(const AName: string; AValue: Integer);
42procedure RegWriteStr(const AName, AValue: string);
43procedure RegWriteBool(const AName: string; AValue: Boolean);
44function UserRegReadDateTime(const AKey, AName: string): TDateTime;
45procedure UserRegWriteDateTime(const AKey, AName: string; AValue: TDateTime);
46function UserRegReadInt(const AKey, AName: string): Integer;
47procedure UserRegWriteInt(const AKey, AName: string; AValue: Integer);
48procedure RunProgram(const AppName: string);
49function UpdateSelf: Boolean;
50function BorlandDLLVersionOK: boolean;
51
52implementation
53
54const
55 CREATE_KEY = True; // cause key to be created if it's not in the registry
56
57function FileLastWrite(const FileName: string): LARGE_INTEGER;
58var
59 AHandle: THandle;
60 FindData: TWin32FindData;
61begin
62 Result.QuadPart := 0;
63 AHandle := FindFirstFile(PChar(FileName), FindData);
64 if AHandle <> INVALID_HANDLE_VALUE then
65 begin
66 Windows.FindClose(AHandle);
67 Result.LowPart := FindData.ftLastWriteTime.dwLowDateTime;
68 Result.HighPart := FindData.ftLastWriteTime.dwHighDateTime;
69 end;
70end;
71
72function AppOutOfDate(AppName: string): Boolean;
73const
74 FIVE_SECONDS = 0.000055;
75 FIVE_SECONDS_NT = 50000000;
76var
77 GoldName, DriveRoot, x: string;
78 DriveType: Integer;
79 LastWriteApp, LastWriteGold: LARGE_INTEGER;
80begin
81 Result := False;
82 // check command line params for no-update parameter
83 if ParamIndex('NOCOPY') > 0 then Exit;
84 // check time of last update, don't retry if too recently called
85 if Abs(Now - UserRegReadDateTime(CPRS_LAST_DATE, FullToFilePart(AppName))) < FIVE_SECONDS
86 then Exit;
87 // check auto-update registry entry
88 if RegReadBool(CPRS_REG_AUTO) = False then Exit;
89 // check directory - if remote then don't allow update
90 if Pos('\\', AppName) = 1 then Exit;
91 if Pos(':', AppName) > 0
92 then DriveRoot := Piece(AppName, ':', 1) + ':\'
93 else DriveRoot := '\';
94 DriveType := GetDriveType(PChar(DriveRoot));
95 if not ((DriveType = DRIVE_FIXED) or (DriveType = DRIVE_REMOVABLE)) then Exit;
96 // check registry to see if updates limited to particular directory
97 x := RegReadStr(CPRS_REG_ONLY);
98 if (Length(x) > 0) and (CompareText(x, FullToPathPart(AppName)) <> 0) then Exit;
99 // check for different file date in the gold directory
100 GoldName := RegReadStr(CPRS_REG_GOLD);
101 if (Length(GoldName) = 0) then exit;
102 if not DirectoryExists(GoldName) then
103 begin
104 if Pos('"', Goldname) > 0 then
105 begin
106 Goldname := Copy(GoldName, 2, MaxInt);
107 if Pos('"', Goldname) > 0 then
108 Goldname := Copy(GoldName, 1, Length(GoldName) - 1);
109 end;
110 end;
111 if (not DirectoryExists(GoldName)) then Exit;
112 GoldName := GoldName + FullToFilePart(AppName);
113 if FileExists(GoldName) then
114 begin
115 LastWriteApp := FileLastWrite(AppName);
116 LastWriteGold := FileLastWrite(GoldName);
117 // check within 5 seconds to work around diffs in NTFS & FAT timestamps
118 if Abs(LastWriteApp.QuadPart - LastWriteGold.QuadPart) > FIVE_SECONDS_NT then Result := True;
119 //if CompareFileTime(LastWriteApp, LastWriteGold) <> 0 then Result := True;
120 end;
121end;
122
123function ClientVersion(const AFileName: string): string;
124var
125 ASize, AHandle: DWORD;
126 Buf: string;
127 FileInfoPtr: Pointer; //PVSFixedFileInfo;
128begin
129 Result := '';
130 ASize:=GetFileVersionInfoSize(PChar(AFileName), AHandle);
131 if ASize > 0 then
132 begin
133 SetLength(Buf, ASize);
134 GetFileVersionInfo(PChar(AFileName), AHandle, ASize, Pointer(Buf));
135 VerQueryValue(Pointer(Buf), '\', FileInfoPtr, ASize);
136 with TVSFixedFileInfo(FileInfoPtr^) do Result := IntToStr(HIWORD(dwFileVersionMS)) + '.' +
137 IntToStr(LOWORD(dwFileVersionMS)) + '.' +
138 IntToStr(HIWORD(dwFileVersionLS)) + '.' +
139 IntToStr(LOWORD(dwFileVersionLS));
140 end;
141end;
142
143function CompareVersion(const A, B: string): Integer;
144var
145 NumA, NumB: Integer;
146begin
147 NumA := (StrToInt(Piece(A, '.', 1)) * 16777216) +
148 (StrToInt(Piece(A, '.', 2)) * 65536) +
149 (StrToInt(Piece(A, '.', 3)) * 256) +
150 StrToInt(Piece(A, '.', 4));
151 NumB := (StrToInt(Piece(B, '.', 1)) * 16777216) +
152 (StrToInt(Piece(B, '.', 2)) * 65536) +
153 (StrToInt(Piece(B, '.', 3)) * 256) +
154 StrToInt(Piece(B, '.', 4));
155 Result := NumA - NumB;
156end;
157
158procedure CopyFileDate(const Source, Dest: string);
159{ from TI2972 }
160var
161 SourceHand, DestHand: Integer;
162begin
163 SourceHand := FileOpen(Source, fmOutput); { open source file }
164 DestHand := FileOpen(Dest, fmInput); { open dest file }
165 FileSetDate(DestHand, FileGetDate(SourceHand)); { get/set date }
166 FileClose(SourceHand); { close source file }
167 FileClose(DestHand); { close dest file }
168end;
169
170procedure CopyLastWriteTime(const Source, Dest: string);
171var
172 HandleSrc, HandleDest: Integer;
173 LastWriteTime: TFileTime;
174begin
175 HandleSrc := FileOpen(Source, fmOpenRead or fmShareDenyNone);
176 HandleDest := FileOpen(Dest, fmOpenWrite);
177 if (HandleSrc > 0) and (HandleDest > 0) then
178 begin
179 if GetFileTime(THandle(HandleSrc), nil, nil, @LastWriteTime) = TRUE
180 then SetFileTime(THandle(HandleDest), nil, nil, @LastWriteTime);
181 FileClose(HandleSrc);
182 FileClose(HandleDest);
183 end;
184end;
185
186procedure Delay(i: Integer);
187const
188 AMilliSecond = 0.000000011574;
189var
190 Start: TDateTime;
191begin
192 Start := Now;
193 while Now < (Start + (i * AMilliSecond)) do Application.ProcessMessages;
194end;
195
196procedure FileCopy(const FromFileName, ToFileName: string);
197var
198 FromFile, ToFile: file;
199 NumRead, NumWritten: Integer;
200 Buf: array[1..16384] of Char;
201begin
202 AssignFile(FromFile, FromFileName); // Input file
203 Reset(FromFile, 1); // Record size = 1
204 AssignFile(ToFile, ToFileName); // Output file
205 Rewrite(ToFile, 1); // Record size = 1
206 repeat
207 BlockRead(FromFile, Buf, SizeOf(Buf), NumRead);
208 BlockWrite(ToFile, Buf, NumRead, NumWritten);
209 until (NumRead = 0) or (NumWritten <> NumRead);
210 CloseFile(FromFile);
211 CloseFile(ToFile);
212end;
213
214procedure FileCopyWithDate(const FromFileName, ToFileName: string);
215var
216 FileHandle, ADate: Integer;
217begin
218 FileCopy(FromFileName, ToFileName);
219 FileHandle := FileOpen(FromFileName, fmOpenRead or fmShareDenyNone);
220 ADate := FileGetDate(FileHandle);
221 FileClose(FileHandle);
222 if ADate < 0 then Exit;
223 FileHandle := FileOpen(ToFileName, fmOpenWrite or fmShareDenyNone);
224 if FileHandle > 0 then FileSetDate(FileHandle, ADate);
225 FileClose(FileHandle);
226end;
227
228procedure CopyFileWithDate(const FromFileName, ToFileName: string);
229var
230 FileHandle, ADate: Integer;
231begin
232 if CopyFile(PChar(FromFileName), PChar(ToFileName), False) then
233 begin
234 FileHandle := FileOpen(FromFileName, fmOpenRead or fmShareDenyNone);
235 ADate := FileGetDate(FileHandle);
236 FileClose(FileHandle);
237 if ADate < 0 then Exit;
238 FileHandle := FileOpen(ToFileName, fmOpenWrite or fmShareDenyNone);
239 if FileHandle > 0 then FileSetDate(FileHandle, ADate);
240 FileClose(FileHandle);
241 end;
242end;
243
244function FullToFilePart(const AFileName: string): string;
245var
246 DirBuf: string;
247 FilePart: PChar;
248 NameLen: DWORD;
249begin
250 Result := '';
251 SetString(DirBuf, nil, 255);
252 NameLen := GetFullPathName(PChar(AFileName), 255, PChar(DirBuf), FilePart);
253 if NameLen > 0 then Result := FilePart;
254end;
255
256function FullToPathPart(const AFileName: string): string;
257var
258 DirBuf: string;
259 FilePart: PChar;
260 NameLen: Cardinal;
261begin
262 Result := '';
263 SetString(DirBuf, nil, 255);
264 NameLen := GetFullPathName(PChar(AFileName), 255, PChar(DirBuf), FilePart);
265 if NameLen > 0 then Result := Copy(DirBuf, 1, NameLen - StrLen(FilePart));
266end;
267
268function IsWin95Style: Boolean;
269begin
270 Result := Lo(GetVersion) >= 4; // True = Win95 interface, otherwise old interface
271end;
272
273function ParamIndex(const AName: string): Integer;
274var
275 i: Integer;
276 x: string;
277begin
278 Result := 0;
279 for i := 1 to ParamCount do
280 begin
281 x := UpperCase(ParamStr(i));
282 x := Piece(x, '=', 1);
283 if x = Uppercase(AName) then
284 begin
285 Result := i;
286 Break;
287 end;
288 end; {for i}
289end;
290
291function ParamSearch(const AName: string): string;
292var
293 i: Integer;
294 x: string;
295begin
296 Result := '';
297 for i := 1 to ParamCount do
298 begin
299 x := UpperCase(ParamStr(i));
300 x := Copy(x, 1, Pos('=', x) - 1);
301 if x = Uppercase(AName) then
302 begin
303 Result := UpperCase(Copy(ParamStr(i), Length(x) + 2, Length(ParamStr(i))));
304 Break;
305 end;
306 end; {for i}
307end;
308
309function QuotedExeName: string;
310var
311 i: Integer;
312begin
313 Result := '"' + ParamStr(0) + '"';
314 for i := 1 to ParamCount do Result := Result + ' ' + ParamStr(i);
315end;
316
317function RegReadInt(const AName: string): Integer;
318var
319 Registry: TRegistry;
320begin
321 Result := 0;
322 Registry := TRegistry.Create;
323 try
324 Registry.RootKey := CPRS_ROOT_KEY;
325 if Registry.OpenKeyReadOnly(CPRS_SOFTWARE) and Registry.ValueExists(AName)
326 then Result := Registry.ReadInteger(AName);
327 Registry.CloseKey;
328 finally
329 Registry.Free;
330 end;
331end;
332
333function RegReadStr(const AName: string): string;
334var
335 Registry: TRegistry;
336begin
337 Result := '';
338 Registry := TRegistry.Create;
339 try
340 Registry.RootKey := CPRS_ROOT_KEY;
341 if Registry.OpenKeyReadOnly(CPRS_SOFTWARE) and Registry.ValueExists(AName)
342 then Result := Registry.ReadString(AName);
343 Registry.CloseKey;
344 finally
345 Registry.Free;
346 end;
347end;
348
349function RegReadBool(const AName: string): Boolean;
350var
351 Registry: TRegistry;
352begin
353 Result := False;
354 Registry := TRegistry.Create;
355 try
356 Registry.RootKey := CPRS_ROOT_KEY;
357 if Registry.OpenKeyReadOnly(CPRS_SOFTWARE) and Registry.ValueExists(AName)
358 then Result := Registry.ReadBool(AName);
359 Registry.CloseKey;
360 finally
361 Registry.Free;
362 end;
363end;
364
365procedure RegWriteInt(const AName: string; AValue: Integer);
366var
367 Registry: TRegistry;
368begin
369 Registry := TRegistry.Create;
370 try
371 Registry.RootKey := CPRS_ROOT_KEY;
372 if Registry.OpenKey(CPRS_SOFTWARE, CREATE_KEY) then Registry.WriteInteger(AName, AValue);
373 Registry.CloseKey;
374 finally
375 Registry.Free;
376 end;
377end;
378
379procedure RegWriteStr(const AName, AValue: string);
380var
381 Registry: TRegistry;
382begin
383 Registry := TRegistry.Create;
384 try
385 Registry.RootKey := CPRS_ROOT_KEY;
386 if Registry.OpenKey(CPRS_SOFTWARE, CREATE_KEY) then Registry.WriteString(AName, AValue);
387 Registry.CloseKey;
388 finally
389 Registry.Free;
390 end;
391end;
392
393procedure RegWriteBool(const AName: string; AValue: Boolean);
394var
395 Registry: TRegistry;
396begin
397 Registry := TRegistry.Create;
398 try
399 Registry.RootKey := CPRS_ROOT_KEY;
400 if Registry.OpenKey(CPRS_SOFTWARE, CREATE_KEY) then Registry.WriteBool(AName, AValue);
401 Registry.CloseKey;
402 finally
403 Registry.Free;
404 end;
405end;
406
407function RegKeyExists(ARoot: HKEY; const AKey: string): Boolean;
408var
409 Registry: TRegistry;
410begin
411 Result := False;
412 Registry := TRegistry.Create;
413 try
414 Registry.RootKey := ARoot;
415 //Result := Registry.KeyExists(AKey); {this tries to open key with full access}
416 if Registry.OpenKeyReadOnly(AKey) and (Registry.CurrentKey <> 0) then Result := True;
417 Registry.CloseKey;
418 finally
419 Registry.Free;
420 end;
421end;
422
423function UserRegReadDateTime(const AKey, AName: string): TDateTime;
424var
425 Registry: TRegistry;
426begin
427 Result := 0;
428 Registry := TRegistry.Create;
429 try
430 Registry.RootKey := CPRS_USER_KEY;
431 if Registry.OpenKey(AKey, CREATE_KEY) and Registry.ValueExists(AName) then
432 try
433 Result := Registry.ReadDateTime(AName);
434 except
435 on ERegistryException do Result := 0;
436 end;
437 Registry.CloseKey;
438 finally
439 Registry.Free;
440 end;
441end;
442
443procedure UserRegWriteDateTime(const AKey, AName: string; AValue: TDateTime);
444var
445 Registry: TRegistry;
446begin
447 Registry := TRegistry.Create;
448 try
449 Registry.RootKey := CPRS_USER_KEY;
450 if Registry.OpenKey(AKey, CREATE_KEY) then Registry.WriteDateTime(AName, AValue);
451 Registry.CloseKey;
452 finally
453 Registry.Free;
454 end;
455end;
456
457function UserRegReadInt(const AKey, AName: string): Integer;
458var
459 Registry: TRegistry;
460begin
461 Result := 0;
462 Registry := TRegistry.Create;
463 try
464 Registry.RootKey := CPRS_USER_KEY;
465 if Registry.OpenKey(AKey, CREATE_KEY) and Registry.ValueExists(AName)
466 then Result := Registry.ReadInteger(AName);
467 Registry.CloseKey;
468 finally
469 Registry.Free;
470 end;
471end;
472
473procedure UserRegWriteInt(const AKey, AName: string; AValue: Integer);
474var
475 Registry: TRegistry;
476begin
477 Registry := TRegistry.Create;
478 try
479 Registry.RootKey := CPRS_USER_KEY;
480 if Registry.OpenKey(AKey, CREATE_KEY) then Registry.WriteInteger(AName, AValue);
481 Registry.CloseKey;
482 finally
483 Registry.Free;
484 end;
485end;
486
487procedure RunProgram(const AppName: string);
488var
489 StartInfo: TStartupInfo;
490 ProcInfo: TProcessInformation;
491begin
492 FillChar(StartInfo, SizeOf(StartInfo), 0);
493 StartInfo.CB := SizeOf(StartInfo);
494 CreateProcess(nil, PChar(AppName), nil, nil, False, DETACHED_PROCESS or NORMAL_PRIORITY_CLASS,
495 nil, nil, StartInfo, ProcInfo);
496end;
497
498function UpdateSelf: Boolean;
499var
500 CPRSUpdate: string;
501begin
502 // auto-update if newer version available
503 Result := False;
504 CPRSUpdate := RegReadStr(CPRS_REG_GOLD) + 'CPRSUpdate.exe';
505 if not FileExists(CPRSUpdate) then CPRSUpdate := 'CPRSUpdate.exe';
506 if AppOutOfDate(Application.ExeName) and FileExists(CPRSUpdate) then
507 begin
508 Result := True;
509 RunProgram(CPRSUpdate + ' COPY=' + QuotedExeName);
510 end;
511end;
512
513(*
514procedure UpdateAppFromGold(const AppName: string);
515var
516 GoldName: string;
517begin
518 Delay(1500);
519 // do a rename of AppName in case problem?
520 GoldName := RegReadStr(CPRS_REG_GOLD);
521 if Length(GoldName) = 0 then Exit;
522 if GoldName[Length(GoldName)] <> '\' then GoldName := GoldName + '\';
523 GoldName := GoldName + ReverseStr(Piece(ReverseStr(AppName), '\', 1));
524 CopyFileWithDate(GoldName, AppName);
525end;
526*)
527
528function BorlandDLLVersionOK: boolean;
529const
530 DLL_CURRENT_VERSION = 10;
531 TC_DLL_ERR = 'ERROR - BORLNDMM.DLL';
532 TX_NO_RUN = 'This version of CPRS is unable to run because' + CRLF;
533 TX_NO_DLL = 'no copy of BORLNDMM.DLL can be found' + CRLF +
534 'in your workstation''s current PATH.';
535 TX_OLD_DLL1 = 'the copy of BORLNDMM.DLL located at:' + CRLF + CRLF;
536 TX_OLD_DLL2 = CRLF + CRLF + 'is out of date (Version ';
537 TX_CALL_IRM = CRLF + CRLF +'Please contact IRM for assistance.';
538var
539 DLLHandle: HMODULE;
540 DLLNamePath: array[0..261] of Char;
541 DLLVersion: string;
542begin
543 Result := TRUE;
544 DLLHandle := GetModuleHandle('BORLNDMM.DLL');
545 if DLLHandle <=0 then
546 begin
547 InfoBox(TX_NO_RUN + TX_NO_DLL + TX_CALL_IRM, TC_DLL_ERR, MB_ICONERROR or MB_OK);
548 Result := FALSE;
549 Exit;
550 end;
551 Windows.GetModuleFileName(DLLHandle, DLLNamePath, 261);
552 DLLVersion := ClientVersion(DLLNamePath);
553 if StrToIntDef(Piece(DLLVersion, '.', 1), 0) < DLL_CURRENT_VERSION then
554 begin
555 InfoBox(TX_NO_RUN + TX_OLD_DLL1 + ' ' + DLLNamePath + TX_OLD_DLL2 + DLLVersion + ')' +
556 TX_CALL_IRM, TC_DLL_ERR, MB_ICONERROR or MB_OK);
557 Result := false;
558 end;
559end;
560
561end.
Note: See TracBrowser for help on using the repository browser.