btutils.pas

由delphi实现的bt下载器示例程序

  Add(pointer(result));
end;

function TBencodeDict.GetDictValue(AName: string): TBencodeDict;
var
  itm: TBencodeItem;
begin
  itm := Values[AName];
  if itm <> nil then
    result := itm.GetDictValue
  else result := nil;
end;

function TBencodeDict.GetIntValue(AName: string): Int64;
var
  itm: TBencodeItem;
begin
  itm := Values[AName];
  if itm <> nil then
    result := itm.GetIntValue
  else result := 0;
end;

function TBencodeDict.GetListValue(Aname: string): TBencodeList;
var
  itm: TBencodeItem;
begin
  itm := Values[Aname];
  if itm <> nil then result := itm.GetListValue else result := nil;
end;

function TBencodeDict.GetStrValue(AName: string): string;
var
  itm: TBencodeItem;
begin
  itm := Values[AName];
  if itm <> nil then result := itm.GetStrValue else result := '';
end;

{ TBTBits }

destructor TBTBits.Destroy;
begin
  clear;
  inherited;
end;

procedure TBTBits.Clear;
begin
  FSetCnt := 0;
  setsize(0);
end;

procedure TBTBits.ANDBits(const Buf; Cnt: Integer);
const
  BitCnt: array [0..15] of Integer = (0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4);
var
  i: Integer;
  p: PByteArray;
begin
  count := cnt;
  fsetcnt := 0;
  if cnt <> 0 then
  begin
    p := @Buf;
    for i := 0 to size - 1 do
    begin
      fbits[i] := fbits[i] and p[i];
      inc(fsetcnt, bitcnt[fbits[i] and $F]);
      inc(fsetcnt, bitcnt[fbits[i] shr 4]);
    end;
  end;
end;

procedure TBTBits.ANDBits(Bits: TBTBits);
begin
  if bits.FBits <> nil then
    andbits(bits.fbits^, bits.count);
end;

procedure TBTBits.ORBits(const Buf; Cnt: Integer);
const
  BitCnt: array [0..15] of Integer = (0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4);
var
  i: Integer;
  p: PByteArray;
begin
  count := cnt;
  fsetcnt := 0;
  if cnt <> 0 then
  begin
    p := @Buf;
    for i := 0 to size - 1 do
    begin
      fbits[i] := fbits[i] or p[i];
      inc(fsetcnt, bitcnt[fbits[i] and $F]);
      inc(fsetcnt, bitcnt[fbits[i] shr 4]);
    end;
  end;
end;

procedure TBTBits.ORBits(Bits: TBTBits);
begin
  if bits.FBits <> nil then
    orbits(bits.fbits^, bits.count);
end;

procedure TBTBits.XORBits(const Buf; Cnt: Integer);
const
  BitCnt: array [0..15] of Integer = (0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4);
var
  i: Integer;
  p: PByteArray;
begin
  count := cnt;
  fsetcnt := 0;
  if cnt <> 0 then
  begin
    p := @Buf;
    for i := 0 to size - 1 do
    begin
      fbits[i] := fbits[i] xor p[i];
      inc(fsetcnt, bitcnt[fbits[i] and $F]);
      inc(fsetcnt, bitcnt[fbits[i] shr 4]);
    end;
  end;
end;

procedure TBTBits.XORBits(Bits: TBTBits);
begin
  if bits.FBits <> nil then
    xorbits(bits.fbits^, bits.Count);
end;

procedure TBTBits.Invert(Cnt: Integer);
const
  bts: array [0..7] of byte = ($FF, $80, $C0, $E0, $F0, $F8, $FC, $FE);
  BitCnt: array [0..15] of Integer = (0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4);
var
  i, v: Integer;
  b: Byte;
begin
  //if cnt > count then
  count := cnt;
  fsetcnt := 0;
  v := (cnt + 7) div 8;
  b := cnt mod 8;
  for i := 0 to v - 1 do
  begin
    fbits[i] := not fbits[i];
    if i = v - 1 then
      fbits[i] := fbits[i] and bts[b];
    inc(fsetcnt, bitcnt[fbits[i] and $F]);
    inc(fsetcnt, bitcnt[fbits[i] shr 4]);
  end;
end;

function TBTBits.GetBitIndex(Flag: Boolean; Position: Integer): Integer;
var
  dst: Integer;
  p: PByteArray;
begin
  result := -1;
  if (position < 1) then exit;
  if flag and ((fsetcnt = 0) or (position > fsetcnt)) then exit;
  if not flag and ((fsetcnt = count) or (position > count - fsetcnt)) then exit;
  {n := 1;
  if randomPosition then
    if flag then n := random(fsetcnt) + 1
    else n := random(count-fsetcnt) + 1;}
  dst := size;
  p := FBits;
  asm
          PUSH    ESI
          PUSH    EBX
          MOV     EBX, dst
          MOV     EDX, Position
          MOV     ESI, p
  @Start:
          LODSB
          MOV     ECX, 8
  @Loop:
          CMP     Flag, 0
          JNZ     @BitSet
          SHL     AL, 1
          JNC     @Found
          JC      @GoOn
  @BitSet:
          SHL     AL, 1
          JNC     @GoOn
  @Found:
          DEC     EDX
          JZ      @CalcResult
  @GoOn:
          LOOP    @Loop
          DEC     EBX
          JZ      @End
          JNZ     @Start
  @CalcResult:
          SUB     EBX, dst
          NEG     EBX
          SHL     EBX, 3
          ADD     EBX, 8
          SUB     EBX, ECX
          MOV     Result, EBX
  @End:
          POP     EBX
          POP     ESI
  end;
end;

function TBTBits.GetBits(Index: Integer): Boolean;
const
  BitFlags: array [0..7] of byte = ($80, $40, $20, $10, $8, $4, $2, $1);
var
  n, x: Integer;
  b: Byte;
begin
  n := Index div 8;
  if n >= Size then result := false
  else begin
    x := Index mod 8;
    b := fbits[n];
    result := b and bitflags[x] <> 0;
  end;
end;

procedure TBTBits.SetBits(Index: Integer; const Value: Boolean);
const
  BitFlags: array [0..7] of byte = ($80, $40, $20, $10, $8, $4, $2, $1);
var
  n, x: Integer;
begin
  n := Index div 8;
  x := Index mod 8;
  if n >= size then size := n + 1;
  if bitflags[x] and fbits[n] <> 0 then dec(fsetcnt);
  if value then
  begin
    fbits[n] := fbits[n] or bitflags[x];
    inc(fsetcnt);
  end
  else
    fbits[n] := fbits[n] and (not bitflags[x]);
end;

function TBTBits.GetCount: Integer;
begin
  result := Fsize * 8;
end;

procedure TBTBits.SetCount(const Value: Integer);
begin
  setsize((value+7) div 8);
end;

procedure TBTBits.SetSize(const Value: Integer);
begin
  if Value <> FSize then
  begin
    reallocmem(fbits, value);
    if value > FSize then
      fillchar(fbits[fsize], value- fsize, 0);
    fsize := value;
  end;
end;

function TBTBits.ToString(Cnt: Integer): string;
begin
  if Cnt <= 0 then cnt := size
  else cnt := (cnt + 7) div 8;
  setlength(result, cnt);
  fillchar(result[1], length(result), 0);
  if cnt > size then cnt := size;
  move(fbits^, result[1], cnt);
end;

procedure TBTBits.FromString(Bits: string);
const
  BitCnt: array [0..15] of Integer = (0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4);
var
  i: Integer;
begin
  fsetcnt := 0;
  size := length(bits);
  for i := 1 to length(bits) do
  begin
    fbits[i-1] := byte(bits[i]);
    fsetcnt := fsetcnt + bitcnt[byte(bits[i]) and $f] + bitcnt[byte(bits[i]) shr 4];
  end;
end;

{ TBTInfo }

constructor TBTInfo.Create(AOwner: TBTMngr);
begin
  initializecriticalsection(flock);
  BitFlags:= TBTBits.Create;
  Clients := TStringList.Create;
  btext := true;
  Interval := 15000;
  owner := AOwner;
  //if aowner <> nil then
  //  workpath := aowner.WorkPath;
end;

destructor TBTInfo.Destroy;
begin
  BitFlags.Free;
  Clients.Free;
  inherited;
  deletecriticalsection(flock);
end;

procedure TBTInfo.Clear;
var
  i: Integer;
begin
  Registered:=false;
  for i := 0 to count - 1 do
    TBTFile(Items[i]).Free;
  inherited;
end;

function TBTInfo.Bencode: string;
var
  dict, info, fileinfo: TBencodeDict;
  files: TBencodeList;
  f: TBTFile;
  i: Integer;
  s: string;
  sha: TDCP_sha1;
begin
  result := '';
  if count = 0 then exit;
  dict := TBencodeDict.Create;
  dict.AddStr('announce', announce);
  dict.AddInt('creation date', createdate);
  if comment <> '' then
    dict.AddStr('comment', comment);
  info := dict.AddDict('info');
  if count = 1 then
  begin
    f := TBTFile(items[0]);
    info.addint('length', f.FileSize);
    info.AddStr('name', f.FileName);
    s := f.MakeComment;
    if s <> '' then
      info.AddStr('file info', s);
  end
  else begin
    files := info.AddList('files');
    for i := 0 to count - 1 do
    begin
      fileinfo := files.DictValue[files.AddDict];
      f := TBTFile(Items[i]);
      fileinfo.AddInt('length', f.FileSize);
      fileinfo.AddListDirect('path', f.bencodename);
      s := f.MakeComment;
      if s <> '' then
        fileinfo.AddStr('file info', s);
    end;
    info.AddStr('name', filepath);
  end;
  info.AddInt('piece length', Blocksize);
  info.AddStr('pieces', blocks);
  sha := TDCP_sha1.Create(nil);
  result := info.Bencode;
  sha.Init;
  sha.Update(result[1], length(result));
  sha.Final(infohash);
  sha.Free;
  result := dict.Bencode;
  dict.Free;
end;

procedure TBTInfo.Init(ADict: TBencodeDict);
var
  info: TBencodeDict;
  files: TBencodeList;
  i: Integer;
  s: string;
  sha: TDCP_sha1;
begin
  clear;
  self.TotalSize := 0;
  announce := adict.StrValue['announce'];
  comment := adict.StrValue['comment'];
  createdate := adict.IntValue['creation date'];
  info := adict.DictValue['info'];
  s := info.Bencode;
  sha := TDCP_sha1.Create(nil);
  sha.Init;
  sha.Update(s[1], length(s));
  sha.Final(infohash);
  sha.Free;
  blocksize := info.IntValue['piece length'];
  blocks := info.StrValue['pieces'];
  files := info.ListValue['files'];
  if files = nil then
  begin
    filepath := '';
    addfileinfo(info);
  end
  else begin
    filepath := info.StrValue['name'];
    for i := 0 to files.Count - 1 do
      addfileinfo(files.DictValue[i]);
  end;
  //initbitflags;
end;

procedure TBTInfo.AddFileInfo(AInfo: TBencodeDict);
var
  f: TBTFile;
  ps: TBencodeList;
begin
  f := TBTFile.Create;
  f.Parent := self;
  ps := ainfo.ListValue['path'];
  if ps = nil then
    f.FileName := ainfo.StrValue['name']
  else
    f.BdecodeName(ps);

  f.StartOff := self.TotalSize;
  f.FileSize := ainfo.IntValue['length'];
  TotalSize := TotalSize + f.FileSize;
  f.initinfo(ainfo.StrValue['file info']);
  f.Index := Add(pointer(f));
end;

procedure TBTInfo.InitBitFlags;
var
  sha: TDCP_sha1;
  h: TSHA1;
  f: TBTFile;
  buffer: string;
  ph: PSHA1Arr;
  i, n, l, cnt: Integer;
  off: Int64;
  bufchg: Boolean;
begin
  restsize := totalsize;
  AnalyzedSize := 0;
  //cnt := (TotalSize + BlockSize-1) div BlockSize;
  cnt := length(blocks) div sizeof(TSHA1);
  sha := TDCP_sha1.Create(nil);
  setlength(buffer, blocksize);
  ph := pointer(blocks);
  n := 0;
  off := 0;
  for i := 0 to cnt - 1 do
  begin
    l := 0;
    bufchg := false;
    while (l < length(buffer)) and (n < Count) do
    begin
      f := TBTFile(Items[n]);
      if f.readtobuffer(buffer[1], length(buffer), off, l, bufchg) then
      begin
        inc(n);
        off := 0;
      end;
      if i = count - 1 then break;
    end;
    if bufchg then
    begin
      //sha := TDCP_sha1.Create(nil);
      sha.Init;
      sha.Update(buffer[1], l);
      sha.Final(h);
      //sha.Free;
    end
    else fillchar(h, sizeof(TSHA1), 0);
    //if comparemem(@h, @(ph[i]), sizeof(TSHA1)) then
    if comparesha1(h, ph[i]) = 0 then
    begin
      bitflags.Bits[i] := true;
      restsize := restsize - l;
    end
    else begin
      bitflags.Bits[i] := false;
    end;
    analyzedsize := analyzedsize + l;
  end;
  sha.Free;
end;

function TBTInfo.BlockToFile(Blk: Integer; var Index: Integer;
  var FileOff: Int64): Boolean;
var
  b, e, c: Integer;
  i: Int64;
  f: TBTFile;
begin
  result := false;
  i := blk * BlockSize;
  b := 0;
  e := count - 1;
  while b <= e do
  begin
    c := (b + e) shr 1;
    f := TBTFile(Items[c]);
    if i < f.StartOff then
      e := c - 1
    else b := c + 1;
  end;
  if e >= 0 then
  begin
    result := true;
    Index := e;
    fileoff := i - TBTFile(Items[Index]).StartOff;
  end;
end;

procedure TBTInfo.LoadFromStream(AStream: TStream);
var
  i, l: Integer;
  f: TBTFile;
begin
  clear;
  astream.Read(InfoHash, 20);
  l := length(announce);
  astream.Read(l, 4);
  setlength(Announce, l);
  if l > 0 then
    astream.Read(announce[1], l);
  astream.Read(l, 4);
  setlength(Comment, l);
  if l > 0 then
    astream.Read(comment[1], l);
  astream.Read(CreateDate, 4);