Commit 77daeb56 authored by Marco Van de Voort's avatar Marco Van de Voort
Browse files

--- Merging r22549 into '.':

U    rtl/objpas/classes/stringl.inc
A    tests/webtbs/tw19610.pp
--- Merging r22650 into '.':
A    packages/fcl-registry/tests/tregistry2.pp
U    packages/fcl-registry/tests/testbasics.pp
--- Merging r22651 into '.':
U    packages/fcl-registry/src/registry.pp
--- Merging r22585 into '.':
U    rtl/objpas/classes/lists.inc
--- Merging r22593 into '.':
G    rtl/objpas/classes/lists.inc
--- Merging r22652 into '.':
U    packages/fcl-registry/src/winreg.inc
--- Merging r23239 into '.':
U    rtl/os2/sysutils.pp

# revisions: 22549,22650,22651,22585,22593,22652,23239
r22549 | marco | 2012-10-05 18:56:09 +0200 (Fri, 05 Oct 2012) | 2 lines
Changed paths:
   M /trunk/rtl/objpas/classes/stringl.inc
   A /trunk/tests/webtbs/tw19610.pp

 * fix for Delphi incompatible DelimitedText, Mantis #19610, big patch from Reinier Olislagers.
r22650 | yury | 2012-10-15 13:08:21 +0200 (Mon, 15 Oct 2012) | 1 line
Changed paths:
   M /trunk/packages/fcl-registry/tests/testbasics.pp
   A /trunk/packages/fcl-registry/tests/tregistry2.pp

+ Added tests for TRegistry bugs.
r22651 | yury | 2012-10-15 13:09:16 +0200 (Mon, 15 Oct 2012) | 1 line
Changed paths:
   M /trunk/packages/fcl-registry/src/registry.pp

* Removed unused vars.
r22585 | michael | 2012-10-08 13:01:39 +0200 (Mon, 08 Oct 2012) | 1 line
Changed paths:
   M /trunk/rtl/objpas/classes/lists.inc

* Patch from Luiz Americo to clean up tlist (bug ID 23024)
r22593 | michael | 2012-10-08 17:11:10 +0200 (Mon, 08 Oct 2012) | 1 line
Changed paths:
   M /trunk/rtl/objpas/classes/lists.inc

* Take care of Florian's remark that FList may be nil when constructor failed
r22652 | yury | 2012-10-15 13:11:43 +0200 (Mon, 15 Oct 2012) | 2 lines
Changed paths:
   M /trunk/packages/fcl-registry/src/winreg.inc

* Implemented CurrentPath property.
* Fixed handle leak when calling OpenKey() for already opened registry.
r23239 | hajny | 2012-12-28 13:53:55 +0100 (Fri, 28 Dec 2012) | 1 line
Changed paths:
   M /trunk/rtl/os2/sysutils.pp

  * GetTickCount(64) implementation for OS/2 added

git-svn-id: branches/fixes_2_6@23652 -
parent 476b0076
......@@ -2278,6 +2278,7 @@ packages/fcl-registry/tests/Makefile svneol=native#text/plain
packages/fcl-registry/tests/Makefile.fpc -text
packages/fcl-registry/tests/regtestframework.pp -text
packages/fcl-registry/tests/testbasics.pp svneol=native#text/plain
packages/fcl-registry/tests/tregistry2.pp svneol=native#text/plain
packages/fcl-res/Makefile svneol=native#text/plain
packages/fcl-res/Makefile.fpc svneol=native#text/plain
packages/fcl-res/fpmake.pp svneol=native#text/plain
......@@ -11894,6 +11895,7 @@ tests/webtbs/tw1938.pp svneol=native#text/plain
tests/webtbs/tw1948.pp svneol=native#text/plain
tests/webtbs/tw1950.pp svneol=native#text/plain
tests/webtbs/tw19548.pp svneol=native#text/pascal
tests/webtbs/tw19610.pp svneol=native#text/plain
tests/webtbs/tw1964.pp svneol=native#text/plain
tests/webtbs/tw19700.pp svneol=native#text/plain
tests/webtbs/tw19864.pp svneol=native#text/pascal
......
......@@ -45,7 +45,9 @@ TRegDataInfo = record
TRegistry = class(TObject)
private
FStringSizeIncludesNull : Boolean;
{$ifdef XMLREG}
FSysData : Pointer;
{$endif XMLREG}
fAccess: LongWord;
fCurrentKey: HKEY;
fRootKey: HKEY;
......@@ -336,9 +338,6 @@ function TRegistry.ReadBool(const Name: string): Boolean;
function TRegistry.ReadCurrency(const Name: string): Currency;
Var
RegDataType: TRegDataType;
begin
ReadBinaryData(Name, Result, SizeOf(Currency));
end;
......@@ -351,8 +350,6 @@ function TRegistry.ReadDate(const Name: string): TDateTime;
end;
function TRegistry.ReadDateTime(const Name: string): TDateTime;
Var
RegDataType: TRegDataType;
begin
ReadBinaryData(Name, Result, SizeOf(TDateTime));
......
......@@ -177,7 +177,7 @@ function TRegistry.OpenKey(const Key: string; CanCreate: Boolean): Boolean;
Handle: HKEY;
Disposition: Integer;
SecurityAttributes: Pointer; //LPSECURITY_ATTRIBUTES;
S: string;
begin
SecurityAttributes := Nil;
P:=PrepKey(Key);
......@@ -194,21 +194,27 @@ function TRegistry.OpenKey(const Key: string; CanCreate: Boolean): Boolean;
else
Result:=RegOpenKeyExA(GetBaseKey(RelativeKey(Key)),
P,0,fAccess,Handle)=ERROR_SUCCESS;
If Result then
fCurrentKey:=Handle;
If Result then begin
if RelativeKey(Key) then
S:=CurrentPath + Key
else
S:=P;
ChangeKey(Handle, S);
end;
end;
function TRegistry.OpenKeyReadOnly(const Key: string): Boolean;
Var
P: PChar;
Handle: HKEY;
OldAccess: LongWord;
begin
P:=PrepKey(Key);
Result := RegOpenKeyExA(GetBaseKey(RelativeKey(Key)),P,0,KEY_READ,Handle) = 0;
If Result Then
fCurrentKey := Handle;
OldAccess:=fAccess;
fAccess:=KEY_READ;
try
Result:=OpenKey(Key, False);
finally
fAccess:=OldAccess;
end;
end;
function TRegistry.RegistryConnect(const UNCName: string): Boolean;
......
......@@ -22,12 +22,17 @@ TTestBasics = class(TTestCase)
procedure TestSimpleWinRegistry;
procedure TestDoubleWrite;
procedure bug16395;
procedure TestAdv;
end;
implementation
uses
registry;
registry
{$ifdef windows}
, tregistry2
{$endif windows}
;
{ TTestBasics }
......@@ -140,6 +145,13 @@ procedure TTestBasics.bug16395;
DeleteUserXmlFile;
end;
procedure TTestBasics.TestAdv;
begin
{$ifdef windows}
DoRegTest2;
{$endif windows}
end;
initialization
RegisterTest(TTestBasics);
end.
{$ifdef FPC} {$mode delphi} {$endif}
unit tregistry2;
interface
procedure DoRegTest2;
implementation
uses Windows, SysUtils, registry;
const
STestRegPath = 'Software\FPC-RegTest';
procedure TestFailed(ErrCode: integer);
begin
raise Exception.Create('Test FAILED. Error code: ' + IntToStr(ErrCode));
end;
procedure DoRegTest2;
var
reg: TRegistry;
k: HKEY;
begin
reg:=TRegistry.Create;
try
if not reg.OpenKey(STestRegPath, True) then
TestFailed(1);
if reg.CurrentPath <> STestRegPath then
TestFailed(2);
k:=reg.CurrentKey;
if not reg.OpenKey('\' + STestRegPath + '\1', True) then
TestFailed(3);
if RegCloseKey(k) = 0 then
TestFailed(4);
if reg.CurrentPath <> STestRegPath + '\1' then
TestFailed(5);
finally
reg.Free;
end;
end;
end.
......@@ -646,7 +646,7 @@ constructor TList.Create;
destructor TList.Destroy;
begin
If (Flist<>Nil) then
if Assigned(Flist) then
Clear;
If Assigned(FObservers) then
begin
......@@ -726,9 +726,8 @@ function TList.Add(Item: Pointer): Integer;
procedure TList.Clear;
begin
If Assigned(Flist) then
While (FList.Count>0) do
Delete(Count-1);
While (FList.Count>0) do
Delete(Count-1);
end;
procedure TList.Delete(Index: Integer);
......
......@@ -140,30 +140,33 @@ function TStrings.GetCommaText: string;
Var
I : integer;
p : pchar;
c : set of char;
BreakChars : set of char;
S : String;
begin
CheckSpecialChars;
result:='';
if StrictDelimiter then
c:=[#0,Delimiter]
BreakChars:=[#0,QuoteChar,Delimiter]
else
c:=[#0..' ',QuoteChar,Delimiter];
BreakChars:=[#0..' ',QuoteChar,Delimiter];
// Check for break characters and quote if required.
For i:=0 to count-1 do
begin
S:=Strings[i];
p:=pchar(S);
while not(p^ in c) do
//Quote strings that include BreakChars:
while not(p^ in BreakChars) do
inc(p);
// strings in list may contain #0
if (p<>pchar(S)+length(S)) and not StrictDelimiter then
if (p<>pchar(S)+length(S)) then
Result:=Result+QuoteString(S,QuoteChar)
else
Result:=Result+S;
if I<Count-1 then
Result:=Result+Delimiter;
end;
// Quote empty string:
If (Length(Result)=0) and (Count=1) then
Result:=QuoteChar+QuoteChar;
end;
......@@ -268,22 +271,48 @@ procedure TStrings.ReadData(Reader: TReader);
j:=1;
aNotFirst:=false;
{ Paraphrased from Delphi XE2 help:
Strings must be separated by Delimiter characters or spaces.
They may be enclosed in QuoteChars.
QuoteChars in the string must be repeated to distinguish them from the QuoteChars enclosing the string.
}
try
Clear;
If StrictDelimiter then
begin
// Easier, faster loop.
While I<=Length(AValue) do
begin
If (AValue[I] in [FDelimiter,#0]) then
begin
Add(Copy(AValue,J,I-J));
J:=I+1;
end;
Inc(i);
while i<=length(AValue) do begin
// skip delimiter
if aNotFirst and (i<=length(AValue)) and (AValue[i]=FDelimiter) then inc(i);
// read next string
if i<=length(AValue) then begin
if AValue[i]=FQuoteChar then begin
// next string is quoted
j:=i+1;
while (j<=length(AValue)) and
( (AValue[j]<>FQuoteChar) or
( (j+1<=length(AValue)) and (AValue[j+1]=FQuoteChar) ) ) do begin
if (j<=length(AValue)) and (AValue[j]=FQuoteChar) then inc(j,2)
else inc(j);
end;
// j is position of closing quote
Add( StringReplace (Copy(AValue,i+1,j-i-1),
FQuoteChar+FQuoteChar,FQuoteChar, [rfReplaceAll]));
i:=j+1;
end else begin
// next string is not quoted; read until delimiter
j:=i;
while (j<=length(AValue)) and
(AValue[j]<>FDelimiter) do inc(j);
Add( Copy(AValue,i,j-i));
i:=j;
end;
If (Length(AValue)>0) then
Add(Copy(AValue,J,I-J));
end else begin
if aNotFirst then Add('');
end;
aNotFirst:=true;
end;
end
else
begin
......@@ -310,7 +339,7 @@ procedure TStrings.ReadData(Reader: TReader);
FQuoteChar+FQuoteChar,FQuoteChar, [rfReplaceAll]));
i:=j+1;
end else begin
// next string is not quoted
// next string is not quoted; read until control character/space/delimiter
j:=i;
while (j<=length(AValue)) and
(Ord(AValue[j])>Ord(' ')) and
......
......@@ -40,6 +40,8 @@ implementation
{$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
{$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
{$DEFINE FPC_FEXPAND_GETENV_PCHAR}
{$DEFINE HAS_GETTICKCOUNT}
{$DEFINE HAS_GETTICKCOUNT64}
{ Include platform independent implementation part }
{$i sysutils.inc}
......@@ -647,6 +649,13 @@ procedure Sleep (Milliseconds: cardinal);
DosSleep (Milliseconds);
end;
function SysTimerTick: QWord;
var
L: cardinal;
begin
DosQuerySysInfo (svMsCount, svMsCount, L, 4);
SysTimerTick := L;
end;
function ExecuteProcess (const Path: AnsiString; const ComLine: AnsiString;Flags:TExecuteFlags=[]):
integer;
......@@ -809,6 +818,24 @@ function ExecuteProcess (const Path: AnsiString;
end;
function GetTickCount: LongWord;
var
L: cardinal;
begin
DosQuerySysInfo (svMsCount, svMsCount, L, 4);
GetTickCount := L;
end;
function GetTickCount64: QWord;
var
L: cardinal;
begin
DosQuerySysInfo (svMsCount, svMsCount, L, 4);
GetTickCount64 := L;
end;
{****************************************************************************
Initialization code
......
This diff is collapsed.
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment