Browse Source

--- Merging r30140 into '.':
U rtl/objpas/sysutils/sysutils.inc
U rtl/objpas/sysutils/sysutilh.inc
--- Recording mergeinfo for merge of r30140 into '.':
U .
--- Merging r30153 into '.':
U rtl/objpas/classes/classes.inc
--- Recording mergeinfo for merge of r30153 into '.':
G .
--- Merging r30159 into '.':
G rtl/objpas/classes/classes.inc
--- Recording mergeinfo for merge of r30159 into '.':
G .
--- Merging r30551 into '.':
G rtl/objpas/sysutils/sysutilh.inc
U rtl/inc/system.inc
U rtl/inc/systemh.inc
--- Recording mergeinfo for merge of r30551 into '.':
G .
--- Merging r30555 into '.':
G rtl/objpas/sysutils/sysutils.inc
G rtl/inc/systemh.inc
G rtl/inc/system.inc
--- Recording mergeinfo for merge of r30555 into '.':
G .
--- Merging r31185 into '.':
U rtl/objpas/sysutils/dati.inc
U rtl/objpas/sysutils/datih.inc
--- Recording mergeinfo for merge of r31185 into '.':
G .
--- Merging r31265 into '.':
U packages/fcl-json/src/jsonconf.pp
--- Recording mergeinfo for merge of r31265 into '.':
G .
--- Merging r31272 into '.':
G packages/fcl-json/src/jsonconf.pp
--- Recording mergeinfo for merge of r31272 into '.':
G .
--- Merging r31273 into '.':
G packages/fcl-json/src/jsonconf.pp
--- Recording mergeinfo for merge of r31273 into '.':
G .
--- Merging r31277 into '.':
G packages/fcl-json/src/jsonconf.pp
--- Recording mergeinfo for merge of r31277 into '.':
G .

# revisions: 30140,30153,30159,30551,30555,31185,31265,31272,31273,31277

git-svn-id: branches/fixes_3_0@31280 -

marco 10 years ago
parent
commit
3de9be5837

+ 86 - 68
packages/fcl-json/src/jsonconf.pp

@@ -57,52 +57,58 @@ type
   TJSONConfig = class(TComponent)
   TJSONConfig = class(TComponent)
   private
   private
     FFilename: String;
     FFilename: String;
+    FFormatIndentSize: Integer;
+    FFormatoptions: TFormatOptions;
+    FFormatted: Boolean;
     FKey: TJSONObject;
     FKey: TJSONObject;
     procedure DoSetFilename(const AFilename: String; ForceReload: Boolean);
     procedure DoSetFilename(const AFilename: String; ForceReload: Boolean);
     procedure SetFilename(const AFilename: String);
     procedure SetFilename(const AFilename: String);
-    Function StripSlash(P : WideString) : WideString;
+    Function StripSlash(Const P : UnicodeString) : UnicodeString;
   protected
   protected
     FJSON: TJSONObject;
     FJSON: TJSONObject;
     FModified: Boolean;
     FModified: Boolean;
     procedure Loaded; override;
     procedure Loaded; override;
-    function FindPath(Const APath: WideString; AllowCreate : Boolean) : TJSONObject;
-    function FindObject(Const APath: WideString; AllowCreate : Boolean) : TJSONObject;
-    function FindObject(Const APath: WideString; AllowCreate : Boolean;Var ElName : WideString) : TJSONObject;
-    function FindElement(Const APath: WideString; CreateParent : Boolean) : TJSONData;
-    function FindElement(Const APath: WideString; CreateParent : Boolean; Var AParent : TJSONObject; Var ElName : WideString) : TJSONData;
+    function FindPath(Const APath: UnicodeString; AllowCreate : Boolean) : TJSONObject;
+    function FindObject(Const APath: UnicodeString; AllowCreate : Boolean) : TJSONObject;
+    function FindObject(Const APath: UnicodeString; AllowCreate : Boolean;Var ElName : UnicodeString) : TJSONObject;
+    function FindElement(Const APath: UnicodeString; CreateParent : Boolean) : TJSONData;
+    function FindElement(Const APath: UnicodeString; CreateParent : Boolean; Var AParent : TJSONObject; Var ElName : UnicodeString) : TJSONData;
   public
   public
     constructor Create(AOwner: TComponent); override;
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
     destructor Destroy; override;
     Procedure Reload;
     Procedure Reload;
     procedure Clear;
     procedure Clear;
     procedure Flush;    // Writes the JSON file
     procedure Flush;    // Writes the JSON file
-    procedure OpenKey(const aPath: WideString; AllowCreate : Boolean);
+    procedure OpenKey(const aPath: UnicodeString; AllowCreate : Boolean);
     procedure CloseKey;
     procedure CloseKey;
     procedure ResetKey;
     procedure ResetKey;
-    Procedure EnumSubKeys(Const APath : String; List : TStrings);
-    Procedure EnumValues(Const APath : String; List : TStrings);
-
-    function  GetValue(const APath: WideString; const ADefault: WideString): WideString; overload;
-    function  GetValue(const APath: WideString; ADefault: Integer): Integer; overload;
-    function  GetValue(const APath: WideString; ADefault: Int64): Int64; overload;
-    function  GetValue(const APath: WideString; ADefault: Boolean): Boolean; overload;
-    function  GetValue(const APath: WideString; ADefault: Double): Double; overload;
-    procedure SetValue(const APath: WideString; const AValue: WideString); overload;
-    procedure SetValue(const APath: WideString; AValue: Integer); overload;
-    procedure SetValue(const APath: WideString; AValue: Int64); overload;
-    procedure SetValue(const APath: WideString; AValue: Boolean); overload;
-    procedure SetValue(const APath: WideString; AValue: Double); overload;
-
-    procedure SetDeleteValue(const APath: WideString; const AValue, DefValue: WideString); overload;
-    procedure SetDeleteValue(const APath: WideString; AValue, DefValue: Integer); overload;
-    procedure SetDeleteValue(const APath: WideString; AValue, DefValue: Int64); overload;
-    procedure SetDeleteValue(const APath: WideString; AValue, DefValue: Boolean); overload;
-
-    procedure DeletePath(const APath: WideString);
-    procedure DeleteValue(const APath: WideString);
+    Procedure EnumSubKeys(Const APath : UnicodeString; List : TStrings);
+    Procedure EnumValues(Const APath : UnicodeString; List : TStrings);
+
+    function  GetValue(const APath: UnicodeString; const ADefault: UnicodeString): UnicodeString; overload;
+    function  GetValue(const APath: UnicodeString; ADefault: Integer): Integer; overload;
+    function  GetValue(const APath: UnicodeString; ADefault: Int64): Int64; overload;
+    function  GetValue(const APath: UnicodeString; ADefault: Boolean): Boolean; overload;
+    function  GetValue(const APath: UnicodeString; ADefault: Double): Double; overload;
+    procedure SetValue(const APath: UnicodeString; const AValue: UnicodeString); overload;
+    procedure SetValue(const APath: UnicodeString; AValue: Integer); overload;
+    procedure SetValue(const APath: UnicodeString; AValue: Int64); overload;
+    procedure SetValue(const APath: UnicodeString; AValue: Boolean); overload;
+    procedure SetValue(const APath: UnicodeString; AValue: Double); overload;
+
+    procedure SetDeleteValue(const APath: UnicodeString; const AValue, DefValue: UnicodeString); overload;
+    procedure SetDeleteValue(const APath: UnicodeString; AValue, DefValue: Integer); overload;
+    procedure SetDeleteValue(const APath: UnicodeString; AValue, DefValue: Int64); overload;
+    procedure SetDeleteValue(const APath: UnicodeString; AValue, DefValue: Boolean); overload;
+
+    procedure DeletePath(const APath: UnicodeString);
+    procedure DeleteValue(const APath: UnicodeString);
     property Modified: Boolean read FModified;
     property Modified: Boolean read FModified;
   published
   published
-    property Filename: String read FFilename write SetFilename;
+    Property Filename: String read FFilename write SetFilename;
+    Property Formatted : Boolean Read FFormatted Write FFormatted;
+    Property FormatOptions : TFormatOptions Read FFormatoptions Write FFormatOptions Default DefaultFormat;
+    Property FormatIndentsize : Integer Read FFormatIndentSize Write FFormatIndentSize Default DefaultIndentSize;
   end;
   end;
 
 
 
 
@@ -119,6 +125,8 @@ begin
   inherited Create(AOwner);
   inherited Create(AOwner);
   FJSON:=TJSONObject.Create;
   FJSON:=TJSONObject.Create;
   FKey:=FJSON;
   FKey:=FJSON;
+  FFormatOptions:=DefaultFormat;
+  FFormatIndentsize:=DefaultIndentSize;
 end;
 end;
 
 
 destructor TJSONConfig.Destroy;
 destructor TJSONConfig.Destroy;
@@ -141,14 +149,19 @@ procedure TJSONConfig.Flush;
 
 
 Var
 Var
   F : Text;
   F : Text;
-
+  S : TJSONStringType;
+  
 begin
 begin
   if Modified then
   if Modified then
     begin
     begin
     AssignFile(F,FileName);
     AssignFile(F,FileName);
     Rewrite(F);
     Rewrite(F);
     Try
     Try
-      Writeln(F,FJSON.AsJSON);
+      if Formatted then
+        S:=FJSON.FormatJSON(Formatoptions,FormatIndentSize)
+      else
+        S:=FJSON.AsJSON;
+      Writeln(F,S);  
     Finally
     Finally
       CloseFile(F);
       CloseFile(F);
     end;
     end;
@@ -157,19 +170,21 @@ begin
 end;
 end;
 
 
 
 
-function TJSONConfig.FindObject(Const APath: WideString; AllowCreate : Boolean) : TJSONObject;
+function TJSONConfig.FindObject(const APath: UnicodeString; AllowCreate: Boolean
+  ): TJSONObject;
 
 
 Var
 Var
-  Dummy : WideString;
+  Dummy : UnicodeString;
 
 
 begin
 begin
   Result:=FindObject(APath,AllowCreate,Dummy);
   Result:=FindObject(APath,AllowCreate,Dummy);
 end;
 end;
 
 
-function TJSONConfig.FindObject(Const APath: WideString; AllowCreate : Boolean;Var ElName : WideString) : TJSONObject;
+function TJSONConfig.FindObject(const APath: UnicodeString; AllowCreate: Boolean;
+  var ElName: UnicodeString): TJSONObject;
 
 
 Var
 Var
-  S,El : WideString;
+  S,El : UnicodeString;
   P,I : Integer;
   P,I : Integer;
   T : TJSonObject;
   T : TJSonObject;
   
   
@@ -232,17 +247,20 @@ begin
   ElName:=S;
   ElName:=S;
 end;
 end;
 
 
-function TJSONConfig.FindElement(Const APath: WideString; CreateParent : Boolean) : TJSONData;
+function TJSONConfig.FindElement(const APath: UnicodeString; CreateParent: Boolean
+  ): TJSONData;
 
 
 Var
 Var
   O : TJSONObject;
   O : TJSONObject;
-  ElName : WideString;
+  ElName : UnicodeString;
   
   
 begin
 begin
   Result:=FindElement(APath,CreateParent,O,ElName);
   Result:=FindElement(APath,CreateParent,O,ElName);
 end;
 end;
 
 
-function TJSONConfig.FindElement(Const APath: WideString; CreateParent : Boolean; Var AParent : TJSONObject; Var ElName : WideString) : TJSONData;
+function TJSONConfig.FindElement(const APath: UnicodeString;
+  CreateParent: Boolean; var AParent: TJSONObject; var ElName: UnicodeString
+  ): TJSONData;
 
 
 Var
 Var
   I : Integer;
   I : Integer;
@@ -261,7 +279,7 @@ begin
 end;
 end;
 
 
 
 
-function TJSONConfig.GetValue(const APath: WideString; const ADefault: WideString): WideString;
+function TJSONConfig.GetValue(const APath: UnicodeString; const ADefault: UnicodeString): UnicodeString;
 
 
 var
 var
   El : TJSONData;
   El : TJSONData;
@@ -274,7 +292,7 @@ begin
     Result:=ADefault;
     Result:=ADefault;
 end;
 end;
 
 
-function TJSONConfig.GetValue(const APath: WideString; ADefault: Integer): Integer;
+function TJSONConfig.GetValue(const APath: UnicodeString; ADefault: Integer): Integer;
 var
 var
   El : TJSONData;
   El : TJSONData;
   
   
@@ -288,7 +306,7 @@ begin
     Result:=StrToIntDef(El.AsString,ADefault);
     Result:=StrToIntDef(El.AsString,ADefault);
 end;
 end;
 
 
-function TJSONConfig.GetValue(const APath: WideString; ADefault: Int64): Int64;
+function TJSONConfig.GetValue(const APath: UnicodeString; ADefault: Int64): Int64;
 var
 var
   El : TJSONData;
   El : TJSONData;
 
 
@@ -302,7 +320,7 @@ begin
     Result:=StrToInt64Def(El.AsString,ADefault);
     Result:=StrToInt64Def(El.AsString,ADefault);
 end;
 end;
 
 
-function TJSONConfig.GetValue(const APath: WideString; ADefault: Boolean): Boolean;
+function TJSONConfig.GetValue(const APath: UnicodeString; ADefault: Boolean): Boolean;
 
 
 var
 var
   El : TJSONData;
   El : TJSONData;
@@ -317,7 +335,7 @@ begin
     Result:=StrToBoolDef(El.AsString,ADefault);
     Result:=StrToBoolDef(El.AsString,ADefault);
 end;
 end;
 
 
-function TJSONConfig.GetValue(const APath: WideString; ADefault: Double): Double;
+function TJSONConfig.GetValue(const APath: UnicodeString; ADefault: Double): Double;
 
 
 var
 var
   El : TJSONData;
   El : TJSONData;
@@ -333,11 +351,11 @@ begin
 end;
 end;
 
 
 
 
-procedure TJSONConfig.SetValue(const APath: WideString; const AValue: WideString);
+procedure TJSONConfig.SetValue(const APath: UnicodeString; const AValue: UnicodeString);
 
 
 var
 var
   El : TJSONData;
   El : TJSONData;
-  ElName : WideString;
+  ElName : UnicodeString;
   O : TJSONObject;
   O : TJSONObject;
   I : integer;
   I : integer;
   
   
@@ -359,7 +377,7 @@ begin
   FModified:=True;
   FModified:=True;
 end;
 end;
 
 
-procedure TJSONConfig.SetDeleteValue(const APath: WideString; const AValue, DefValue: WideString);
+procedure TJSONConfig.SetDeleteValue(const APath: UnicodeString; const AValue, DefValue: UnicodeString);
 begin
 begin
   if AValue = DefValue then
   if AValue = DefValue then
     DeleteValue(APath)
     DeleteValue(APath)
@@ -367,11 +385,11 @@ begin
     SetValue(APath, AValue);
     SetValue(APath, AValue);
 end;
 end;
 
 
-procedure TJSONConfig.SetValue(const APath: WideString; AValue: Integer);
+procedure TJSONConfig.SetValue(const APath: UnicodeString; AValue: Integer);
 
 
 var
 var
   El : TJSONData;
   El : TJSONData;
-  ElName : WideString;
+  ElName : UnicodeString;
   O : TJSONObject;
   O : TJSONObject;
   I : integer;
   I : integer;
 
 
@@ -394,11 +412,11 @@ begin
   FModified:=True;
   FModified:=True;
 end;
 end;
 
 
-procedure TJSONConfig.SetValue(const APath: WideString; AValue: Int64);
+procedure TJSONConfig.SetValue(const APath: UnicodeString; AValue: Int64);
 
 
 var
 var
   El : TJSONData;
   El : TJSONData;
-  ElName : WideString;
+  ElName : UnicodeString;
   O : TJSONObject;
   O : TJSONObject;
   I : integer;
   I : integer;
 
 
@@ -421,7 +439,7 @@ begin
   FModified:=True;
   FModified:=True;
 end;
 end;
 
 
-procedure TJSONConfig.SetDeleteValue(const APath: WideString; AValue,
+procedure TJSONConfig.SetDeleteValue(const APath: UnicodeString; AValue,
   DefValue: Integer);
   DefValue: Integer);
 begin
 begin
   if AValue = DefValue then
   if AValue = DefValue then
@@ -430,7 +448,7 @@ begin
     SetValue(APath, AValue);
     SetValue(APath, AValue);
 end;
 end;
 
 
-procedure TJSONConfig.SetDeleteValue(const APath: WideString; AValue,
+procedure TJSONConfig.SetDeleteValue(const APath: UnicodeString; AValue,
   DefValue: Int64);
   DefValue: Int64);
 begin
 begin
   if AValue = DefValue then
   if AValue = DefValue then
@@ -439,11 +457,11 @@ begin
     SetValue(APath, AValue);
     SetValue(APath, AValue);
 end;
 end;
 
 
-procedure TJSONConfig.SetValue(const APath: WideString; AValue: Boolean);
+procedure TJSONConfig.SetValue(const APath: UnicodeString; AValue: Boolean);
 
 
 var
 var
   El : TJSONData;
   El : TJSONData;
-  ElName : WideString;
+  ElName : UnicodeString;
   O : TJSONObject;
   O : TJSONObject;
   I : integer;
   I : integer;
 
 
@@ -465,11 +483,11 @@ begin
   FModified:=True;
   FModified:=True;
 end;
 end;
 
 
-procedure TJSONConfig.SetValue(const APath: WideString; AValue: Double);
+procedure TJSONConfig.SetValue(const APath: UnicodeString; AValue: Double);
 
 
 var
 var
   El : TJSONData;
   El : TJSONData;
-  ElName : WideString;
+  ElName : UnicodeString;
   O : TJSONObject;
   O : TJSONObject;
   I : integer;
   I : integer;
 
 
@@ -491,7 +509,7 @@ begin
   FModified:=True;
   FModified:=True;
 end;
 end;
 
 
-procedure TJSONConfig.SetDeleteValue(const APath: WideString; AValue,
+procedure TJSONConfig.SetDeleteValue(const APath: UnicodeString; AValue,
   DefValue: Boolean);
   DefValue: Boolean);
 begin
 begin
   if AValue = DefValue then
   if AValue = DefValue then
@@ -500,13 +518,13 @@ begin
     SetValue(APath,AValue);
     SetValue(APath,AValue);
 end;
 end;
 
 
-procedure TJSONConfig.DeletePath(const APath: WideString);
+procedure TJSONConfig.DeletePath(const APath: UnicodeString);
 
 
 Var
 Var
   P : String;
   P : String;
   L : integer;
   L : integer;
   Node : TJSONObject;
   Node : TJSONObject;
-  ElName : WideString;
+  ElName : UnicodeString;
   
   
 begin
 begin
   P:=StripSlash(APath);
   P:=StripSlash(APath);
@@ -523,13 +541,13 @@ begin
     end;
     end;
 end;
 end;
 
 
-procedure TJSONConfig.DeleteValue(const APath: WideString);
+procedure TJSONConfig.DeleteValue(const APath: UnicodeString);
 
 
 begin
 begin
   DeletePath(APath);
   DeletePath(APath);
 end;
 end;
 
 
-Procedure TJSONConfig.Reload;
+procedure TJSONConfig.Reload;
 
 
 begin
 begin
   if Length(Filename) > 0 then
   if Length(Filename) > 0 then
@@ -541,11 +559,11 @@ begin
   Reload;
   Reload;
 end;
 end;
 
 
-function TJSONConfig.FindPath(const APath: WideString; AllowCreate: Boolean
+function TJSONConfig.FindPath(const APath: UnicodeString; AllowCreate: Boolean
   ): TJSONObject;
   ): TJSONObject;
   
   
 Var
 Var
-  P : WideString;
+  P : UnicodeString;
   L : Integer;
   L : Integer;
   
   
 begin
 begin
@@ -603,7 +621,7 @@ begin
   DoSetFilename(AFilename, False);
   DoSetFilename(AFilename, False);
 end;
 end;
 
 
-function TJSONConfig.StripSlash(P: WideString): WideString;
+function TJSONConfig.StripSlash(Const P: UnicodeString): UnicodeString;
 
 
 Var
 Var
   L : Integer;
   L : Integer;
@@ -622,10 +640,10 @@ begin
   ResetKey;
   ResetKey;
 end;
 end;
 
 
-procedure TJSONConfig.OpenKey(const aPath: WideString; AllowCreate: Boolean);
+procedure TJSONConfig.OpenKey(const aPath: UnicodeString; AllowCreate: Boolean);
 
 
 Var
 Var
-  ElName : WideString;
+  ElName : UnicodeString;
   P : String;
   P : String;
   L : Integer;
   L : Integer;
 begin
 begin
@@ -648,7 +666,7 @@ begin
   FKey:=FJSON;
   FKey:=FJSON;
 end;
 end;
 
 
-procedure TJSONConfig.EnumSubKeys(const APath: String; List: TStrings);
+procedure TJSONConfig.EnumSubKeys(const APath: UnicodeString; List: TStrings);
 
 
 Var
 Var
   AKey : TJSONObject;
   AKey : TJSONObject;
@@ -664,7 +682,7 @@ begin
     end;
     end;
 end;
 end;
 
 
-procedure TJSONConfig.EnumValues(const APath: String; List: TStrings);
+procedure TJSONConfig.EnumValues(const APath: UnicodeString; List: TStrings);
 
 
 Var
 Var
   AKey : TJSONObject;
   AKey : TJSONObject;

+ 4 - 1
rtl/inc/system.inc

@@ -982,7 +982,10 @@ Begin
     redirection to seriell i/o }
     redirection to seriell i/o }
 {$ifndef EMBEDDED}
 {$ifndef EMBEDDED}
   { Show runtime error and exit }
   { Show runtime error and exit }
-  pstdout:=@stdout;
+  if WriteErrorsToStdErr then
+    pstdout:=@stderr
+  else  
+    pstdout:=@stdout;
   If erroraddr<>nil Then
   If erroraddr<>nil Then
    Begin
    Begin
      Writeln(pstdout^,'Runtime error ',Errorcode,' at $',hexstr(erroraddr));
      Writeln(pstdout^,'Runtime error ',Errorcode,' at $',hexstr(erroraddr));

+ 3 - 0
rtl/inc/systemh.inc

@@ -712,6 +712,9 @@ Var
   { Stack checking }
   { Stack checking }
   StackBottom : Pointer;
   StackBottom : Pointer;
   StackLength : SizeUInt;
   StackLength : SizeUInt;
+  
+Var
+  WriteErrorsToStdErr : Boolean = True;
 
 
 function StackTop: Pointer;
 function StackTop: Pointer;
 
 

+ 61 - 57
rtl/objpas/classes/classes.inc

@@ -357,68 +357,72 @@ procedure TThread.Synchronize(AMethod: TThreadMethod);
     TThread.Synchronize(self,AMethod);
     TThread.Synchronize(self,AMethod);
   end;
   end;
 
 
+Function PopThreadQueueHead : TThread.PThreadQueueEntry;
+
+begin
+  Result:=ThreadQueueHead;
+  if (Result<>Nil) then
+    begin
+    System.EnterCriticalSection(ThreadQueueLock);
+    try
+      Result:=ThreadQueueHead;
+      if Result<>Nil then
+        ThreadQueueHead:=ThreadQueueHead^.Next;
+      if Not Assigned(ThreadQueueHead) then
+        ThreadQueueTail := Nil;
+    finally
+      System.LeaveCriticalSection(ThreadQueueLock);
+    end;
+    end;
+end;
 
 
 function CheckSynchronize(timeout : longint=0) : boolean;
 function CheckSynchronize(timeout : longint=0) : boolean;
-  { assumes being called from GUI thread }
-  var
-    exceptobj: Exception;
-    tmpentry: TThread.PThreadQueueEntry;
-  begin
-    result:=false;
-    { first sanity check }
-    if Not IsMultiThread then
-      Exit
-    { second sanity check }
-    else if GetCurrentThreadID<>MainThreadID then
-      raise EThread.CreateFmt(SCheckSynchronizeError,[GetCurrentThreadID])
+
+{ assumes being called from GUI thread }
+var
+  ExceptObj: Exception;
+  tmpentry: TThread.PThreadQueueEntry;
+
+begin
+  result:=false;
+  { first sanity check }
+  if Not IsMultiThread then
+    Exit
+  { second sanity check }
+  else if GetCurrentThreadID<>MainThreadID then
+    raise EThread.CreateFmt(SCheckSynchronizeError,[GetCurrentThreadID]);
+  if timeout>0 then
+    RtlEventWaitFor(SynchronizeTimeoutEvent,timeout)
+  else
+    RtlEventResetEvent(SynchronizeTimeoutEvent);
+  tmpentry := PopThreadQueueHead;
+  while Assigned(tmpentry) do
+    begin
+    { step 2: execute the method }
+    exceptobj := Nil;
+    try
+      ExecuteThreadQueueEntry(tmpentry);
+    except
+      exceptobj := Exception(AcquireExceptionObject);
+    end;
+    { step 3: error handling and cleanup }
+    if Assigned(tmpentry^.SyncEvent) then
+      begin
+      { for Synchronize entries we pass back the Exception and trigger
+        the event that Synchronize waits in }
+      tmpentry^.Exception := exceptobj;
+      RtlEventSetEvent(tmpentry^.SyncEvent)
+      end
     else
     else
       begin
       begin
-        if timeout>0 then
-          begin
-            RtlEventWaitFor(SynchronizeTimeoutEvent,timeout);
-          end
-         else
-           RtlEventResetEvent(SynchronizeTimeoutEvent);
-
-        System.EnterCriticalSection(ThreadQueueLock);
-        try
-          { Note: we don't need to pay attention to recursive calls to
-                  Synchronize as those calls will be executed in the context of
-                  the GUI thread and thus will be executed immediatly instead of
-                  queuing them }
-          while Assigned(ThreadQueueHead) do begin
-            { step 1: update the list }
-            tmpentry := ThreadQueueHead;
-            ThreadQueueHead := ThreadQueueHead^.Next;
-            if not Assigned(ThreadQueueHead) then
-              ThreadQueueTail := Nil;
-
-            { step 2: execute the method }
-            exceptobj := Nil;
-            try
-              ExecuteThreadQueueEntry(tmpentry);
-            except
-              exceptobj := Exception(AcquireExceptionObject);
-            end;
-
-            { step 3: error handling and cleanup }
-            if Assigned(tmpentry^.SyncEvent) then begin
-              { for Synchronize entries we pass back the Exception and trigger
-                the event that Synchronize waits in }
-              tmpentry^.Exception := exceptobj;
-              RtlEventSetEvent(tmpentry^.SyncEvent)
-            end else begin
-              { for Queue entries we dispose the entry and raise the exception }
-              Dispose(tmpentry);
-              if Assigned(exceptobj) then
-                raise exceptobj;
-            end;
-          end;
-        finally
-          System.LeaveCriticalSection(ThreadQueueLock);
-        end;
+      { for Queue entries we dispose the entry and raise the exception }
+      Dispose(tmpentry);
+      if Assigned(exceptobj) then
+        raise exceptobj;
       end;
       end;
-  end;
+    tmpentry := PopThreadQueueHead;
+    end;
+end;
 
 
 
 
 class function TThread.GetCurrentThread: TThread;
 class function TThread.GetCurrentThread: TThread;

+ 9 - 5
rtl/objpas/sysutils/dati.inc

@@ -165,7 +165,8 @@ begin
     else  
     else  
       Date:=Date-1/(msecsperday*2);
       Date:=Date-1/(msecsperday*2);
     if Date>MaxDateTime then
     if Date>MaxDateTime then
-       Raise EConvertError.CreateFmt('%f is not a valid TDatetime encoding, maximum value is %f.',[Date,MaxDateTime]);
+      Date:=MaxDateTime;
+//       Raise EConvertError.CreateFmt('%f is not a valid TDatetime encoding, maximum value is %f.',[Date,MaxDateTime]);
     j := pred((Trunc(System.Int(Date)) + 693900) SHL 2);
     j := pred((Trunc(System.Int(Date)) + 693900) SHL 2);
     ly:= j DIV 146097;
     ly:= j DIV 146097;
     j:= j - 146097 * cardinal(ly);
     j:= j - 146097 * cardinal(ly);
@@ -338,14 +339,17 @@ end;
 
 
 {   DateTimeToStr returns a string representation of DateTime using LongDateTimeFormat   }
 {   DateTimeToStr returns a string representation of DateTime using LongDateTimeFormat   }
 
 
-function DateTimeToStr(DateTime: TDateTime): string;
+Const
+  DateTimeToStrFormat : Array[Boolean] of string = ('c','f');
+  
+function DateTimeToStr(DateTime: TDateTime; ForceTimeIfZero : Boolean = False): string;
 begin
 begin
-  DateTimeToString(Result, 'c', DateTime);
+  DateTimeToString(Result, DateTimeToStrFormat[ForceTimeIfZero], DateTime)
 end ;
 end ;
 
 
-function DateTimeToStr(DateTime: TDateTime; const FormatSettings: TFormatSettings): string;
+function DateTimeToStr(DateTime: TDateTime; const FormatSettings: TFormatSettings; ForceTimeIfZero : Boolean = False): string;
 begin
 begin
-  DateTimeToString(Result, 'c', DateTime ,FormatSettings);
+  DateTimeToString(Result,  DateTimeToStrFormat[ForceTimeIfZero], DateTime ,FormatSettings);
 end;
 end;
 
 
 {   StrToDate converts the string S to a TDateTime value
 {   StrToDate converts the string S to a TDateTime value

+ 2 - 2
rtl/objpas/sysutils/datih.inc

@@ -133,8 +133,8 @@ function DateToStr(Date: TDateTime): string;
 function DateToStr(Date: TDateTime; const FormatSettings: TFormatSettings): string;
 function DateToStr(Date: TDateTime; const FormatSettings: TFormatSettings): string;
 function TimeToStr(Time: TDateTime): string;
 function TimeToStr(Time: TDateTime): string;
 function TimeToStr(Time: TDateTime; const FormatSettings: TFormatSettings): string;
 function TimeToStr(Time: TDateTime; const FormatSettings: TFormatSettings): string;
-function DateTimeToStr(DateTime: TDateTime): string;
-function DateTimeToStr(DateTime: TDateTime; const FormatSettings: TFormatSettings): string;
+function DateTimeToStr(DateTime: TDateTime; ForceTimeIfZero : Boolean = False): string;
+function DateTimeToStr(DateTime: TDateTime; const FormatSettings: TFormatSettings; ForceTimeIfZero : Boolean = False): string;
 function StrToDate(const S: ShortString): TDateTime;                  {$ifdef SYSUTILSINLINE}inline;{$endif}
 function StrToDate(const S: ShortString): TDateTime;                  {$ifdef SYSUTILSINLINE}inline;{$endif}
 function StrToDate(const S: Ansistring): TDateTime;                   {$ifdef SYSUTILSINLINE}inline;{$endif}
 function StrToDate(const S: Ansistring): TDateTime;                   {$ifdef SYSUTILSINLINE}inline;{$endif}
 function StrToDate(const S: ShortString; separator : char): TDateTime;{$ifdef SYSUTILSINLINE}inline;{$endif}
 function StrToDate(const S: ShortString; separator : char): TDateTime;{$ifdef SYSUTILSINLINE}inline;{$endif}

+ 1 - 1
rtl/objpas/sysutils/sysutilh.inc

@@ -254,7 +254,7 @@ type
 
 
 Var
 Var
    OnShowException : Procedure (Msg : ShortString);
    OnShowException : Procedure (Msg : ShortString);
-
+   
 Const
 Const
    HexDisplayPrefix : string = '$';
    HexDisplayPrefix : string = '$';
 
 

+ 5 - 1
rtl/objpas/sysutils/sysutils.inc

@@ -289,8 +289,12 @@ Procedure CatchUnhandledException (Obj : TObject; Addr: CodePointer; FrameCount:
 Var
 Var
   i : longint;
   i : longint;
   hstdout : ^text;
   hstdout : ^text;
+  
 begin
 begin
-  hstdout:=@stdout;
+  if WriteErrorsToStdErr then
+    hstdout:=@stderr
+  else
+    hstdout:=@stdout;
   Writeln(hstdout^,'An unhandled exception occurred at $',HexStr(Addr),':');
   Writeln(hstdout^,'An unhandled exception occurred at $',HexStr(Addr),':');
   if Obj is exception then
   if Obj is exception then
     Writeln(hstdout^,Obj.ClassName,': ',Exception(Obj).Message)
     Writeln(hstdout^,Obj.ClassName,': ',Exception(Obj).Message)