streams.pas

delphi完成端口Socks例子,纯Delphi做的

unit Streams;

interface

uses SysUtils;

type
  TSeekOrigin = (soBeginning, soCurrent, soEnd);
  EStreamError = class(Exception);
  EReadError = class(EStreamError);
  EWriteError = class(EStreamError);
  
  TStream = class
  private
    function GetPosition: Integer;
    procedure SetPosition(Pos: Integer);
  protected
    function GetSize: Integer; virtual;
    procedure SetSize(NewSize: Integer); virtual;
  public
    function Read(var Buffer; Count: Integer): Integer; virtual; abstract;
    function Write(const Buffer; Count: Integer): Integer; virtual; abstract;
    function Seek(Offset: Integer; Origin: TSeekOrigin): Integer; virtual; abstract;
    procedure ReadBuffer(var Buffer; Count: Longint);
    procedure WriteBuffer(const Buffer; Count: Longint);
    function CopyFrom(Source: TStream; Count: Integer): Integer;
    property Position: Integer read GetPosition write SetPosition;
    property Size: Integer read GetSize write SetSize;

    function ReadByte: Byte;
    function ReadSmallInt: SmallInt;
    function ReadChar: Char;
    function ReadInteger: Integer;
    function ReadString: string;
    function ReadDateTime: TDateTime;
    function ReadSingle: Single;
    function ReadDouble: Double;
    procedure WriteByte(Value: Byte);
    procedure WriteSmallInt(Value: SmallInt);
    procedure WriteChar(Value: Char);
    procedure WriteInteger(Value: Integer);
    procedure WriteString(const Value: string);
    procedure WriteDateTime(const Value: TDateTime);
    procedure WriteSingle(const Value: Single);
    procedure WriteDouble(const Value: Double);
  end;

  TCustomMemoryStream = class(TStream)
  private
    FMemory: Pointer;
    FSize, FPosition: Integer;
  protected
    procedure SetPointer(Ptr: Pointer; Size: Integer);
  public
    function Read(var Buffer; Count: Integer): Integer; override;
    function Seek(Offset: Integer; Origin: TSeekOrigin): Integer; override;
    procedure SaveToStream(Stream: TStream);
    property Memory: Pointer read FMemory;
  end;

  TMemoryStream = class(TCustomMemoryStream)
  private
    FCapacity: Integer;
    procedure SetCapacity(NewCapacity: Integer);
  protected
    function Realloc(var NewCapacity: Integer): Pointer; virtual;
    property Capacity: Integer read FCapacity write SetCapacity;
  public
    destructor Destroy; override;
    procedure Clear;
    procedure LoadFromStream(Stream: TStream);
    procedure SetSize(NewSize: Integer); override;
    function Write(const Buffer; Count: Integer): Integer; override;
  end;

  TMemStream = class(TCustomMemoryStream)
  public
    constructor Create(Data: Pointer; DataSize: Integer);
    function Write(const Buffer; Count: Integer): Integer; override;
  end;

procedure _NewAlloc(Size: Integer; var Value: Pointer);
procedure _Realloc(Size: Integer; var Value: Pointer);
procedure _Free(var Value: Pointer);
  
implementation

uses Windows;

resourcestring
  SReadError = 'Stream read error';
  SWriteError = 'Stream write error';
  SMemoryStreamError = 'Out of memory while expanding memory stream';
  SStreamReadOnly = 'Stream is Readonly';

{ TStream }

function TStream.GetPosition: Integer;
begin
  Result := Seek(0, soCurrent);
end;

procedure TStream.SetPosition(Pos: Integer);
begin
  Seek(Pos, soBeginning);
end;

function TStream.GetSize: Integer;
var
  Pos: Integer;
begin
  Pos := Seek(0, soCurrent);
  Result := Seek(0, soEnd);
  Seek(Pos, soBeginning);
end;

procedure TStream.SetSize(NewSize: Integer);
begin

end;

procedure TStream.ReadBuffer(var Buffer; Count: Integer);
begin
  if (Count <> 0) and (Read(Buffer, Count) <> Count) then
    raise EReadError.CreateRes(@SReadError);
end;

procedure TStream.WriteBuffer(const Buffer; Count: Integer);
begin
  if (Count <> 0) and (Write(Buffer, Count) <> Count) then
    raise EWriteError.CreateRes(@SWriteError);
end;

function TStream.CopyFrom(Source: TStream; Count: Integer): Integer;
const
  MaxBufSize = $F000;
var
  BufSize, N: Integer;
  Buffer: PChar;
begin
  if Count = 0 then
  begin
    Source.Position := 0;
    Count := Source.Size;
  end;
  Result := Count;
  if Count > MaxBufSize then BufSize := MaxBufSize else BufSize := Count;
  GetMem(Buffer, BufSize);
  try
    while Count <> 0 do
    begin
      if Count > BufSize then N := BufSize else N := Count;
      Source.ReadBuffer(Buffer^, N);
      WriteBuffer(Buffer^, N);
      Dec(Count, N);
    end;
  finally
    FreeMem(Buffer, BufSize);
  end;
end;

function TStream.ReadByte: Byte;
begin
  Read(Result, SizeOf(Byte));
end;

function TStream.ReadSmallInt: SmallInt;
begin
  Read(Result, SizeOf(SmallInt));
end;

function TStream.ReadChar: Char;
begin
  Read(Result, SizeOf(Char));
end;

function TStream.ReadInteger: Integer;
begin
  Read(Result, SizeOf(Integer));
end;

function TStream.ReadString: string;
var
  L: Integer;
  P: PChar;
begin
  L := ReadInteger;
  if L = 0 then
    Result := ''
  else
  begin
    P := StrAlloc(L + 1);
    Read(P^, L);
    SetString(Result, P, L);
    StrDispose(P);
  end;
end;

function TStream.ReadDateTime: TDateTime;
begin
  Read(Result, SizeOf(TDateTime));
end;

function TStream.ReadSingle: Single;
begin
  Read(Result, SizeOf(Single));
end;

function TStream.ReadDouble: Double;
begin
  Read(Result, SizeOf(Double));
end;

procedure TStream.WriteByte(Value: Byte);
begin
  Write(Value, SizeOf(Byte));
end;

procedure TStream.WriteSmallInt(Value: SmallInt);
begin
  Write(Value, SizeOf(SmallInt));
end;

procedure TStream.WriteChar(Value: Char);
begin
  Write(Value, SizeOf(Char));
end;

procedure TStream.WriteInteger(Value: Integer);
begin
  Write(Value, SizeOf(Integer));
end;

procedure TStream.WriteString(const Value: string);
var
  L: Integer;
  P: PChar;
begin
  L := Length(Value);
  WriteInteger(L);
  if L > 0 then
  begin
    P := StrAlloc(L + 1);
    StrPLCopy(P, Value, L);
    Write(P^, L);
    StrDispose(P);
  end;
end;

procedure TStream.WriteDateTime(const Value: TDateTime);
begin
  Write(Value, SizeOf(TDateTime));
end;

procedure TStream.WriteSingle(const Value: Single);
begin
  Write(Value, SizeOf(Single));
end;

procedure TStream.WriteDouble(const Value: Double);
begin
  Write(Value, SizeOf(Double));
end;

{ TCustomMemoryStream }

procedure _NewAlloc(Size: Integer; var Value: Pointer);
begin
{$IFDEF MSWINDOWS}
  Value := GlobalAllocPtr(HeapAllocFlags, Size);
{$ELSE}
  GetMem(Value, Size);
{$ENDIF}
end;

procedure _Resize(Size: Integer; var Value: Pointer);
begin
{$IFDEF MSWINDOWS}
  Value := GlobalReallocPtr(Value, Size, HeapAllocFlags);
{$ELSE}
  ReallocMem(Value, Size);
{$ENDIF}
end;

procedure _Free(var Value: Pointer);
begin
{$IFDEF MSWINDOWS}
  GlobalFreePtr(Value);
{$ELSE}
  FreeMem(Value);
{$ENDIF}
  Value := nil;
end;

procedure _Realloc(Size: Integer; var Value: Pointer);
begin
  if Size > 0 then
    if Value = nil then
      _NewAlloc(Size, Value)
    else
      _Resize(Size, Value)
  else if Value <> nil then
    _Free(Value);
end;

procedure TCustomMemoryStream.SetPointer(Ptr: Pointer; Size: Integer);
begin
  FMemory := Ptr;
  FSize := Size;
end;

function TCustomMemoryStream.Read(var Buffer; Count: Integer): Integer;
begin
  if (FPosition >= 0) and (Count >= 0) then
  begin
    Result := FSize - FPosition;
    if Result > 0 then
    begin
      if Result > Count then Result := Count;
      Move(Pointer(Longint(FMemory) + FPosition)^, Buffer, Result);
      Inc(FPosition, Result);
      Exit;
    end;
  end;
  Result := 0;
end;

function TCustomMemoryStream.Seek(Offset: Integer; Origin: TSeekOrigin): Integer;
begin
  case Origin of
    soBeginning: FPosition := Offset;
    soCurrent: Inc(FPosition, Offset);
    soEnd: FPosition := FSize + Offset;
  end;
  Result := FPosition;
end;

procedure TCustomMemoryStream.SaveToStream(Stream: TStream);
begin
  if FSize <> 0 then Stream.WriteBuffer(FMemory^, FSize);
end;

{ TMemoryStream }

const
  MemoryDelta = $2000; { Must be a power of 2 }

destructor TMemoryStream.Destroy;
begin
  Clear;
  inherited Destroy;
end;

procedure TMemoryStream.SetCapacity(NewCapacity: Integer);
begin
  SetPointer(Realloc(NewCapacity), FSize);
  FCapacity := NewCapacity;
end;

procedure TMemoryStream.SetSize(NewSize: Integer);
var
  OldPosition: Integer;
begin
  OldPosition := FPosition;
  SetCapacity(NewSize);
  FSize := NewSize;
  if OldPosition > NewSize then Seek(0, soEnd);
end;

function TMemoryStream.Realloc(var NewCapacity: Integer): Pointer;
begin
  if (NewCapacity > 0) and (NewCapacity <> FSize) then
    NewCapacity := (NewCapacity + (MemoryDelta - 1)) and not (MemoryDelta - 1);
  Result := Memory;
  if NewCapacity <> FCapacity then
  begin
    if NewCapacity = 0 then
      _Free(Result)
    else
    begin
      if Capacity = 0 then
        _NewAlloc(NewCapacity, Result)
      else
        _Resize(NewCapacity, Result);
      if Result = nil then raise EStreamError.CreateRes(@SMemoryStreamError);
    end;
  end;
end;

function TMemoryStream.Write(const Buffer; Count: Integer): Integer;
var
  Pos: Integer;
begin
  if (FPosition >= 0) and (Count >= 0) then
  begin
    Pos := FPosition + Count;
    if Pos > 0 then
    begin
      if Pos > FSize then
      begin
        if Pos > FCapacity then
          SetCapacity(Pos);
        FSize := Pos;
      end;
      System.Move(Buffer, Pointer(Longint(FMemory) + FPosition)^, Count);
      FPosition := Pos;
      Result := Count;
      Exit;
    end;
  end;
  Result := 0;
end;

procedure TMemoryStream.Clear;
begin
  SetCapacity(0);
  FSize := 0;
  FPosition := 0;
end;

procedure TMemoryStream.LoadFromStream(Stream: TStream);
var
  Count: Longint;
begin
  Stream.Position := 0;
  Count := Stream.Size;
  SetSize(Count);
  if Count <> 0 then Stream.ReadBuffer(FMemory^, Count);
end;

{ TMemStream }

constructor TMemStream.Create(Data: Pointer; DataSize: Integer);
begin
  SetPointer(Data, DataSize);
end;

function TMemStream.Write(const Buffer; Count: Integer): Integer;
begin
  raise EStreamError.CreateRes(@SStreamReadOnly);
end;

end.