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

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

Initial Upload of Official WV CPRS 1.0.26.76

File size: 16.7 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;
129begin
130 Result := '';
131 ASize:=GetFileVersionInfoSize(PChar(AFileName), AHandle);
132 if ASize > 0 then
133 begin
134 SetLength(Buf, ASize);
135 GetFileVersionInfo(PChar(AFileName), AHandle, ASize, Pointer(Buf));
136 VerQueryValue(Pointer(Buf), '\', FileInfoPtr, ASize);
137 with TVSFixedFileInfo(FileInfoPtr^) do Result := IntToStr(HIWORD(dwFileVersionMS)) + '.' +
138 IntToStr(LOWORD(dwFileVersionMS)) + '.' +
139 IntToStr(HIWORD(dwFileVersionLS)) + '.' +
140 IntToStr(LOWORD(dwFileVersionLS));
141 end;
142end;
143
144function FileVersionValue(const AFileName, AValueName: string): string;
145type
146 PValBuf = ^TValBuf;
147 TValBuf = array[0..255] of Char;
148var
149 VerSize, ValSize, AHandle: DWORD;
150 VerBuf: Pointer;
151 ValBuf: PValBuf;
152begin
153 Result := '';
154 VerSize:=GetFileVersionInfoSize(PChar(AFileName), AHandle);
155 if VerSize > 0 then
156 begin
157 GetMem(VerBuf, VerSize);
158 try
159 GetFileVersionInfo(PChar(AFileName), AHandle, VerSize, VerBuf);
160 VerQueryValue(VerBuf, PChar(AValueName), Pointer(ValBuf), ValSize);
161 SetString(Result, ValBuf^, ValSize);
162 finally
163 FreeMem(VerBuf);
164 end;
165 end;
166end;
167
168function CompareVersion(const A, B: string): Integer;
169var
170 NumA, NumB: Integer;
171begin
172 NumA := (StrToInt(Piece(A, '.', 1)) * 16777216) +
173 (StrToInt(Piece(A, '.', 2)) * 65536) +
174 (StrToInt(Piece(A, '.', 3)) * 256) +
175 StrToInt(Piece(A, '.', 4));
176 NumB := (StrToInt(Piece(B, '.', 1)) * 16777216) +
177 (StrToInt(Piece(B, '.', 2)) * 65536) +
178 (StrToInt(Piece(B, '.', 3)) * 256) +
179 StrToInt(Piece(B, '.', 4));
180 Result := NumA - NumB;
181end;
182
183procedure CopyFileDate(const Source, Dest: string);
184{ from TI2972 }
185var
186 SourceHand, DestHand: Integer;
187begin
188 SourceHand := FileOpen(Source, fmOutput); { open source file }
189 DestHand := FileOpen(Dest, fmInput); { open dest file }
190 FileSetDate(DestHand, FileGetDate(SourceHand)); { get/set date }
191 FileClose(SourceHand); { close source file }
192 FileClose(DestHand); { close dest file }
193end;
194
195procedure CopyLastWriteTime(const Source, Dest: string);
196var
197 HandleSrc, HandleDest: Integer;
198 LastWriteTime: TFileTime;
199begin
200 HandleSrc := FileOpen(Source, fmOpenRead or fmShareDenyNone);
201 HandleDest := FileOpen(Dest, fmOpenWrite);
202 if (HandleSrc > 0) and (HandleDest > 0) then
203 begin
204 if GetFileTime(THandle(HandleSrc), nil, nil, @LastWriteTime) = TRUE
205 then SetFileTime(THandle(HandleDest), nil, nil, @LastWriteTime);
206 FileClose(HandleSrc);
207 FileClose(HandleDest);
208 end;
209end;
210
211procedure Delay(i: Integer);
212const
213 AMilliSecond = 0.000000011574;
214var
215 Start: TDateTime;
216begin
217 Start := Now;
218 while Now < (Start + (i * AMilliSecond)) do Application.ProcessMessages;
219end;
220
221procedure FileCopy(const FromFileName, ToFileName: string);
222var
223 FromFile, ToFile: file;
224 NumRead, NumWritten: Integer;
225 Buf: array[1..16384] of Char;
226begin
227 AssignFile(FromFile, FromFileName); // Input file
228 Reset(FromFile, 1); // Record size = 1
229 AssignFile(ToFile, ToFileName); // Output file
230 Rewrite(ToFile, 1); // Record size = 1
231 repeat
232 BlockRead(FromFile, Buf, SizeOf(Buf), NumRead);
233 BlockWrite(ToFile, Buf, NumRead, NumWritten);
234 until (NumRead = 0) or (NumWritten <> NumRead);
235 CloseFile(FromFile);
236 CloseFile(ToFile);
237end;
238
239procedure FileCopyWithDate(const FromFileName, ToFileName: string);
240var
241 FileHandle, ADate: Integer;
242begin
243 FileCopy(FromFileName, ToFileName);
244 FileHandle := FileOpen(FromFileName, fmOpenRead or fmShareDenyNone);
245 ADate := FileGetDate(FileHandle);
246 FileClose(FileHandle);
247 if ADate < 0 then Exit;
248 FileHandle := FileOpen(ToFileName, fmOpenWrite or fmShareDenyNone);
249 if FileHandle > 0 then FileSetDate(FileHandle, ADate);
250 FileClose(FileHandle);
251end;
252
253procedure CopyFileWithDate(const FromFileName, ToFileName: string);
254var
255 FileHandle, ADate: Integer;
256begin
257 if CopyFile(PChar(FromFileName), PChar(ToFileName), False) then
258 begin
259 FileHandle := FileOpen(FromFileName, fmOpenRead or fmShareDenyNone);
260 ADate := FileGetDate(FileHandle);
261 FileClose(FileHandle);
262 if ADate < 0 then Exit;
263 FileHandle := FileOpen(ToFileName, fmOpenWrite or fmShareDenyNone);
264 if FileHandle > 0 then FileSetDate(FileHandle, ADate);
265 FileClose(FileHandle);
266 end;
267end;
268
269function FullToFilePart(const AFileName: string): string;
270var
271 DirBuf: string;
272 FilePart: PChar;
273 NameLen: DWORD;
274begin
275 Result := '';
276 SetString(DirBuf, nil, 255);
277 NameLen := GetFullPathName(PChar(AFileName), 255, PChar(DirBuf), FilePart);
278 if NameLen > 0 then Result := FilePart;
279end;
280
281function FullToPathPart(const AFileName: string): string;
282var
283 DirBuf: string;
284 FilePart: PChar;
285 NameLen: Cardinal;
286begin
287 Result := '';
288 SetString(DirBuf, nil, 255);
289 NameLen := GetFullPathName(PChar(AFileName), 255, PChar(DirBuf), FilePart);
290 if NameLen > 0 then Result := Copy(DirBuf, 1, NameLen - StrLen(FilePart));
291end;
292
293function IsWin95Style: Boolean;
294begin
295 Result := Lo(GetVersion) >= 4; // True = Win95 interface, otherwise old interface
296end;
297
298function ParamIndex(const AName: string): Integer;
299var
300 i: Integer;
301 x: string;
302begin
303 Result := 0;
304 for i := 1 to ParamCount do
305 begin
306 x := UpperCase(ParamStr(i));
307 x := Piece(x, '=', 1);
308 if x = Uppercase(AName) then
309 begin
310 Result := i;
311 Break;
312 end;
313 end; {for i}
314end;
315
316function ParamSearch(const AName: string): string;
317var
318 i: Integer;
319 x: string;
320begin
321 Result := '';
322 for i := 1 to ParamCount do
323 begin
324 x := UpperCase(ParamStr(i));
325 x := Copy(x, 1, Pos('=', x) - 1);
326 if x = Uppercase(AName) then
327 begin
328 Result := UpperCase(Copy(ParamStr(i), Length(x) + 2, Length(ParamStr(i))));
329 Break;
330 end;
331 end; {for i}
332end;
333
334function QuotedExeName: string;
335var
336 i: Integer;
337begin
338 Result := '"' + ParamStr(0) + '"';
339 for i := 1 to ParamCount do Result := Result + ' ' + ParamStr(i);
340end;
341
342function RegReadInt(const AName: string): Integer;
343var
344 Registry: TRegistry;
345begin
346 Result := 0;
347 Registry := TRegistry.Create;
348 try
349 Registry.RootKey := CPRS_ROOT_KEY;
350 if Registry.OpenKeyReadOnly(CPRS_SOFTWARE) and Registry.ValueExists(AName)
351 then Result := Registry.ReadInteger(AName);
352 Registry.CloseKey;
353 finally
354 Registry.Free;
355 end;
356end;
357
358function RegReadStr(const AName: string): string;
359var
360 Registry: TRegistry;
361begin
362 Result := '';
363 Registry := TRegistry.Create;
364 try
365 Registry.RootKey := CPRS_ROOT_KEY;
366 if Registry.OpenKeyReadOnly(CPRS_SOFTWARE) and Registry.ValueExists(AName)
367 then Result := Registry.ReadString(AName);
368 Registry.CloseKey;
369 finally
370 Registry.Free;
371 end;
372end;
373
374function RegReadBool(const AName: string): Boolean;
375var
376 Registry: TRegistry;
377begin
378 Result := False;
379 Registry := TRegistry.Create;
380 try
381 Registry.RootKey := CPRS_ROOT_KEY;
382 if Registry.OpenKeyReadOnly(CPRS_SOFTWARE) and Registry.ValueExists(AName)
383 then Result := Registry.ReadBool(AName);
384 Registry.CloseKey;
385 finally
386 Registry.Free;
387 end;
388end;
389
390procedure RegWriteInt(const AName: string; AValue: Integer);
391var
392 Registry: TRegistry;
393begin
394 Registry := TRegistry.Create;
395 try
396 Registry.RootKey := CPRS_ROOT_KEY;
397 if Registry.OpenKey(CPRS_SOFTWARE, CREATE_KEY) then Registry.WriteInteger(AName, AValue);
398 Registry.CloseKey;
399 finally
400 Registry.Free;
401 end;
402end;
403
404procedure RegWriteStr(const AName, AValue: string);
405var
406 Registry: TRegistry;
407begin
408 Registry := TRegistry.Create;
409 try
410 Registry.RootKey := CPRS_ROOT_KEY;
411 if Registry.OpenKey(CPRS_SOFTWARE, CREATE_KEY) then Registry.WriteString(AName, AValue);
412 Registry.CloseKey;
413 finally
414 Registry.Free;
415 end;
416end;
417
418procedure RegWriteBool(const AName: string; AValue: Boolean);
419var
420 Registry: TRegistry;
421begin
422 Registry := TRegistry.Create;
423 try
424 Registry.RootKey := CPRS_ROOT_KEY;
425 if Registry.OpenKey(CPRS_SOFTWARE, CREATE_KEY) then Registry.WriteBool(AName, AValue);
426 Registry.CloseKey;
427 finally
428 Registry.Free;
429 end;
430end;
431
432function RegKeyExists(ARoot: HKEY; const AKey: string): Boolean;
433var
434 Registry: TRegistry;
435begin
436 Result := False;
437 Registry := TRegistry.Create;
438 try
439 Registry.RootKey := ARoot;
440 //Result := Registry.KeyExists(AKey); {this tries to open key with full access}
441 if Registry.OpenKeyReadOnly(AKey) and (Registry.CurrentKey <> 0) then Result := True;
442 Registry.CloseKey;
443 finally
444 Registry.Free;
445 end;
446end;
447
448function UserRegReadDateTime(const AKey, AName: string): TDateTime;
449var
450 Registry: TRegistry;
451begin
452 Result := 0;
453 Registry := TRegistry.Create;
454 try
455 Registry.RootKey := CPRS_USER_KEY;
456 if Registry.OpenKey(AKey, CREATE_KEY) and Registry.ValueExists(AName) then
457 try
458 Result := Registry.ReadDateTime(AName);
459 except
460 on ERegistryException do Result := 0;
461 end;
462 Registry.CloseKey;
463 finally
464 Registry.Free;
465 end;
466end;
467
468procedure UserRegWriteDateTime(const AKey, AName: string; AValue: TDateTime);
469var
470 Registry: TRegistry;
471begin
472 Registry := TRegistry.Create;
473 try
474 Registry.RootKey := CPRS_USER_KEY;
475 if Registry.OpenKey(AKey, CREATE_KEY) then Registry.WriteDateTime(AName, AValue);
476 Registry.CloseKey;
477 finally
478 Registry.Free;
479 end;
480end;
481
482function UserRegReadInt(const AKey, AName: string): Integer;
483var
484 Registry: TRegistry;
485begin
486 Result := 0;
487 Registry := TRegistry.Create;
488 try
489 Registry.RootKey := CPRS_USER_KEY;
490 if Registry.OpenKey(AKey, CREATE_KEY) and Registry.ValueExists(AName)
491 then Result := Registry.ReadInteger(AName);
492 Registry.CloseKey;
493 finally
494 Registry.Free;
495 end;
496end;
497
498procedure UserRegWriteInt(const AKey, AName: string; AValue: Integer);
499var
500 Registry: TRegistry;
501begin
502 Registry := TRegistry.Create;
503 try
504 Registry.RootKey := CPRS_USER_KEY;
505 if Registry.OpenKey(AKey, CREATE_KEY) then Registry.WriteInteger(AName, AValue);
506 Registry.CloseKey;
507 finally
508 Registry.Free;
509 end;
510end;
511
512procedure RunProgram(const AppName: string);
513var
514 StartInfo: TStartupInfo;
515 ProcInfo: TProcessInformation;
516begin
517 FillChar(StartInfo, SizeOf(StartInfo), 0);
518 StartInfo.CB := SizeOf(StartInfo);
519 CreateProcess(nil, PChar(AppName), nil, nil, False, DETACHED_PROCESS or NORMAL_PRIORITY_CLASS,
520 nil, nil, StartInfo, ProcInfo);
521end;
522
523function UpdateSelf: Boolean;
524var
525 CPRSUpdate: string;
526begin
527 // auto-update if newer version available
528 Result := False;
529 CPRSUpdate := RegReadStr(CPRS_REG_GOLD) + 'CPRSUpdate.exe';
530 if not FileExists(CPRSUpdate) then CPRSUpdate := 'CPRSUpdate.exe';
531 if AppOutOfDate(Application.ExeName) and FileExists(CPRSUpdate) then
532 begin
533 Result := True;
534 RunProgram(CPRSUpdate + ' COPY=' + QuotedExeName);
535 end;
536end;
537
538(*
539procedure UpdateAppFromGold(const AppName: string);
540var
541 GoldName: string;
542begin
543 Delay(1500);
544 // do a rename of AppName in case problem?
545 GoldName := RegReadStr(CPRS_REG_GOLD);
546 if Length(GoldName) = 0 then Exit;
547 if GoldName[Length(GoldName)] <> '\' then GoldName := GoldName + '\';
548 GoldName := GoldName + ReverseStr(Piece(ReverseStr(AppName), '\', 1));
549 CopyFileWithDate(GoldName, AppName);
550end;
551*)
552
553end.
Note: See TracBrowser for help on using the repository browser.