rtl: implement TStreamAdapter.CopyTo, .SetSize, return proper error value for Clone instead of raising exception (#0016161) + test

git-svn-id: trunk@15138 -

.gitattributes

@@ -10342,6 +10342,7 @@ tests/webtbs/tw16004.pp svneol=native#text/plain
 tests/webtbs/tw16040.pp svneol=native#text/plain
 tests/webtbs/tw16083.pp svneol=native#text/plain
 tests/webtbs/tw16108.pp svneol=native#text/plain
+tests/webtbs/tw16161.pp svneol=native#text/pascal
 tests/webtbs/tw16163.pp svneol=native#text/plain
 tests/webtbs/tw1617.pp svneol=native#text/plain
 tests/webtbs/tw16188.pp svneol=native#text/plain

rtl/objpas/classes/streams.inc

@@ -919,18 +919,53 @@ begin
       Result := STG_E_REVERTED;
       Exit;
     end;
-  runerror(217);
+  if libNewSize<0 then
+    begin
+      Result := STG_E_INVALIDFUNCTION;
+      Exit;
+    end;
+  try
+    FStream.Size := libNewSize;
+    Result := S_OK;
+  except
+    // TODO: return different error value according to exception like STG_E_MEDIUMFULL
+    Result := E_FAIL;
+  end;
 end;
 
 
 function TStreamAdapter.CopyTo(stm: IStream; cb: Largeint; out cbRead: Largeint; out cbWritten: Largeint): HResult; stdcall;
+var
+  sz: dword;
+  buffer : array[0..1023] of byte;
 begin
   if m_bReverted then
     begin
       Result := STG_E_REVERTED;
       Exit;
     end;
-  runerror(217);
+
+  // the method is similar to TStream.CopyFrom => use CopyFrom implementation
+  cbWritten := 0;
+  cbRead := 0;
+  while cb > 0 do
+    begin
+      if (cb > sizeof(buffer)) then
+        sz := sizeof(Buffer)
+      else
+        sz := cb;
+      sz := FStream.Read(buffer, sz);
+      inc(cbRead, sz);
+      stm.Write(@buffer[0], sz, @sz);
+      inc(cbWritten, sz);
+      if sz = 0 then
+        begin
+          Result := E_FAIL;
+          Exit;
+        end;
+      dec(cb, sz);
+    end;
+  Result := S_OK;
 end;
 
 function TStreamAdapter.Commit(grfCommitFlags: Longint): HResult; stdcall;
@@ -994,7 +1029,9 @@ begin
       Result := STG_E_REVERTED;
       Exit;
     end;
-  runerror(217);
+  // don't raise an exception here return error value that function is not implemented
+  // to implement this we need a clone method for TStream class
+  Result := STG_E_UNIMPLEMENTEDFUNCTION;
 end;
 
 constructor TProxyStream.Create(const Stream: IStream);

tests/webtbs/tw16161.pp

@@ -0,0 +1,34 @@
+program tw16161;
+
+{$ifdef fpc}
+  {$mode delphi}
+{$endif}
+{$apptype console}
+
+uses
+  Classes, ActiveX;
+
+var
+  Stream1: TMemoryStream;
+  _Stream1, _Stream2: IStream;
+  cbRead, cbWritten: LargeInt;
+  NewPos: Int64;
+  buf: array[0..3] of char;
+begin
+  Stream1 := TMemoryStream.Create;
+  Stream1.Write('test', 4);
+  Stream1.Position := 0;
+  _Stream1 := TStreamAdapter.Create(Stream1, soReference);
+  _Stream1.SetSize(3);
+  _Stream2 := TStreamAdapter.Create(TMemoryStream.Create, soOwned);
+  _Stream1.CopyTo(_Stream2, 4, cbRead, cbWritten);
+  _Stream2.Seek(0, STREAM_SEEK_SET, NewPos);
+  if (cbRead <> 3) or (cbWritten <> 3) then
+    halt(1);
+  _Stream2.Read(@buf[0], cbRead, @cbWritten);
+  if (buf[0] <> 't') or (buf[1] <> 'e') or (buf[2] <> 's') then
+    halt(2);
+  if (cbRead <> 3) or (cbWritten <> 3) then
+    halt(3);
+  Stream1.Free;
+end.