source: cprs/branches/tmg-cprs/CPRS-Lib/ORSystem.~pas@ 498

Last change on this file since 498 was 453, checked in by Kevin Toppenberg, 16 years ago

Initial upload of TMG-CPRS 1.0.26.69

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