首页 › Delphi/Pascal论坛 › bosn.pas

小兔子一点都不乖 發表於 2020-9-8 20:28:00

bosn.pas

<p>bosn.pas</p>
<div class="cnblogs_Highlighter">
<pre class="brush:csharp;gutter:true;">unit bson;
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
interface

uses
SysUtils,
Classes,
Contnrs;
{
BSON element format
&lt;type:byte&gt; &lt;c-str&gt; &lt;data&gt;
&lt;data&gt; below
}

const
BSON_EOF = $00;
BSON_FLOAT = $01; //double 8-byte float
BSON_STRING = $02; //UTF-8 string
BSON_DOC = $03; //embedded document
BSON_ARRAY = $04; //bson document but using integer string for key
BSON_BINARY = $05; //
BSON_UNDEFINED = $06; //deprecated
BSON_OBJECTID = $07; //
BSON_BOOLEAN = $08; //false:$00, true:$01
BSON_DATETIME = $09;
BSON_NULL = $0A;
BSON_REGEX = $0B; //
BSON_DBPTR = $0C; //deprecated
BSON_JS = $0D;
BSON_SYMBOL = $0E;
BSON_JSSCOPE = $0F;
BSON_INT32 = $10;
BSON_TIMESTAMP = $11;
BSON_INT64 = $12;
BSON_MINKEY = $FF;
BSON_MAXKEY = $7F;
{subtype}
BSON_SUBTYPE_FUNC = $01;
BSON_SUBTYPE_BINARY = $02;
BSON_SUBTYPE_UUID = $03;
BSON_SUBTYPE_MD5 = $05;
BSON_SUBTYPE_USER = $80;
{boolean constant}
BSON_BOOL_FALSE = $00;
BSON_BOOL_TRUE = $01;

const
nullterm: AnsiChar = #0;

type
EBSONException = class(Exception);
TBSONObjectID = array of byte;
TBSONDocument = class;
TBSONItem = class
protected
    eltype: byte;
    elname: string;
    fnull: boolean;

    procedure WriteDouble(Value: real); virtual;
    procedure WriteInteger(Value: integer); virtual;
    procedure WriteInt64(Value: Int64); virtual;
    procedure WriteBoolean(Value: Boolean); virtual;
    procedure WriteString(Value: string); virtual;
    procedure WriteOID(Value: TBSONObjectID); virtual;
    procedure WriteDocument(Value: TBSONDocument); virtual;
    procedure WriteItem(idx: integer; Value: TBSONItem); virtual;

    function ReadDouble: real; virtual;
    function ReadInteger: integer; virtual;
    function ReadInt64: Int64; virtual;
    function ReadBoolean: Boolean; virtual;
    function ReadString: string; virtual;
    function ReadOID: TBSONObjectID; virtual;
    function ReadDocument: TBSONDocument; virtual;
    function ReadItem(idx: integer): TBSONItem; virtual;
public
    constructor Create(etype: byte = BSON_NULL);

    procedure WriteStream(F: TStream); virtual;
    procedure ReadStream(F: TStream); virtual;

    function GetSize: longint; virtual;
    function ToString: string; virtual;

    function Clone: TBSONItem; virtual;

    function IsNull: boolean;
    property AsObjectID: TBSONObjectID read ReadOID write WriteOID;
    property AsInteger: integer read ReadInteger write WriteInteger;
    property AsDouble: real read ReadDouble write WriteDouble;
    property AsInt64: int64 read ReadInt64 write WriteInt64;
    property AsString: string read ReadString write WriteString;
    property AsBoolean: Boolean read ReadBoolean write WriteBoolean;
    property Items: TBSONItem read ReadItem write WriteItem;
    property Name: string read elname;
end;

TBSONDocument = class
    FItems: TObjectList;
    function GetItem(i: integer): TBSONItem;
    function GetValue(name: string): TBSONItem;
    procedure SetValue(Name: string; Value: TBSONItem);
    function GetCount: integer;
public
    constructor Create;
    destructor Destroy; override;

    procedure Clear;
    procedure ReadStream(F: TStream);
    procedure WriteStream(F: TStream);

    procedure LoadFromFile(filename: string);
    procedure SaveToFile(filename: string);

    function IndexOf(name: string): integer;
    function GetSize: longint;
    function Clone: TBSONDocument;

    function ToString: string;
    function HasItem(itemname: string): Boolean;

    property Items: TBSONItem read GetItem;
    property Values: TBSONItem read GetValue write SetValue;
    property Count: integer read GetCount;
end;

TBSONDoubleItem = class(TBSONItem)
    FData: real;

    procedure WriteDouble(AValue: real); override;
    function ReadDouble: real; override;
public
    constructor Create(AValue: real = 0.0);
    function GetSize: longint; override;

    function ToString: string; override;
    function Clone: TBSONItem; override;

    procedure ReadStream(F: TStream); override;
    procedure WriteStream(F: TStream); override;
end;

TBSONIntItem = class(TBSONItem)
    FData: integer;

    procedure WriteInteger(AValue: integer); override;
    function ReadInteger: integer; override;
public
    constructor Create(AValue: integer = 0);
    function GetSize: longint; override;

    function ToString: string; override;
    function Clone: TBSONItem; override;

    procedure ReadStream(F: TStream); override;
    procedure WriteStream(F: TStream); override;
end;

TBSONStringItem = class(TBSONItem)
protected
    FData: string;

    procedure WriteString(AValue: string); override;
    function ReadString: string; override;
public
    constructor Create(AValue: string = '');
    function GetSize: longint; override;

    function ToString: string; override;
    function Clone: TBSONItem; override;

    procedure ReadStream(F: TStream); override;
    procedure WriteStream(F: TStream); override;
end;

TBSONJSItem = class(TBSONStringItem)
public
    constructor Create(AValue: string = '');

    function Clone: TBSONItem; override;
end;

TBSONSymbolItem = class(TBSONStringItem)
public
    constructor Create(AValue: string = '');

    function Clone: TBSONItem; override;
end;

TBSONInt64Item = class(TBSONItem)
    FData: Int64;

    procedure WriteInt64(AValue: int64); override;
    function ReadInt64: Int64; override;
public
    constructor Create(AValue: Int64 = 0);
    function GetSize: longint; override;

    function ToString: string; override;
    function Clone: TBSONItem; override;

    procedure ReadStream(F: TStream); override;
    procedure WriteStream(F: TStream); override;
end;

TBSONBooleanItem = class(TBSONItem)
    FData: Boolean;

    procedure WriteBoolean(AValue: Boolean); override;
    function ReadBoolean: Boolean; override;
public
    constructor Create(AValue: Boolean = false);
    function GetSize: longint; override;

    function ToString: string; override;
    function Clone: TBSONItem; override;

    procedure ReadStream(F: TStream); override;
    procedure WriteStream(F: TStream); override;
end;

TBSONDocumentItem = class(TBSONItem)
    FData: TBSONDocument;
public
    constructor Create;
    destructor Destroy; override;
    function GetSize: longint; override;

    function ToString: string; override;
    function Clone: TBSONItem; override;

    procedure ReadStream(F: TStream); override;
    procedure WriteStream(F: TStream); override;
end;

TBSONArrayItem = class(TBSONItem)
    FData: TBSONDocument;

    procedure WriteItem(idx: integer; item: TBSONItem); override;
    function ReadItem(idx: integer): TBSONItem; override;
public
    constructor Create;
    destructor Destroy; override;
    function GetSize: longint; override;

    function ToString: string; override;
    function Clone: TBSONItem; override;

    procedure ReadStream(F: TStream); override;
    procedure WriteStream(F: TStream); override;
end;

TBSONDatetimeItem = class(TBSONItem)
    FData: TDatetime;
public
    constructor Create(AValue: TDateTime);
    function GetSize: longint; override;

    function ToString: string; override;
    function Clone: TBSONItem; override;

    procedure ReadStream(F: TStream); override;
    procedure WriteStream(F: TStream); override;
end;

TBSONBinaryItem = class(TBSONItem)
    FLen: integer;
    FSubtype: byte;
    FData: Pointer;
public
    constructor Create;
    destructor Destroy; override;
    function GetSize: longint; override;

    function ToString: string; override;
    function Clone: TBSONItem; override;

    procedure ReadStream(F: TStream); override;
    procedure WriteStream(F: TStream); override;
end;

TBSONObjectIDItem = class(TBSONItem)
    FData: TBSONObjectID;

    procedure WriteOID(AValue: TBSONObjectID); override;
    function ReadOID: TBSONObjectID; override;
public
    constructor Create(AValue: string = '000000000000');
    function GetSize: longint; override;

    function ToString: string; override;
    function Clone: TBSONItem; override;

    procedure ReadStream(F: TStream); override;
    procedure WriteStream(F: TStream); override;
end;

TBSONDBRefItem = class(TBSONStringItem)
    FValue: TBSONObjectID;
    procedure WriteOID(AValue: TBSONObjectID); override;
    function ReadOID: TBSONObjectID; override;
public
    constructor Create(AValue: string = ''; AData: string = '');
    function GetSize: longint; override;

    function ToString: string; override;
    function Clone: TBSONItem; override;

    procedure ReadStream(F: TStream); override;
    procedure WriteStream(F: TStream); override;
end;

TBSONRegExItem = class(TBSONItem)
    FPattern, FOptions: string;
public
    constructor Create(APattern: string = ''; AOptions: string = '');
    function GetSize: longint; override;

    function ToString: string; override;
    function Clone: TBSONItem; override;

    procedure ReadStream(F: TStream); override;
    procedure WriteStream(F: TStream); override;
end;

TBSONScopedJSItem = class(TBSONItem)
    FLen: integer;
    FCode: string;
    FScope: TBSONDocument;
public
    constructor Create;
    destructor Destroy; override;
    function GetSize: longint; override;

    function ToString: string; override;
    function Clone: TBSONItem; override;

    procedure ReadStream(F: TStream); override;
    procedure WriteStream(F: TStream); override;
end;

function _ReadString(F: TStream): string;

implementation

uses
DateUtils;

var
buf: array of AnsiChar;
nullitem: TBSONItem;

function _ReadString(F: TStream): string;
var
i: integer;
c: Ansichar;
begin
i := 0;
repeat
    f.read(c, sizeof(char));
    buf := c;
    inc(i);
until c = nullterm;
result := strpas(buf);
end;

{ TBSONDocument }

procedure TBSONDocument.Clear;
begin
FItems.Clear;
end;

function TBSONDocument.Clone: TBSONDocument;
var
i: integer;
begin
Result := TBSONDocument.Create;
for i := 0 to FItems.Count - 1 do begin
    Result.FItems.Add((FItems as TBSONItem).Clone);
end;
end;

constructor TBSONDocument.Create;
begin
FItems := TObjectlist.Create(true);
end;

destructor TBSONDocument.Destroy;
begin
FItems.Free;

inherited Destroy;
end;

function TBSONDocument.GetCount: integer;
begin
Result := FItems.Count;
end;

function TBSONDocument.GetItem(i: integer): TBSONItem;
begin
if i in then
    Result := (FItems as TBSONItem)
else
    Result := nullitem;
end;

function TBSONDocument.GetSize: longint;
var
i: integer;
begin
Result := 5;
for i := 0 to FItems.Count - 1 do begin
    Result := Result + (FItems as TBSONItem).GetSize;
end;
end;

function TBSONDocument.GetValue(name: string): TBSONItem;
var
i: integer;
begin
result := nullitem;
i := IndexOf(name);
if i &lt;&gt; -1 then Result := (FItems as TBSONItem);
end;

function TBSONDocument.HasItem(itemname: string): Boolean;
var
i: integer;
begin
Result := False;
for i := 0 to FItems.Count - 1 do begin
    if (FItems as TBSONItem).elname = itemname then begin
      Result := True;
      break;
    end;
end;
end;

function TBSONDocument.IndexOf(name: string): integer;
var
i: integer;
begin
Result := -1;
for i := 0 to FItems.Count - 1 do begin
    if (FItems as TBSONItem).elname = name then begin
      Result := i;
      break;
    end;
end;
end;

procedure TBSONDocument.LoadFromFile(filename: string);
var
f: TFileStream;
begin
f := TFileStream.Create(filename, fmOpenRead);
try
    ReadStream(f);
finally
    f.Free;
end;
end;

procedure TBSONDocument.ReadStream(F: TStream);
var
len: integer;
elmtype: byte;
elmname: string;
lastItem: TBSONItem;
begin
Clear;
f.Read(len, sizeof(len));
f.Read(elmtype, sizeof(byte));
while elmtype &lt;&gt; BSON_EOF do begin
    elmname := _ReadString(f);
    case elmtype of
      BSON_ARRAY: lastItem := TBSONArrayItem.Create;
      BSON_BINARY: lastItem := TBSONBinaryItem.Create;
      BSON_DBPTR: lastItem := TBSONDBRefItem.Create;
      BSON_FLOAT: lastItem := TBSONDoubleItem.Create;
      BSON_INT32: lastItem := TBSONIntItem.Create;
      BSON_INT64: lastItem := TBSONInt64Item.Create;
      BSON_BOOLEAN: lastItem := TBSONBooleanItem.Create;
      BSON_STRING: lastItem := TBSONStringItem.Create;
      BSON_DOC: lastItem := TBSONDocumentItem.Create;
      BSON_JS: lastItem := TBSONJSItem.Create;
      BSON_JSSCOPE: lastItem := TBSONScopedJSItem.Create;
      BSON_OBJECTID: lastItem := TBSONObjectIDItem.Create;
      BSON_MINKEY: lastItem := TBSONItem.Create(BSON_MINKEY);
      BSON_MAXKEY: lastItem := TBSONItem.Create(BSON_MAXKEY);
      BSON_REGEX: lastItem := TBSONRegExItem.Create;
      BSON_SYMBOL: lastItem := TBSONSymbolItem.Create;
      BSON_DATETIME: lastItem := TBSONDateTimeItem.Create(0);
    else
      raise EBSONException.Create('unimplemented element handler ' + inttostr(elmtype));
    end;
    with lastItem do begin
      elname := elmname;
      ReadStream(f);
    end;
    FItems.Add(lastItem);
    f.Read(elmtype, sizeof(byte));
end;
end;

procedure TBSONDocument.SaveToFile(filename: string);
var
f: TFileStream;
begin
{$IFDEF FPC}
f := TFileStream.Create(filename, fmOpenWrite);
{$ELSE}
f := TFileStream.Create(FileCreate(filename));
{$ENDIF}
try
    WriteStream(f);
finally
    f.Free;
end;
end;

procedure TBSONDocument.SetValue(Name: string; Value: TBSONItem);
var
item: TBSONItem;
idx: integer;
begin
idx := IndexOf(name);
if idx = -1 then begin
    Value.elname := Name;
    FItems.Add(Value)
end
else begin
    item := FItems as TBSONItem;
    if (item.eltype &lt;&gt; value.eltype) then begin
      FItems := Value;
      item.Free;
    end;
end;
end;

function TBSONDocument.ToString: string;
var
i, n: integer;
begin
Result := '{';
n := FItems.Count - 1;
for i := 0 to n do begin
    Result := Result + (FItems as TBSONItem).ToString;
    if i &lt; n then Result := Result + ', ';
end;
Result := Result + '}';
end;

procedure TBSONDocument.WriteStream(F: TStream);
var
dummy: integer;
i: integer;
begin
dummy := GetSize;
f.write(dummy, sizeof(dummy));
for i := 0 to FItems.Count - 1 do begin
    (FItems as TBSONItem).WriteStream(f);
end;
f.Write(nullterm, sizeof(nullterm));
end;

{ TBSONDoubleItem }

function TBSONDoubleItem.Clone: TBSONItem;
begin
Result := TBSONDoubleItem.Create(FData);
end;

constructor TBSONDoubleItem.Create(AValue: real);
begin
eltype := BSON_FLOAT;
FData := AValue;
end;

function TBSONDoubleItem.GetSize: longint;
begin
Result := 2 + length(elname) + sizeof(FData);
end;

function TBSONDoubleItem.ReadDouble: real;
begin
Result := FData;
end;

procedure TBSONDoubleItem.ReadStream(F: TStream);
begin
f.Read(FData, sizeof(FData));
end;

function TBSONDoubleItem.ToString: string;
begin
Result := format('"%s" : %f', );
end;

procedure TBSONDoubleItem.WriteDouble(AValue: real);
begin
FData := AValue;
end;

procedure TBSONDoubleItem.WriteStream(F: TStream);
begin
f.Write(eltype, sizeof(byte));
f.Write(elname, length(elname));
f.Write(nullterm, sizeof(nullterm));
f.Write(FData, sizeof(FData));
end;

{ TBSONIntItem }

function TBSONIntItem.Clone: TBSONItem;
begin
Result := TBSONIntItem.Create(FData);
end;

constructor TBSONIntItem.Create(AValue: integer);
begin
eltype := BSON_INT32;
FData := AValue;
end;

function TBSONIntItem.GetSize: longint;
begin
Result := 2 + length(elname) + sizeof(FData);
end;

function TBSONIntItem.ReadInteger: integer;
begin
result := FData;
end;

procedure TBSONIntItem.ReadStream(F: TStream);
begin
f.Read(fdata, sizeof(integer));
end;

function TBSONIntItem.ToString: string;
begin
Result := format('"%s" : %d', );
end;

procedure TBSONIntItem.WriteInteger(AValue: integer);
begin
FData := AValue;
end;

procedure TBSONIntItem.WriteStream(F: TStream);
begin
f.Write(eltype, sizeof(byte));
f.Write(elname, length(elname));
f.Write(nullterm, sizeof(nullterm));
f.Write(FData, sizeof(FData));
end;

{ TBSONStringItem }

function TBSONStringItem.Clone: TBSONItem;
begin
Result := TBSONStringItem.Create(FData);
end;

constructor TBSONStringItem.Create(AValue: string);
begin
eltype := BSON_STRING;
FData := AValue;
end;

function TBSONStringItem.GetSize: longint;
begin
Result := 7 + length(elname) + length(fdata);
end;

procedure TBSONStringItem.ReadStream(F: TStream);
var
len: integer;
begin
f.Read(len, sizeof(integer));
FData := _ReadString(F);
end;

function TBSONStringItem.ReadString: string;
begin
Result := FData;
end;

function TBSONStringItem.ToString: string;
begin
Result := format('"%s" : "%s"', );
end;

procedure TBSONStringItem.WriteStream(F: TStream);
var
len: integer;
begin
len := length(FData) + 1;
f.Write(eltype, sizeof(byte));
f.Write(elname, length(elname));
f.Write(nullterm, sizeof(nullterm));
f.Write(len, sizeof(integer));
f.Write(FData, length(FData));
f.Write(nullterm, sizeof(nullterm));
end;

procedure TBSONStringItem.WriteString(AValue: string);
begin
FData := AValue;
end;

{ TBSONInt64Item }

function TBSONInt64Item.Clone: TBSONItem;
begin
Result := TBSONInt64Item.Create(FData);
end;

constructor TBSONInt64Item.Create(AValue: Int64);
begin
eltype := BSON_INT64;
FData := AValue;
end;

function TBSONInt64Item.GetSize: longint;
begin
Result := 2 + length(elname) + sizeof(fdata);
end;

function TBSONInt64Item.ReadInt64: Int64;
begin
Result := FData;
end;

procedure TBSONInt64Item.ReadStream(F: TStream);
begin
f.Read(FData, sizeof(FData));
end;

function TBSONInt64Item.ToString: string;
begin
Result := format('"%s" : %d', );
end;

procedure TBSONInt64Item.WriteInt64(AValue: int64);
begin
FData := AValue;
end;

procedure TBSONInt64Item.WriteStream(F: TStream);
begin
f.Write(eltype, sizeof(byte));
f.Write(elname, length(elname));
f.Write(nullterm, sizeof(nullterm));
f.Write(FData, sizeof(FData));
end;

{ TBSONBooleanItem }

function TBSONBooleanItem.Clone: TBSONItem;
begin
Result := TBSONBooleanItem.Create(FData);
end;

constructor TBSONBooleanItem.Create(AValue: Boolean);
begin
eltype := BSON_BOOLEAN;
FData := AValue;
end;

function TBSONBooleanItem.GetSize: longint;
begin
Result := 3 + length(elname);
end;

function TBSONBooleanItem.ReadBoolean: Boolean;
begin
Result := FData;
end;

procedure TBSONBooleanItem.ReadStream(F: TStream);
var
b: Byte;
begin
f.Read(b, sizeof(byte));
FData := b = BSON_BOOL_TRUE
end;

function TBSONBooleanItem.ToString: string;
begin
Result := format('"%s" : %s', );
end;

procedure TBSONBooleanItem.WriteBoolean(AValue: Boolean);
begin
FData := AValue;
end;

procedure TBSONBooleanItem.WriteStream(F: TStream);
var
boolb: byte;
begin
f.Write(eltype, sizeof(byte));
f.Write(elname, length(elname));
f.Write(nullterm, sizeof(nullterm));
if FData then
    boolb := BSON_BOOL_TRUE
else
    boolb := BSON_BOOL_FALSE;
f.Write(boolb, sizeof(byte));
end;

{ TBSONItem }

function TBSONItem.Clone: TBSONItem;
begin
Result := TBSONItem.Create(eltype);
end;

constructor TBSONItem.Create(etype: byte);
begin
fnull := true;
eltype := etype;
end;

function TBSONItem.GetSize: longint;
begin
Result := 0;
if FNull then
    Result := 2 + Length(elName);
end;

function TBSONItem.IsNull: boolean;
begin
Result := FNull;
end;

function TBSONItem.ReadBoolean: Boolean;
begin
Result := False;
end;

function TBSONItem.ReadDocument: TBSONDocument;
begin
Result := nil;
end;

function TBSONItem.ReadDouble: real;
begin
Result := 0;
end;

function TBSONItem.ReadInt64: Int64;
begin
Result := 0;
end;

function TBSONItem.ReadInteger: integer;
begin
Result := 0;
end;

function TBSONItem.ReadItem(idx: integer): TBSONItem;
begin
Result := nullitem;
end;

function TBSONItem.ReadOID: TBSONObjectID;
begin
Result := Result;
end;

procedure TBSONItem.ReadStream(F: TStream);
begin

end;

function TBSONItem.ReadString: string;
begin
Result := '';
end;

function TBSONItem.ToString: string;
begin
Result := elname + ' : null';
end;

procedure TBSONItem.WriteBoolean(Value: Boolean);
begin

end;

procedure TBSONItem.WriteDocument(Value: TBSONDocument);
begin

end;

procedure TBSONItem.WriteDouble(Value: real);
begin

end;

procedure TBSONItem.WriteInt64(Value: Int64);
begin

end;

procedure TBSONItem.WriteInteger(Value: integer);
begin

end;

procedure TBSONItem.WriteItem(idx: integer; Value: TBSONItem);
begin

end;

procedure TBSONItem.WriteOID(Value: TBSONObjectID);
begin

end;

procedure TBSONItem.WriteStream(F: TStream);
begin
if FNull then begin
    f.Write(eltype, sizeof(byte));
    f.Write(elname, length(elname));
    f.Write(nullterm, sizeof(nullterm));
end;
end;

procedure TBSONItem.WriteString(Value: string);
begin

end;

{ TBSONDocumentItem }

function TBSONDocumentItem.Clone: TBSONItem;
var
item: TBSONDocumentItem;
begin
item := TBSONDocumentItem.Create;
item.FData.Free;
item.FData := FData.Clone;
Result := item;
end;

constructor TBSONDocumentItem.Create;
begin
FData := TBSONDocument.Create;
end;

destructor TBSONDocumentItem.Destroy;
begin
FData.Free;

inherited Destroy;
end;

function TBSONDocumentItem.GetSize: longint;
begin
Result := 2 + length(elname) + FData.GetSize;
end;

procedure TBSONDocumentItem.ReadStream(F: TStream);
begin
inherited;
FData.ReadStream(f);
end;

function TBSONDocumentItem.ToString: string;
begin
Result := format('"%s" : %s', );
end;

procedure TBSONDocumentItem.WriteStream(F: TStream);
begin
f.Write(eltype, sizeof(byte));
f.Write(elname, length(elname));
f.Write(nullterm, sizeof(nullterm));
FData.WriteStream(f);
end;

{ TBSONArrayItem }

function TBSONArrayItem.Clone: TBSONItem;
var
item: TBSONArrayItem;
begin
item := TBSONArrayItem.Create;
item.FData.Free;
item.FData := FData.Clone;
Result := Item;
end;

constructor TBSONArrayItem.Create;
begin
eltype := BSON_ARRAY;
FData := TBSONDocument.Create;
end;

destructor TBSONArrayItem.Destroy;
begin
FData.Free;

inherited Destroy;
end;

function TBSONArrayItem.GetSize: longint;
begin
Result := 2 + length(elname) + FData.GetSize;
end;

function TBSONArrayItem.ReadItem(idx: integer): TBSONItem;
begin
Result := FData.Items;
end;

procedure TBSONArrayItem.ReadStream(F: TStream);
begin
FData.ReadStream(F);
end;

function TBSONArrayItem.ToString: string;
var
i, n: integer;
tmp, t2: string;
begin
tmp := '';
n := FData.Count - 1;
for i := 0 to n do begin
    t2 := FData.Items.ToString;
    tmp := tmp + Copy(t2, Pos(':', t2) + 1, length(t2));
    if i &lt; n then tmp := tmp + ', ';
end;
Result := format('"%s" : [%s]', );
end;

procedure TBSONArrayItem.WriteItem(idx: integer; item: TBSONItem);
begin
inherited;
FData.SetValue(IntToStr(idx), item);
end;

procedure TBSONArrayItem.WriteStream(F: TStream);
begin
f.Write(eltype, sizeof(byte));
f.Write(elname, length(elname));
f.Write(nullterm, sizeof(nullterm));
FData.WriteStream(f);
end;

{ TBSONDatetimeItem }

function TBSONDatetimeItem.Clone: TBSONItem;
begin
Result := TBSONDateTimeItem.Create(FData);
end;

constructor TBSONDatetimeItem.Create(AValue: TDateTime);
begin
eltype := BSON_DATETIME;
FData := AValue;
end;

function TBSONDatetimeItem.GetSize: longint;
begin
result := 2 + length(elname) + sizeof(int64);
end;

procedure TBSONDatetimeItem.ReadStream(F: TStream);
var
data: int64;
begin
f.Read(data, sizeof(int64));
FData := UnixToDateTime(data);
end;

function TBSONDatetimeItem.ToString: string;
begin
Result := format('"%s" : %s', );
end;

procedure TBSONDatetimeItem.WriteStream(F: TStream);
var
data: Int64;
begin
data := DateTimeToUnix(FData);
f.Write(eltype, sizeof(byte));
f.Write(elname, length(elname));
f.Write(nullterm, sizeof(nullterm));
f.Write(Data, sizeof(int64));
end;

{ TBSONJSItem }

function TBSONJSItem.Clone: TBSONItem;
begin
Result := TBSONJSItem.Create(FData);
end;

constructor TBSONJSItem.Create(AValue: string);
begin
inherited Create(AValue);
eltype := BSON_JS;
end;

{ TBSONObjectIDItem }

function TBSONObjectIDItem.Clone: TBSONItem;
begin
Result := TBSONObjectIDItem.Create;
Result.AsObjectID := FData;
end;

constructor TBSONObjectIDItem.Create(AValue: string);
var
i: integer;
begin
eltype := BSON_OBJECTID;
if length(AValue) = 12 then
    for i := 0 to 11 do
      FData := StrToInt(AValue);
end;

function TBSONObjectIDItem.GetSize: longint;
begin
result := 2 + length(elname) + 12;
end;

function TBSONObjectIDItem.ReadOID: TBSONObjectID;
begin
Result := FData;
end;

procedure TBSONObjectIDItem.ReadStream(F: TStream);
begin
f.Read(FData, 12);
end;

function TBSONObjectIDItem.ToString: string;
begin
Result := format('"%s" : ObjectID("%s%s%s%s%s%s%s%s%s%s%s%s")', [elname,
    IntToHex(FData, 2),
      IntToHex(FData, 2),
      IntToHex(FData, 2),
      IntToHex(FData, 2),
      IntToHex(FData, 2),
      IntToHex(FData, 2),
      IntToHex(FData, 2),
      IntToHex(FData, 2),
      IntToHex(FData, 2),
      IntToHex(FData, 2),
      IntToHex(FData, 2),
      IntToHex(FData, 2)
      ]);
end;

procedure TBSONObjectIDItem.WriteOID(AValue: TBSONObjectID);
begin
FData := AValue;
end;

procedure TBSONObjectIDItem.WriteStream(F: TStream);
begin
f.Write(eltype, sizeof(byte));
f.Write(elname, length(elname));
f.Write(nullterm, sizeof(nullterm));
f.Write(FData, 12);
end;

{ TBSONRegExItem }

function TBSONRegExItem.Clone: TBSONItem;
begin
Result := TBSONRegExItem.Create(FPattern, FOptions);
end;

constructor TBSONRegExItem.Create(APattern, AOptions: string);
begin
FPattern := APattern;
FOptions := AOptions;
eltype := BSON_REGEX;
end;

function TBSONRegExItem.GetSize: longint;
begin
result := 2 + length(elname) + 1 + length(FPattern) + 1 + length(FOptions);
end;

procedure TBSONRegExItem.ReadStream(F: TStream);
begin
FPattern := _ReadString(f);
FOptions := _ReadString(f);
end;

function TBSONRegExItem.ToString: string;
begin
Result := format('"%s" : "%s" "%s"', );
end;

procedure TBSONRegExItem.WriteStream(F: TStream);
begin
f.Write(eltype, sizeof(byte));
f.Write(elname, length(elname));
f.Write(nullterm, sizeof(nullterm));
f.Write(FPattern, length(FPattern));
f.Write(nullterm, sizeof(nullterm));
f.Write(FOptions, length(FOptions));
f.Write(nullterm, sizeof(nullterm));
end;

{ TBSONBinaryItem }

function TBSONBinaryItem.Clone: TBSONItem;
var
ms: TMemoryStream;
begin
Result := TBSONBinaryItem.Create;
ms := TMemoryStream.Create;
try
    WriteStream(ms);
    ms.Seek(0, soFromBeginning);
    Result.ReadStream(ms);
finally
    ms.Free;
end;
end;

constructor TBSONBinaryItem.Create;
begin
FLen := 0;
FData := nil;
FSubtype := BSON_SUBTYPE_USER;
eltype := BSON_BINARY;
end;

destructor TBSONBinaryItem.Destroy;
begin
if FLen &lt;&gt; 0 then
    FreeMem(FData);

inherited Destroy;
end;

function TBSONBinaryItem.GetSize: longint;
begin
result := 2 + length(elname) + 4 + 1 + FLen;
end;

procedure TBSONBinaryItem.ReadStream(F: TStream);
begin
f.Read(FLen, sizeof(integer));
f.Read(FSubtype, sizeof(byte));
GetMem(FData, FLen);
f.Read(FData^, Flen);
end;

function TBSONBinaryItem.ToString: string;
begin
Result := format('"%s" : %s', );
end;

procedure TBSONBinaryItem.WriteStream(F: TStream);
begin
f.Write(eltype, sizeof(byte));
f.Write(elname, length(elname));
f.Write(nullterm, sizeof(nullterm));

f.Write(FLen, sizeof(integer));
f.Write(FSubtype, sizeof(byte));
f.Write(FData^, FLen);
end;


{ TBSONScopedJSItem }

function TBSONScopedJSItem.Clone: TBSONItem;
var
item: TBSONScopedJSItem;
begin
item := TBSONScopedJSItem.Create;
item.FCode := FCode;
item.FLen := FLen;
item.FScope.Free;
item.FScope := FScope.Clone;
Result := item;
end;

constructor TBSONScopedJSItem.Create;
begin
eltype := BSON_JSSCOPE;
FScope := TBSONDocument.Create;
end;

destructor TBSONScopedJSItem.Destroy;
begin
FScope.Free;

inherited Destroy;
end;

function TBSONScopedJSItem.GetSize: longint;
begin
result := 2 + length(elname) + 4 + length(fcode) + 1 + FScope.GetSize;
end;

procedure TBSONScopedJSItem.ReadStream(F: TStream);
begin
f.Read(Flen, sizeof(integer));
FCode := _ReadString(f);
FScope.ReadStream(f);
end;

function TBSONScopedJSItem.ToString: string;
begin
Result := format('"%s" : "%s" %s', );
end;

procedure TBSONScopedJSItem.WriteStream(F: TStream);
begin
f.Write(eltype, sizeof(byte));
f.Write(elname, length(elname));
f.Write(nullterm, sizeof(nullterm));
FLen := FScope.GetSize + 5 + length(FCode);
f.Write(FLen, sizeof(integer));
f.Write(FCode, length(FCode));
f.Write(nullterm, sizeof(nullterm));
FScope.WriteStream(f);
end;

{ TBSONSymbolItem }

function TBSONSymbolItem.Clone: TBSONItem;
begin
Result := TBSONSymbolItem.Create(FData);
end;

constructor TBSONSymbolItem.Create(AValue: string);
begin
eltype := BSON_SYMBOL;
end;

{ TBSONDBRefItem }

function TBSONDBRefItem.Clone: TBSONItem;
begin
Result := TBSONDBRefItem.Create(FData);
Result.AsObjectID := FValue;
end;

constructor TBSONDBRefItem.Create(AValue, AData: string);
var
i: integer;
begin
inherited Create(AValue);
eltype := BSON_DBPTR;
if length(AData) = 12 then
    for i := 0 to 11 do
      FValue := StrToInt(AData);
end;

function TBSONDBRefItem.GetSize: longint;
begin
result := 3 + length(elname) + length(FData) + 12;
end;

function TBSONDBRefItem.ReadOID: TBSONObjectID;
begin
Result := FValue;
end;

procedure TBSONDBRefItem.ReadStream(F: TStream);
begin
inherited;
f.Read(FValue, 12);
end;

function TBSONDBRefItem.ToString: string;
begin
Result := format('"%s" : DBRef("%s", "%s%s%s%s%s%s%s%s%s%s%s%s")', [elname,
    FData,
      IntToHex(FValue, 2),
      IntToHex(FValue, 2),
      IntToHex(FValue, 2),
      IntToHex(FValue, 2),
      IntToHex(FValue, 2),
      IntToHex(FValue, 2),
      IntToHex(FValue, 2),
      IntToHex(FValue, 2),
      IntToHex(FValue, 2),
      IntToHex(FValue, 2),
      IntToHex(FValue, 2),
      IntToHex(FValue, 2)
      ]);
end;

procedure TBSONDBRefItem.WriteOID(AValue: TBSONObjectID);
begin
FValue := AValue;
end;

procedure TBSONDBRefItem.WriteStream(F: TStream);
begin
inherited;
f.Write(FValue, 12);
end;

initialization
nullitem := TBSONItem.Create;
finalization
nullitem.Free;
end.
</pre>
</div>
<p>　　调用：</p>
<div class="cnblogs_Highlighter">
<pre class="brush:csharp;gutter:true;">procedure TForm1.Button1Click(Sender: TObject);
begin
var doc: TBSONDocument := TBSONDocument.Create;
var item: TBSONStringItem := TBSONStringItem.Create('test');
doc.SetValue('str', item);
var item2: TBSONDatetimeItem := TBSONDatetimeItem.Create(now);
doc.setvalue('datetime', item2);
memo1.Text := doc.ToString;
end;
</pre>
</div>
<p>　　<img src="https://img2020.cnblogs.com/blog/368779/202009/368779-20200908202754760-1237913674.png"></p>

</div>
<div id="MySignature" role="contentinfo">
    <p>本文来自博客园，作者：{咏南中间件}，转载请注明原文链接：https://www.cnblogs.com/hnxxcxg/p/13635108.html</p><br><br>
来源：https://www.cnblogs.com/hnxxcxg/p/13635108.html

查看完整版本: bosn.pas