* Merging revisions 42743,42766,42767,42768,42782 from trunk:

------------------------------------------------------------------------
    r42743 | michael | 2019-08-20 09:03:24 +0200 (Tue, 20 Aug 2019) | 1 line
    
    * Fix bug #0035985
    ------------------------------------------------------------------------
    r42766 | michael | 2019-08-23 08:45:11 +0200 (Fri, 23 Aug 2019) | 1 line
    
    * Fix bug ID #0035596: better detection of vcs device
    ------------------------------------------------------------------------
    r42767 | michael | 2019-08-23 09:21:03 +0200 (Fri, 23 Aug 2019) | 1 line
    
    * Make TResponse.Content a RawByteString
    ------------------------------------------------------------------------
    r42768 | michael | 2019-08-23 09:21:44 +0200 (Fri, 23 Aug 2019) | 1 line
    
    * Set content-type on response (bug ID 35990)
    ------------------------------------------------------------------------
    r42782 | michael | 2019-08-24 10:54:24 +0200 (Sat, 24 Aug 2019) | 1 line
    
    * Add WideString support in json string constructor
    ------------------------------------------------------------------------

git-svn-id: branches/fixes_3_2@42844 -

packages/fcl-json/src/fpjson.pp

@@ -2497,6 +2497,8 @@ begin
       vtExtended   : Result:=CreateJSON(VExtended^);
       vtString     : Result:=CreateJSON(vString^);
       vtAnsiString : Result:=CreateJSON(UTF8Decode(StrPas(VPChar)));
+      vtUnicodeString: Result:=CreateJSON(UnicodeString(VUnicodeString));
+      vtWideString: Result:=CreateJSON(WideString(VWideString));
       vtPChar      : Result:=CreateJSON(StrPas(VPChar));
       vtPointer    : If (VPointer<>Nil) then
                        TJSONData.DoError(SErrPointerNotNil,[SourceType])

packages/fcl-json/tests/testjsondata.pp

@@ -53,7 +53,7 @@ type
     Procedure SetUp; override;
     Procedure TestItemCount(J : TJSONData;Expected : Integer);
     Procedure TestJSONType(J : TJSONData;Expected : TJSONType);
-    Procedure TestJSON(J : TJSONData;Expected : String);
+    Procedure TestJSON(J : TJSONData;Expected : TJSONStringType);
     Procedure TestIsNull(J : TJSONData;Expected : Boolean);
     Procedure TestAsBoolean(J : TJSONData;Expected : Boolean; ExpectError : boolean = False);
     Procedure TestAsInteger(J : TJSONData; Expected : Integer; ExpectError : boolean = False);
@@ -238,6 +238,8 @@ type
     procedure TestCreateBoolean;
     procedure TestCreateBooleanUnquoted;
     procedure TestCreateObject;
+    procedure TestCreateJSONUnicodeString;
+    procedure TestCreateJSONWideString;
     procedure TestCreateJSONString;
     procedure TestCreateJSONStringUnquoted;
     procedure TestCreateJSONObject;
@@ -1078,7 +1080,7 @@ begin
   AssertEquals(J.ClassName+'.JSONType',Ord(Expected),Ord(J.JSONType));
 end;
 
-Procedure TTestJSON.TestJSON(J: TJSONData; Expected: String);
+Procedure TTestJSON.TestJSON(J: TJSONData; Expected: TJSONStringType);
 begin
   AssertEquals(J.ClassName+'.AsJSON',Expected,J.AsJSON);
 end;
@@ -3926,6 +3928,44 @@ begin
   end;
 end;
 
+procedure TTestObject.TestCreateJSONUnicodeString;
+Const
+  A = 'A';
+  S : Unicodestring = 'A string';
+
+Var
+  O : TJSONObject;
+
+begin
+  O:=TJSONObject.Create([A,S]);
+  try
+    TestItemCount(O,1);
+    TestJSONType(O[A],jtString);
+    TestJSON(O,'{ "A" : "'+UTF8Encode(S)+'" }');
+  finally
+    FreeAndNil(O);
+  end;
+end;
+
+procedure TTestObject.TestCreateJSONWideString;
+Const
+  A = 'A';
+  W : WideString = 'A string';
+
+Var
+  O : TJSONObject;
+
+begin
+  O:=TJSONObject.Create([A,W]);
+  try
+    TestItemCount(O,1);
+    TestJSONType(O[A],jtString);
+    TestJSON(O,'{ "A" : "'+UTF8Encode(W)+'" }');
+  finally
+    FreeAndNil(O);
+  end;
+end;
+
 procedure TTestObject.TestCreateNilPointer;
 
 Const

packages/fcl-web/src/base/httpdefs.pp

@@ -475,8 +475,8 @@ type
     FContentSent: Boolean;
     FRequest : TRequest;
     FCookies : TCookies;
-    function GetContent: String;
+    function GetContent: RawByteString;
-    procedure SetContent(const AValue: String);
+    procedure SetContent(const AValue: RawByteString);
     procedure SetContents(AValue: TStrings);
     procedure SetContentStream(const AValue: TStream);
     procedure SetFirstHeaderLine(const line: String);
@@ -507,7 +507,7 @@ type
     Property RetryAfter : String  Index Ord(hhRetryAfter) Read GetHeaderValue Write SetHeaderValue;
     Property FirstHeaderLine : String Read GetFirstHeaderLine Write SetFirstHeaderLine;
     Property ContentStream : TStream Read FContentStream Write SetContentStream;
-    Property Content : String Read GetContent Write SetContent;
+    Property Content : RawByteString Read GetContent Write SetContent;
     property Contents : TStrings read FContents Write SetContents;
     Property HeadersSent : Boolean Read FHeadersSent;
     Property ContentSent : Boolean Read FContentSent;
@@ -1985,7 +1985,7 @@ begin
   FContents:=TStringList.Create;
   TStringList(FContents).OnChange:=@ContentsChanged;
   FCookies:=TCookies.Create(TCookie);
-  FCustomHeaders:=TStringList.Create;
+  FCustomHeaders:=TStringList.Create; // Destroyed in parent
 end;
 
 destructor TResponse.destroy;
@@ -2074,14 +2074,18 @@ begin
   FContents.Assign(AValue);
 end;
 
-function TResponse.GetContent: String;
+function TResponse.GetContent: RawByteString;
 begin
   Result:=Contents.Text;
 end;
 
-procedure TResponse.SetContent(const AValue: String);
+procedure TResponse.SetContent(const AValue: RawByteString);
 begin
-  FContentStream:=Nil;
+  if Assigned(FContentStream) then
+    if FreeContentStream then
+      FreeAndNil(FContentStream)
+    else
+      FContentStream:=Nil;
   FContents.Text:=AValue;
 end;
 

packages/fcl-web/src/jsonrpc/webjsonrpc.pp

@@ -89,8 +89,10 @@ Type
     FOptions: TJSONRPCDispatchOptions;
     FRequest: TRequest;
     FResponse: TResponse;
+    FResponseContentType: String;
     procedure SetDispatcher(const AValue: TCustomJSONRPCDispatcher);
   Protected
+    Function GetResponseContentType : String;
     Function CreateDispatcher : TCustomJSONRPCDispatcher; virtual;
     procedure Notification(AComponent: TComponent; Operation: TOperation);override;
     Property Dispatcher :  TCustomJSONRPCDispatcher Read FDispatcher Write SetDispatcher;
@@ -102,14 +104,19 @@ Type
     Property Request: TRequest Read FRequest;
     // Access to response
     Property Response: TResponse Read FResponse;
+    // Response Content-Type. If left empty, application/json is used.
+    Property ResponseContentType : String Read FResponseContentType Write FResponseContentType;
   end;
 
   { TJSONRPCDataModule }
 
+  { TJSONRPCModule }
+
   TJSONRPCModule = Class(TCustomJSONRPCModule)
   Published
     Property Dispatcher;
     Property DispatchOptions;
+    Property ResponseContentType;
   end;
 
 implementation
@@ -118,6 +125,9 @@ implementation
 uses dbugintf;
 {$endif}
 
+Const
+  SApplicationJSON = 'application/json';
+
 { TCustomJSONRPCContentProducer }
 
 function TCustomJSONRPCContentProducer.GetIDProperty: String;
@@ -133,7 +143,7 @@ Var
   Disp : TCustomJSONRPCDispatcher;
   P : TJSONParser;
   Req,res : TJSONData;
-  R : String;
+  R : TJSONStringType;
 
 begin
   Disp:=Self.GetDispatcher;
@@ -211,6 +221,13 @@ begin
     FDispatcher.FreeNotification(Self);
 end;
 
+function TCustomJSONRPCModule.GetResponseContentType: String;
+begin
+  Result:=FResponseContentType;
+  if Result='' then
+    Result:=SApplicationJSON;
+end;
+
 function TCustomJSONRPCModule.CreateDispatcher: TCustomJSONRPCDispatcher;
 
 Var
@@ -245,6 +262,7 @@ procedure TCustomJSONRPCModule.HandleRequest(ARequest: TRequest;
 Var
   Disp : TCustomJSONRPCDispatcher;
   res : TJSONData;
+  R : TJSONStringType;
 
 begin
   If (Dispatcher=Nil) then
@@ -254,10 +272,15 @@ begin
   try
     If Assigned(Res) then
       begin
-      AResponse.Content:=Res.AsJSON;
+      AResponse.FreeContentStream:=True;
-      AResponse.ContentLength:=Length(AResponse.Content);
+      AResponse.ContentStream:=TMemoryStream.Create;
+      R:=Res.AsJSON;
+      AResponse.ContentStream.WriteBuffer(R[1],Length(R));
+      AResponse.ContentLength:=AResponse.ContentStream.Size;
+      R:=''; // Free up mem
+      AResponse.ContentType:=GetResponseContentType;
       end;
-  AResponse.SendResponse;
+    AResponse.SendResponse;
   finally
     Res.Free;
   end;

rtl/linux/linuxvcs.pp

@@ -82,73 +82,59 @@ end;
 procedure detect_linuxvcs;
 
 var f:text;
-    f_open : boolean;
+    fields:array [0..60] of int64;
-    c,pc:char;
+    fieldct,i:integer;
-    pid,cpid,dummy:longint;
+    pid,ppid:longint;
-    device:dword;
+    magnitude:int64;
     s:string[15];
+    statln:ansistring;
 
 begin
   {Extremely aggressive VCSA detection. Works even through Midnight
    Commander. Idea from the C++ Turbo Vision project, credits go
    to Martynas Kunigelis <algikun@santaka.sc-uni.ktu.lt>.}
   pid:=fpgetpid;
-  f_open:=false;
-  {$push}
-  {$I-}
-  {$R-}
   repeat
-    cpid:=pid;
     str(pid,s);
-    assign(f,'/proc/'+s+'/stat');
+    assign(f, '/proc/'+s+'/stat');
+    {$I-}
     reset(f);
+    {$I+}
     if ioresult<>0 then
-      exit;
+      break;
-    f_open:=true;
+    readln(f, statln);
-    { from here we can discard I/O errors, as long as we avoid
-      infinite loops }
-    { first number is pid }
-    dummy:=0;
-    read(f,dummy);
-    if dummy<>pid then
-      exit;
-    { after comes the name of the binary within (), look for closing brace followed by space }
-    c:=#0;
-    repeat
-      pc:=c;
-      read(f,c);
-      if ioresult<>0 then
-        break;
-    until (pc=')') and (c=' ');
-    { now comes the state letter }
-    repeat
-      read(f,c);
-      if ioresult<>0 then
-        break;
-    until c=' ';
-    { parent pid }
-    pid:=-1;
-    read(f,pid);
-    { process group }
-    read(f,dummy);
-    { session }
-    read(f,dummy);
-    { device number }
-    device:=0;
-    read(f,device);
     close(f);
-    f_open:=false;
+    magnitude := 1;
-    if (device and $ffffffc0)=$00000400 then {/dev/tty*}
+    fieldct := 0;
+    fields[fieldct] := 0;
+    for i := high(statln) downto low(statln) do
       begin
-        vcs_device:=device and $3f;
+        case statln[i] of
+          '-': magnitude := -1;
+          '0'..'9': begin
+            fields[fieldct] := fields[fieldct]
+                               + (magnitude * (ord(statln[i]) - ord('0')));
+            magnitude := magnitude * 10;
+          end;
+          ' ': begin
+            magnitude := 1;
+            fieldct := fieldct + 1;
+            fields[fieldct] := 0;
+          end;
+        else
+          break;
+        end;
+      end;
+    ppid := pid;
+    pid := fields[fieldct - 1];
+    if (fields[fieldct - 4] and $ffffffc0) = $00000400 then {/dev/tty*}
+      begin
+        vcs_device:=fields[fieldct - 4] and $3f;
         break;
       end;
-  until (device=0) {Not attached to a terminal, i.e. an xterm.}
+  until (fields[fieldct - 4]=0) {Not attached to a terminal, i.e. an xterm.}
-      or (pid=-1)
+        or (pid=-1)
-      or (cpid=pid);
+        or (ppid=pid);
-  if f_open then
-    close(f);
-  {$pop}
 end;
 
 begin