unit Licensing.VMProtect;

interface

{$IFDEF FPC}
  {$MODE DELPHI}
  {$RANGECHECKS OFF}
  {$OVERFLOWCHECKS OFF}
{$ELSE}
  {$WEAKLINKRTTI ON}
  {$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])}
{$ENDIF}

uses
  {$IFDEF FPC}
  Base64, Classes, SysUtils, Sha1, Md5;
  {$ELSE}
  System.NetEncoding, System.Classes, System.SysUtils, System.WideStrUtils,
  System.Hash;
  {$ENDIF}

const
  BuildDate = {$I BuildDate.inc};

type
  TVMProtectDate = packed record
    wYear: Word;
    bMonth: Byte;
    bDay: Byte;
  end;

  PVMProtectSerialNumberData = ^TVMProtectSerialNumberData;
  TVMProtectSerialNumberData = packed record
    nState: Longword;
    wUserName: array [0..255] of WideChar;
    wEMail: array [0..255] of WideChar;
    dtExpire: TVMProtectDate;
    dtMaxBuild: TVMProtectDate;
    bRunningTime: Longword;
    nUserDataLength: Byte;
    bUserData: array [0..254] of Byte;
  end;

const
  SERIAL_STATE_SUCCESS                 = 0;
  SERIAL_STATE_FLAG_CORRUPTED            = $00000001;
  SERIAL_STATE_FLAG_INVALID           = $00000002;
  SERIAL_STATE_FLAG_BLACKLISTED           = $00000004;
  SERIAL_STATE_FLAG_DATE_EXPIRED       = $00000008;
  SERIAL_STATE_FLAG_RUNNING_TIME_OVER  = $00000010;
  SERIAL_STATE_FLAG_BAD_HWID           = $00000020;
  SERIAL_STATE_FLAG_MAX_BUILD_EXPIRED  = $00000040;

type
  LbIntBuf = packed record
    dwLen: Integer;
    pBuf: PByte;
  end;

  LbInteger = packed record
    bSign: Boolean;
    dwUsed: Integer;
    IntBuf: LbIntBuf;
  end;

  { TSerialDecoder }

  TSerialDecoder = class
  private
    FSerialNum: TBytes;
    FPublicExp: TBytes;
    FPublicMod: TBytes;
    FProductCode: UInt64;
    FSerialNumberData: TVMProtectSerialNumberData;
    procedure CheckSerialBlackList;
    function GetDecodedBytes: TBytes;
    function GetBytesFromBase64(const Value: string): TBytes;
    function GetLargeIntFromBytes(const Bytes: TBytes): LbInteger;
    function GetBytesFromLargeInt(const Value: LbInteger): TBytes;
  protected
    function GetBuildDate: TDate; virtual;
  public
    procedure SetPublicExp(const Value: string);
    procedure SetPublicMod(const Value: string);
    procedure SetSerialNum(const Value: string);
    procedure SetProductCode(const Value: UInt64);
    function VMProtectSetSerialNumber(const SerialNumber: string): LongWord;
    function VMProtectGetSerialNumberData(Data: PVMProtectSerialNumberData;
      DataSize: Integer): Boolean;
  end;

implementation

const
  cLESS_THAN = ShortInt(-1);
  cEQUAL_TO = ShortInt(0);
  cGREATER_THAN = ShortInt(1);
  cPOSITIVE = True;
  cNEGATIVE = False;

const
  cBYTE_POSSIBLE_VALUES = 256;
  cDEFAULT_PRECISION = 64;
  cUSE_DEFAULT_PRECISION = 0;
  cDEFAULT_SIGN = cPOSITIVE;
  cDEFAULT_USED = 0;
  cAPPEND_ARRAY = 0;
  cPREPEND_ARRAY = 1;

const
  sBIBufferNotAssigned = 'Buffer not assigned';
  sBINoNumber = 'No number';
  sBISubtractErr = 'Subtraction error';
  sBIZeroDivide = 'Division by zero';
  sBIQuotientErr = 'Quotient process error';
  sBIZeroFactor = 'Factor is zero';

type
  PBiByteArray = ^TBiByteArray;
  TBiByteArray = array [0..Pred(MaxInt)] of Byte;

{$IFNDEF FPC}
type
  TBytesStream = class(System.Classes.TBytesStream)
  public
    function ReadByte: Byte;
    function ReadWord: Word;
    function ReadDWord: UInt32;
    function ReadQWord: UInt64;
  end;
{$ENDIF}

procedure LbBiInit(out N1: LbInteger; const Precision: Integer);
begin
  N1 := Default(LbInteger);
  if Precision > 0 then
    N1.IntBuf.dwLen := Precision
  else
    N1.IntBuf.dwLen := cDEFAULT_PRECISION;

  N1.bSign := cDEFAULT_SIGN;
  N1.dwUsed := cDEFAULT_USED;

  N1.IntBuf.pBuf := PByte(AllocMem(N1.IntBuf.dwLen));
end;

procedure LbBiTrimSigZeros(var N1: LbInteger);
begin
  if (not Assigned(N1.IntBuf.pBuf)) then
    raise Exception.Create(sBIBufferNotAssigned);

  while (PBiByteArray(N1.IntBuf.pBuf)[Pred(N1.dwUsed)] = 0) do
  begin
    Dec(N1.dwUsed);
    if (N1.dwUsed <= 0) then
    begin
      N1.dwUsed := 1;
      Exit;
    end;
  end;
end;

procedure LbBiRealloc(var N1: LbInteger; const Len: Integer);
var
  TmpPtr: PByte;
begin
  if (N1.dwUsed > Len) then
    Exit;
  TmpPtr := AllocMem(Len);
  move(N1.IntBuf.pBuf^, TmpPtr^, N1.dwUsed);
  FreeMem(N1.IntBuf.pBuf);
  N1.IntBuf.dwLen := Len;
  N1.IntBuf.pBuf := TmpPtr;
end;

procedure LbBiClear(var N1: LbInteger);
begin
  N1.bSign := cDEFAULT_SIGN;
  N1.dwUsed := cDEFAULT_USED;
  FillChar(N1.IntBuf.pBuf^, N1.IntBuf.dwLen, $00);
end;

function LbBiIsZero(N1: LbInteger): Boolean;
begin
  LbBiTrimSigZeros(N1);
  Result := False;
  if (N1.dwUsed = 1) and (PBiByteArray(N1.IntBuf.pBuf)[0] = 0) then
    Result := True
end;

procedure LbBiAddByte(var N1: LbInteger; const Place: Integer;
  const ByteValue: Byte);
begin
  if (Place = cAPPEND_ARRAY) then
  begin
    if (Succ(N1.dwUsed) > N1.IntBuf.dwLen) then
      LbBiRealloc(N1, Succ(N1.dwUsed));
    PBiByteArray(N1.IntBuf.pBuf)[N1.dwUsed] := ByteValue;
    Inc(N1.dwUsed);
  end
  else
  begin
    if (Place > N1.IntBuf.dwLen) then
      LbBiRealloc(N1, Place);
    PBiByteArray(N1.IntBuf.pBuf)[Pred(Place)] := ByteValue;
    if (N1.dwUsed < Place) then
      N1.dwUsed := Place;
  end;
end;

function LbBiGetByteValue(const N1: LbInteger; const Place: Integer): Byte;
begin
  if (N1.dwUsed < Place) then
  begin
    Result := 0;
    Exit;
  end;
  Result := PBiByteArray(N1.IntBuf.pBuf)[Pred(Place)];
end;

function LbBiReverseBits(ByteValue: Byte): Byte;
var
  I: Byte;
  RBit: Byte;
begin
  Result := 0;
  RBit := $80;
  for I := 1 to 8 do
  begin
    if ((ByteValue and $01) <> 0) then
      Result := Result or RBit;
    RBit := RBit shr 1;
    ByteValue := ByteValue shr 1;
  end;
end;

function LbBiIsOne(N1: LbInteger): Boolean;
begin
  LbBiTrimSigZeros(N1);
  Result := False;
  if (N1.dwUsed = 1) and (PBiByteArray(N1.IntBuf.pBuf)[0] = 1) then
    Result := True
end;

procedure LbBiCopy(var Dest: LbInteger; const Src: LbInteger;
  const Len: Integer);
var
  Ptr: PByte;
  Size: Integer;
begin
  FillChar(Dest.IntBuf.pBuf^, Dest.IntBuf.dwLen, $00);

  Size := Integer(Len);

  if Size > Dest.IntBuf.dwLen then
    LbBiRealloc(Dest, Size);

  Ptr := Dest.IntBuf.pBuf;
  move(Src.IntBuf.pBuf^, Ptr^, Len);

  if (Dest.dwUsed < Size) then
    Dest.dwUsed := Size;
end;

function MultSpecialCase(const N1: LbInteger; const N2: LbInteger;
  var Product: LbInteger): Boolean;
begin
  Result := False;

  if (LbBiIsZero(N1) or LbBiIsZero(N2)) then
  begin
    LbBiAddByte(Product, cPREPEND_ARRAY, $00);
    Result := True;
    Exit;
  end;

  if (LbBiIsOne(N1)) then
  begin
    Product.dwUsed := N2.dwUsed;

    if (Product.IntBuf.dwLen < N2.IntBuf.dwLen) then
      LbBiRealloc(Product, N2.IntBuf.dwLen);

    LbBiCopy(Product, N2, N2.dwUsed);
    Result := True;
    Exit;
  end;

  if (LbBiIsOne(N2)) then
  begin
    Product.dwUsed := N1.dwUsed;

    if (Product.IntBuf.dwLen < N1.IntBuf.dwLen) then
      LbBiRealloc(Product, N1.IntBuf.dwLen);

    LbBiCopy(Product, N1, N1.dwUsed);
    Result := True;
  end;
end;

procedure LbBiMultBase(N1: LbInteger; const N2: LbInteger;
  var Product: LbInteger);
var
  InxX: Integer;
  InxY: Integer;
  MaxX: Integer;
  Carry: Integer;
  Prd: Integer;
  Plc: Integer;
  TmpByte: Byte;
  TmpInt: Integer;
begin
  if (MultSpecialCase(N1, N2, Product)) then
    Exit;
  MaxX := Pred(N1.dwUsed);
  TmpInt := Pred(N2.dwUsed);
  for InxY := 0 to TmpInt do
  begin
    if PBiByteArray(N2.IntBuf.pBuf)[InxY] <> 0 then
    begin
      Carry := 0;
      for InxX := 0 to MaxX do
      begin
        Plc := InxX + InxY;
        Prd := PBiByteArray(N1.IntBuf.pBuf)[InxX];
        Prd := Prd * PBiByteArray(N2.IntBuf.pBuf)[InxY];
        if (Product.dwUsed < Plc) then
          Prd := Prd + Carry
        else
          Prd := Prd + PBiByteArray(Product.IntBuf.pBuf)[Plc] + Carry;

        TmpByte := Prd and $00FF;
        Carry := Prd shr 8;

        if (Succ(Plc) > Product.IntBuf.dwLen) then
          LbBiRealloc(Product, Plc + 100);
        PBiByteArray(Product.IntBuf.pBuf)[Plc] := TmpByte;
        if (Product.dwUsed < Succ(Plc)) then
          N1.dwUsed := Succ(Plc);
      end;
      LbBiAddByte(Product, (MaxX + InxY + 2), Carry);
    end;
  end;
  LbBiTrimSigZeros(Product);
end;

procedure LbBiMult(const N1, N2: LbInteger; var Product: LbInteger);
begin
  LbBiMultBase(N1, N2, Product);
  if (N1.bSign = N2.bSign) then
    Product.bSign := cPOSITIVE
  else
    Product.bSign := cNEGATIVE;
end;

procedure LbBiFree(var N1: LbInteger);
begin
  if (Assigned(N1.IntBuf.pBuf)) then
    FreeMem(N1.IntBuf.pBuf);
  FillChar(N1, SizeOf(LbInteger), $00);
end;

procedure LbBiMultInPlace(var N1: LbInteger; const N2: LbInteger);
var
  Product: LbInteger;
  Precis: Integer;
begin
  Precis := (N1.dwUsed + N2.dwUsed) * 2;
  LbBiInit(Product, Precis);
  LbBiMult(N1, N2, Product);
  LbBiClear(N1);
  N1.dwUsed := Product.dwUsed;
  N1.bSign := Product.bSign;
  if (N1.IntBuf.dwLen < Product.IntBuf.dwLen) then
    LbBiRealloc(N1, Product.IntBuf.dwLen);
  LbBiCopy(N1, Product, Product.dwUsed);
  LbBiFree(Product);
end;

function LbBiFindFactor(B1: Byte): Byte;
begin
  Result := 1;
  while (B1 < $80) do
  begin
    B1 := (B1 shl 1);
    Result := Result * 2;
  end;
end;

procedure LbBiMulByDigitBase(N1: LbInteger; const N2: Byte;
  var Product: LbInteger);
var
  Count: Integer;
  Carry: Byte;
  Prd: WORD;
  TmpByte: Byte;
  TmpInt: Integer;
begin
  if (N2 = 1) then
  begin
    if (Product.IntBuf.dwLen < N1.IntBuf.dwLen) then
      LbBiRealloc(Product, N1.IntBuf.dwLen);
    Product.dwUsed := N1.dwUsed;
    Product.bSign := N1.bSign;
    LbBiCopy(Product, N1, N1.dwUsed);
  end;

  if (N2 = 0) then
  begin
    Product.dwUsed := 1;
    LbBiAddByte(Product, cPREPEND_ARRAY, 0);
  end;

  if LbBiIsOne(N1) then
  begin
    Product.dwUsed := 1;
    LbBiAddByte(Product, cPREPEND_ARRAY, N2);
  end;
  if (N1.dwUsed = 1) and (PBiByteArray(N1.IntBuf.pBuf)[0] = 0) then
  begin
    Product.dwUsed := 1;
    LbBiAddByte(Product, cPREPEND_ARRAY, 0);
  end;

  Carry := 0;
  TmpInt := Pred(N1.dwUsed);
  for Count := 0 to TmpInt do
  begin
    Prd := (PBiByteArray(N1.IntBuf.pBuf)[Count] * N2) + Carry;
    TmpByte := Prd and $00FF;
    Carry := Prd shr 8;
    PBiByteArray(Product.IntBuf.pBuf)[Count] := TmpByte;
    if (Product.dwUsed < Succ(Count)) then
      N1.dwUsed := Succ(Count);
  end;
  LbBiAddByte(Product, Succ(N1.dwUsed), Carry);
  LbBiTrimSigZeros(Product);
end;

procedure LbBiMulByDigit(const N1: LbInteger; const N2: Byte;
  var Product: LbInteger);
begin
  LbBiMulByDigitBase(N1, N2, Product);
  Product.bSign := N1.bSign;
end;

procedure LbBiMulByDigitInPlace(var N1: LbInteger; const N2: Byte);
var
  Product: LbInteger;
  Precis: Integer;
begin
  Precis := (N1.dwUsed + 1) * 2;
  LbBiInit(Product, Precis);
  try
    LbBiMulByDigit(N1, N2, Product);
    if (N1.IntBuf.dwLen < Product.IntBuf.dwLen) then
      LbBiRealloc(N1, Product.IntBuf.dwLen);
    N1.bSign := Product.bSign;
    N1.dwUsed := Product.dwUsed;
    LbBiCopy(N1, Product, Product.dwUsed);
  finally
    LbBiFree(Product);
  end;
end;

procedure LbBiMove(var Fest: LbInteger; const Src: LbInteger;
  const Place, Len: Integer);
var
  Ptr: PByte;
  Size: Integer;
begin
  if (not Assigned(Fest.IntBuf.pBuf)) then
    raise Exception.Create(sBIBufferNotAssigned);

  if (Place = cAPPEND_ARRAY) then
  begin
    if ((Integer(Len) + Fest.dwUsed) > Fest.IntBuf.dwLen) then
      LbBiRealloc(Fest, (Integer(Len) + Fest.dwUsed));

    Ptr := Fest.IntBuf.pBuf;
    Inc(Ptr, Fest.dwUsed);
    move(Src.IntBuf.pBuf^, Ptr^, Len);
    Inc(Fest.dwUsed, Len);
  end
  else
  begin
    Size := Pred(Place) + Integer(Len);
    if Size > Fest.IntBuf.dwLen then
      LbBiRealloc(Fest, Size);
    Ptr := Fest.IntBuf.pBuf;
    Inc(Ptr, Pred(Place));
    move(Src.IntBuf.pBuf^, Ptr^, Len);
    if (Fest.dwUsed < Size) then
      Fest.dwUsed := Size;
  end;
end;

function LbBiCompare(N1, N2: LbInteger): ShortInt;
var
  Count: Integer;
begin
  LbBiTrimSigZeros(N1);
  LbBiTrimSigZeros(N2);
  if (N1.bSign <> N2.bSign) then
  begin
    if (N1.bSign = cPOSITIVE) then
      Result := cGREATER_THAN
    else
      Result := cLESS_THAN;
    Exit;
  end;

  if (N1.dwUsed <> N2.dwUsed) then
  begin
    if (N1.dwUsed > N2.dwUsed) then
    begin
      Result := cGREATER_THAN;
      Exit;
    end
    else
    begin
      Result := cLESS_THAN;
      Exit;
    end;
  end;

  Count := N1.dwUsed;
  while PBiByteArray(N1.IntBuf.pBuf)[Pred(Count)] = PBiByteArray(N2.IntBuf.pBuf)
    [Pred(Count)] do
  begin
    Dec(Count);
    if (Count = 0) then
    begin
      Result := cEQUAL_TO;
      Exit;
    end;
  end;

  if PBiByteArray(N1.IntBuf.pBuf)[Pred(Count)] > PBiByteArray(N2.IntBuf.pBuf)
    [Pred(Count)] then
    Result := cGREATER_THAN
  else
    Result := cLESS_THAN;
end;

procedure LbBiFindLargestUsed(const N1, N2: LbInteger; out Count: Integer);
begin
  if (N1.dwUsed >= N2.dwUsed) then
    Count := N1.dwUsed
  else
    Count := N2.dwUsed;
end;

procedure LbBiAddBase(const N1, N2: LbInteger; var Sum: LbInteger);
var
  Carry: Byte;
  I: Integer;
  Count: Integer;
  TempWord: WORD;
  TempByte: Byte;
begin
  LbBiFindLargestUsed(N1, N2, Count);

  if (LbBiIsZero(N1)) then
  begin
    LbBiCopy(Sum, N2, N2.dwUsed);
    Exit;
  end;

  if (LbBiIsZero(N2)) then
  begin
    LbBiCopy(Sum, N1, N1.dwUsed);
    Exit;
  end;

  Carry := 0;
  if (Succ(Count) > Sum.dwUsed) then
    LbBiRealloc(Sum, Succ(Count));
  for I := 1 to Count do
  begin
    TempWord := LbBiGetByteValue(N1, I) + LbBiGetByteValue(N2, I) + Carry;
    TempByte := TempWord and $00FF;
    Carry := TempWord shr 8;
    PBiByteArray(Sum.IntBuf.pBuf)[Sum.dwUsed] := TempByte;
    Inc(Sum.dwUsed);
  end;
  LbBiAddByte(Sum, cAPPEND_ARRAY, Carry);
  LbBiTrimSigZeros(Sum);
end;

function LbBiAbs(N1, N2: LbInteger): ShortInt;
var
  Count: Integer;
begin
  LbBiTrimSigZeros(N1);
  LbBiTrimSigZeros(N2);

  if (N1.dwUsed <> N2.dwUsed) then
  begin
    if (N1.dwUsed > N2.dwUsed) then
    begin
      Result := cGREATER_THAN;
      Exit;
    end
    else
    begin
      Result := cLESS_THAN;
      Exit;
    end;
  end;

  Count := N1.dwUsed;
  while PBiByteArray(N1.IntBuf.pBuf)[Pred(Count)] = PBiByteArray(N2.IntBuf.pBuf)
    [Pred(Count)] do
  begin
    Dec(Count);
    if (Count = 0) then
    begin
      Result := cEQUAL_TO;
      Exit;
    end;
  end;

  if PBiByteArray(N1.IntBuf.pBuf)[Pred(Count)] > PBiByteArray(N2.IntBuf.pBuf)
    [Pred(Count)] then
    Result := cGREATER_THAN
  else
    Result := cLESS_THAN;
end;

procedure LbBiSubBase(const N1, N2: LbInteger; var Diff: LbInteger);
var
  TempInt: Integer;
  Borrow: WORD;
  Count: Integer;
  I: Integer;
begin
  if (LbBiIsZero(N1)) then
  begin
    LbBiCopy(Diff, N2, N2.dwUsed);
    Exit;
  end;

  if (LbBiIsZero(N2)) then
  begin
    LbBiCopy(Diff, N1, N1.dwUsed);
    Exit;
  end;

  Borrow := 0;
  I := Pred(N1.dwUsed);
  for Count := 0 to I do
  begin
    TempInt := PBiByteArray(N1.IntBuf.pBuf)[Count];
    if (N2.dwUsed < Succ(Count)) then
      TempInt := TempInt - Borrow
    else
      TempInt := TempInt - (PBiByteArray(N2.IntBuf.pBuf)[Count] + Borrow);

    if (TempInt < 0) then
    begin
      Inc(TempInt, cBYTE_POSSIBLE_VALUES);
      Borrow := 1;
    end
    else
      Borrow := 0;

    if (Succ(Diff.dwUsed) > Diff.IntBuf.dwLen) then
      LbBiRealloc(Diff, Succ(Diff.dwUsed));
    PBiByteArray(Diff.IntBuf.pBuf)[Diff.dwUsed] := TempInt;
    Inc(Diff.dwUsed);
  end;
  if (Borrow <> 0) then
    raise Exception.Create(sBISubtractErr);
  LbBiTrimSigZeros(Diff);
end;

procedure LbBiAdd(const N1, N2: LbInteger; var Sum: LbInteger);
var
  Value: ShortInt;
begin
  if (N1.bSign = N2.bSign) then
  begin
    Sum.bSign := N1.bSign;
    LbBiAddBase(N1, N2, Sum);
  end
  else
  begin
    Value := LbBiAbs(N1, N2);
    if (Value = cEQUAL_TO) then
    begin
      LbBiAddByte(Sum, cPREPEND_ARRAY, $00);
      Exit;
    end
    else if (Value = cGREATER_THAN) then
    begin
      Sum.bSign := N1.bSign;
      LbBiSubBase(N1, N2, Sum);
    end
    else
    begin
      Sum.bSign := N2.bSign;
      LbBiSubBase(N2, N1, Sum);
    end;
  end;
end;

procedure LbBiSub(const N1: LbInteger; N2: LbInteger; var Diff: LbInteger);
begin
  N2.bSign := not N2.bSign;
  LbBiAdd(N1, N2, Diff);
end;

procedure LbBiSubInPlace(var N1: LbInteger; const N2: LbInteger);
var
  Difference: LbInteger;
  Precision: Integer;
begin
  if (N1.dwUsed > N2.dwUsed) then
    Precision := Succ(N1.dwUsed)
  else
    Precision := Succ(N2.dwUsed);

  LbBiInit(Difference, Precision);
  try
    LbBiSub(N1, N2, Difference);
    LbBiClear(N1);
    N1.dwUsed := Difference.dwUsed;
    N1.bSign := Difference.bSign;
    if (N1.IntBuf.dwLen < Difference.IntBuf.dwLen) then
      LbBiRealloc(N1, Difference.IntBuf.dwLen);

    LbBiCopy(N1, Difference, Difference.dwUsed);
  finally
    LbBiFree(Difference);
  end;
end;

procedure LbBiDivByDigitBase(const N1: LbInteger; const N2: Byte;
  var Quotient: LbInteger; var Remainder: Byte);
var
  Factor: Byte;
  I: Integer;
  Temp: Integer;
  SigDivd: LongInt;
  LclQT: LongInt;
  Carry: WORD;
  Plc: Integer;
  LclDVD: LbInteger;
  Divisor: Byte;
begin
  LbBiInit(LclDVD, N1.dwUsed);
  Carry := 0;
  try
    if (LbBiIsZero(N1)) then
    begin
      LbBiAddByte(Quotient, cPREPEND_ARRAY, $00);
      Exit;
    end;
    if (N2 = 1) then
    begin
      LbBiCopy(Quotient, N1, N1.dwUsed);
      Exit;
    end;
    if (N2 = 0) then
      raise Exception.Create(sBIZeroDivide);

    LbBiCopy(LclDVD, N1, N1.dwUsed);
    Divisor := N2;

    Factor := LbBiFindFactor(N2);
    if (Factor <> 1) then
    begin
      LbBiMulByDigitInPlace(LclDVD, Factor);
      Divisor := Divisor * Factor;
    end;

    if PBiByteArray(LclDVD.IntBuf.pBuf)[Pred(LclDVD.dwUsed)] >= Divisor then
    begin
      LbBiAddByte(LclDVD, cAPPEND_ARRAY, $00);
    end;

    LbBiClear(Quotient);
    Remainder := 0;

    Plc := Pred(LclDVD.dwUsed);
    if (LclDVD.dwUsed > Quotient.dwUsed) then
      LbBiRealloc(Quotient, LclDVD.dwUsed);
    Carry := 0;
    Temp := Pred(LclDVD.dwUsed);
    for I := Temp downto 0 do
    begin
      SigDivd := (Carry shl 8) or
        (Integer(PBiByteArray(LclDVD.IntBuf.pBuf)[I]));
      if (SigDivd < Divisor) then
      begin
        Carry := SigDivd;
        Dec(Plc);
        continue;
      end;

      LclQT := SigDivd div Divisor;
      if (LclQT <> 0) then
      begin
        if (LclQT >= cBYTE_POSSIBLE_VALUES) then
          LclQT := Pred(cBYTE_POSSIBLE_VALUES);

        while SigDivd < (Divisor * LclQT) do
        begin
          Dec(LclQT);
          if (LclQT = 0) then
            raise Exception.Create(sBIQuotientErr);
        end;
      end;

      if (LclQT <> 0) then
      begin
        PBiByteArray(Quotient.IntBuf.pBuf)[Plc] := LclQT;
        if (Quotient.dwUsed < Succ(Plc)) then
          Quotient.dwUsed := Succ(Plc);

        Carry := SigDivd - (Divisor * LclQT);
      end;
      Dec(Plc);
    end;
  finally
    Remainder := Carry;
    if (Quotient.dwUsed = 0) then
      LbBiAddByte(Quotient, cPREPEND_ARRAY, $00);

    LbBiFree(LclDVD);
    LbBiTrimSigZeros(Quotient);
  end;
end;

procedure LbBiDivByDigit(const N1: LbInteger; const N2: Byte;
  var Quotient: LbInteger; var Remainder: Byte);
begin
  LbBiDivByDigitBase(N1, N2, Quotient, Remainder);
  Quotient.bSign := N1.bSign;
end;

procedure LbBiDivByDigitInPlace(var N1: LbInteger; const N2: Byte;
  var Remainder: Byte);
var
  Temp: LbInteger;
  Precision: Integer;
begin
  Precision := (N1.dwUsed + 1) * 2;
  LbBiInit(Temp, Precision);
  try
    LbBiDivByDigit(N1, N2, Temp, Remainder);

    N1.dwUsed := Temp.dwUsed;
    N1.bSign := Temp.bSign;
    if (N1.IntBuf.dwLen < Temp.IntBuf.dwLen) then
      LbBiRealloc(N1, Temp.IntBuf.dwLen);
    LbBiCopy(N1, Temp, Temp.dwUsed);
  finally
    LbBiFree(Temp);
  end;
end;

procedure LbBiDivBase(const N1, N2: LbInteger;
  var Quotient, Remainder: LbInteger);
var
  Factor: Byte;
  InxQ: Integer;
  InxX: Integer;
  TmpByte: Byte;
  TempInt: Integer;
  SigDigit: Byte;
  LclQT: LongInt;
  LclDVD: LbInteger;
  LclDSR: LbInteger;
  TempDR: LbInteger;
  TempBN: LbInteger;
  SigDivd: LongInt;
begin
  LbBiInit(LclDVD, N1.dwUsed);
  LbBiInit(LclDSR, N1.dwUsed);
  LbBiInit(TempDR, N1.dwUsed);
  LbBiInit(TempBN, N1.dwUsed);
  try
    if (N1.dwUsed < 1) or (N2.dwUsed < 1) then
      raise Exception.Create(sBINoNumber);

    if LbBiIsZero(N1) then
    begin
      LbBiAddByte(Quotient, cPREPEND_ARRAY, $00);
      LbBiAddByte(Remainder, cPREPEND_ARRAY, $00);
      Exit;
    end;

    if LbBiIsOne(N2) then
    begin
      LbBiCopy(Quotient, N1, N1.dwUsed);
      LbBiAddByte(Remainder, cPREPEND_ARRAY, $00);
      Exit;
    end;
    if LbBiIsZero(N2) then
      raise Exception.Create(sBIZeroDivide);

    LbBiCopy(LclDVD, N1, N1.dwUsed);
    LbBiCopy(LclDSR, N2, N2.dwUsed);
    LbBiTrimSigZeros(LclDSR);

    TmpByte := PBiByteArray(LclDSR.IntBuf.pBuf)[Pred(LclDSR.dwUsed)];
    if (TmpByte = 0) then
      raise Exception.Create(sBIZeroFactor);

    Factor := LbBiFindFactor(TmpByte);
    if (Factor <> 1) then
    begin
      LbBiMulByDigitInPlace(LclDVD, Factor);
      LbBiMulByDigitInPlace(LclDSR, Factor);
    end;

    if PBiByteArray(LclDVD.IntBuf.pBuf)[Pred(LclDVD.dwUsed)] >=
      PBiByteArray(LclDSR.IntBuf.pBuf)[Pred(LclDSR.dwUsed)] then
    begin
      LbBiAddByte(LclDVD, cAPPEND_ARRAY, $00);
    end;

    while (LclDVD.dwUsed < LclDSR.dwUsed) do
      LbBiAddByte(LclDVD, cAPPEND_ARRAY, $00);

    InxQ := LclDVD.dwUsed - LclDSR.dwUsed + 1;
    InxX := LclDVD.dwUsed;

    LbBiClear(Quotient);
    LbBiClear(Remainder);

    SigDigit := PBiByteArray(LclDSR.IntBuf.pBuf)[Pred(LclDSR.dwUsed)];
    if (SigDigit = 0) then
    begin
      TempInt := Pred(LclDSR.dwUsed);
      while SigDigit = 0 do
      begin
        SigDigit := PBiByteArray(LclDSR.IntBuf.pBuf)[TempInt];
        Dec(TempInt);
        if TempInt < 0 then
          raise Exception.Create(sBIQuotientErr);
      end;
    end;

    while InxQ >= 1 do
    begin
      if (LclDVD.dwUsed = 1) then
        SigDivd := PBiByteArray(LclDVD.IntBuf.pBuf)[0]
      else
        SigDivd := Integer(PBiByteArray(LclDVD.IntBuf.pBuf)[InxX])
          shl 8 + PBiByteArray(LclDVD.IntBuf.pBuf)[Pred(InxX)];

      LclQT := SigDivd div SigDigit;
      if (LclQT <> 0) then
      begin
        if (LclQT >= cBYTE_POSSIBLE_VALUES) then
          LclQT := Pred(cBYTE_POSSIBLE_VALUES);

        LbBiClear(TempDR);
        LbBiMove(TempDR, LclDSR, InxQ, LclDSR.dwUsed);

        LbBiMulByDigitInPlace(TempDR, LclQT);

        while (LbBiCompare(LclDVD, TempDR) = cLESS_THAN) do
        begin
          Dec(LclQT);
          if (LclQT = 0) then
            break;

          LbBiClear(TempDR);
          LbBiMove(TempDR, LclDSR, InxQ, LclDSR.dwUsed);

          LbBiMulByDigitInPlace(TempDR, LclQT);
        end;
      end;

      if (LclQT <> 0) then
      begin

        LbBiAddByte(Quotient, InxQ, LclQT);
        LbBiSubInPlace(LclDVD, TempDR);
      end;
      Dec(InxX);
      Dec(InxQ);
    end;

    LbBiCopy(Remainder, LclDVD, LclDVD.dwUsed);

    if (Factor <> 0) then
    begin
      if (Remainder.dwUsed > 1) then
      begin
        LbBiDivByDigitInPlace(Remainder, Factor, TmpByte);
      end
      else if (Remainder.dwUsed = 1) then
      begin
        TmpByte := PBiByteArray(Remainder.IntBuf.pBuf)[0];
        TmpByte := TmpByte div Factor;
        LbBiAddByte(Remainder, cPREPEND_ARRAY, TmpByte);
      end;
    end;
  finally
    LbBiFree(LclDVD);
    LbBiFree(LclDSR);
    LbBiFree(TempDR);
    LbBiFree(TempBN);

    if (Quotient.dwUsed = 0) then
      LbBiAddByte(Quotient, cPREPEND_ARRAY, $00);

    if (Remainder.dwUsed = 0) then
    begin
      LbBiAddByte(Remainder, cPREPEND_ARRAY, $00);
    end;

    LbBiTrimSigZeros(Quotient);
    LbBiTrimSigZeros(Remainder);
  end;
end;

procedure LbBiDiv(const N1, N2: LbInteger; var Quotient, Remainder: LbInteger);
begin
  LbBiDivBase(N1, N2, Quotient, Remainder);
  if (N1.bSign = N2.bSign) then
    Quotient.bSign := cPOSITIVE
  else
    Quotient.bSign := cNEGATIVE;
end;

procedure LbBiMod(const N1, N2: LbInteger; var Remainder: LbInteger);
var
  Quotient: LbInteger;
begin
  LbBiInit(Quotient, N2.dwUsed);
  LbBiDiv(N1, N2, Quotient, Remainder);
  LbBiFree(Quotient);
end;

procedure LbBiModInPlace(var N1: LbInteger; const Modulas: LbInteger);
var
  Remainder: LbInteger;
begin
  LbBiInit(Remainder, Modulas.dwUsed);
  LbBiMod(N1, Modulas, Remainder);

  LbBiClear(N1);
  N1.dwUsed := Remainder.dwUsed;
  N1.bSign := Remainder.bSign;

  if (N1.IntBuf.dwLen < Remainder.IntBuf.dwLen) then
    LbBiRealloc(N1, Remainder.IntBuf.dwLen);

  LbBiCopy(N1, Remainder, Remainder.dwUsed);
  LbBiFree(Remainder);
end;

procedure LbBiPowerAndMod(const I1, Exponent, Modulus: LbInteger;
  var Result: LbInteger);
var
  BitCount: Integer;
  I: Integer;
  TempByte: Byte;
  Hold: LbInteger;
begin
  LbBiClear(Result);
  if (LbBiIsZero(Exponent)) then
  begin
    LbBiAddByte(Result, cPREPEND_ARRAY, $01);
    Exit;
  end;
  LbBiInit(Hold, cDEFAULT_PRECISION);
  try
    I := Exponent.dwUsed;
    LbBiAddByte(Result, cPREPEND_ARRAY, $01);
    while I > 0 do
    begin
      TempByte := LbBiGetByteValue(Exponent, I);
      Dec(I);
      BitCount := 8;
      TempByte := LbBiReverseBits(TempByte);

      while BitCount > 0 do
      begin
        LbBiMultInPlace(Result, Result);
        LbBiModInPlace(Result, Modulus);
        if Odd(TempByte) then
        begin
          LbBiMultInPlace(Result, I1);
          LbBiModInPlace(Result, Modulus);
        end;
        TempByte := TempByte shr 1;
        Dec(BitCount);
      end;
    end;
  finally
    LbBiFree(Hold);
  end;
end;

procedure LbBiPowerAndModInPLace(var I1: LbInteger;
  const Exponent, Modulus: LbInteger);
var
  Result: LbInteger;
begin
  LbBiInit(Result, cUSE_DEFAULT_PRECISION);
  try
    LbBiPowerAndMod(I1, Exponent, Modulus, Result);
    LbBiClear(I1);
    I1.dwUsed := Result.dwUsed;
    I1.bSign := Result.bSign;
    if (I1.IntBuf.dwLen < Result.IntBuf.dwLen) then
      LbBiRealloc(I1, Result.IntBuf.dwLen);
    LbBiCopy(I1, Result, Result.dwUsed);
  finally
    LbBiFree(Result);
  end;
end;

{TSerialDecoder}

function TSerialDecoder.GetDecodedBytes: TBytes;
var
  Serial, Exponent, Modulas, Output: LbInteger;
begin
  Serial := GetLargeIntFromBytes(FSerialNum);
  try
    Modulas := GetLargeIntFromBytes(FPublicMod);
    try
      Exponent := GetLargeIntFromBytes(FPublicExp);
      try
        LbBiInit(Output, cUSE_DEFAULT_PRECISION);
        try
          LbBiPowerAndMod(Serial, Exponent, Modulas, Output);
          Result := GetBytesFromLargeInt(Output);
        finally
          LbBiFree(Output);
        end;
      finally
        LbBiFree(Exponent);
      end;
    finally
      LbBiFree(Modulas);
    end;
  finally
    LbBiFree(Serial);
  end;
end;

function TSerialDecoder.GetBytesFromBase64(const Value: string): TBytes;
{$IFDEF FPC}
var
  Input: TStringStream;
  Output: TMemoryStream;
  Decoder: TBase64DecodingStream;
{$ENDIF}
begin
  {$IFDEF FPC}
  Input := TStringStream.Create(Value);
  try
    Decoder := TBase64DecodingStream.Create(Input);
    try
      Output := TMemoryStream.Create;
      try
        Result := nil;
        Output.CopyFrom(Decoder, Decoder.size);
        SetLength(Result, Output.size);
        Move(Output.Memory^, Result[0], Output.size);
      finally
        Output.Free;
      end;
    finally
      Decoder.Free;
    end;
  finally
    Input.Free;
  end;
  {$ELSE}
  Result := TNetEncoding.Base64.DecodeStringToBytes(Value);
  {$ENDIF}
end;

function TSerialDecoder.GetLargeIntFromBytes(const Bytes: TBytes): LbInteger;
var
  I: Integer;
begin
  Result.bSign := cDEFAULT_SIGN;
  Result.IntBuf.pBuf := AllocMem(Length(Bytes));
  Result.IntBuf.dwLen := Length(Bytes);
  Result.dwUsed := Length(Bytes);
  for I := High(Bytes) downto Low(Bytes) do
    Result.IntBuf.pBuf[High(Bytes) - I] := Bytes[I];
end;

function TSerialDecoder.GetBytesFromLargeInt(const Value: LbInteger): TBytes;
var
  I: Integer;
begin
  Result := nil;
  SetLength(Result, Value.dwUsed);
  for I := Low(Result) to High(Result) do
    Result[High(Result) - I] := Value.IntBuf.pBuf[I];
end;

function TSerialDecoder.GetBuildDate: TDate;
begin
  {Constant is in format YYYY-MM-DD}
  Result := EncodeDate(StrToInt(Copy(BuildDate, 1, 4)),
    StrToInt(Copy(BuildDate, 6, 2)), StrToInt(Copy(BuildDate, 9, 2)));
end;

procedure TSerialDecoder.SetPublicExp(const Value: string);
begin
  FPublicExp := GetBytesFromBase64(Value);
  if Length(FPublicExp) >= 8 then
    Assert(Length(FPublicExp) mod 8 = 0);
end;

procedure TSerialDecoder.SetPublicMod(const Value: string);
begin
  FPublicMod := GetBytesFromBase64(Value);
  if Length(FPublicMod) >= 8 then
    Assert(Length(FPublicMod) mod 8 = 0);
end;

procedure TSerialDecoder.SetSerialNum(const Value: string);
begin
  FSerialNum := GetBytesFromBase64(Value);
end;

procedure TSerialDecoder.SetProductCode(const Value: UInt64);
begin
  FProductCode := Value;
end;

function TSerialDecoder.VMProtectSetSerialNumber(
  const SerialNumber: string): LongWord;
var
  HashData: PByte;
  HashSize: Integer;
  DataStart: Integer;
  Digest: {$IFDEF FPC}TSHA1Digest{$ELSE}THashSHA1{$ENDIF};
  BytesStream: TBytesStream;
  Buffer: TBytes;
  Len: Byte;
begin
  try
    {Assign serial number}
    SetSerialNum(SerialNumber);
    {Check the black list}
    CheckSerialBlackList;
    {Decode license key}
    BytesStream := TBytesStream.Create(GetDecodedBytes);
    try
      {Find data section}
      while BytesStream.ReadByte <> 0 do
      begin
        {Skip random data}
      end;
      DataStart := BytesStream.Position;
      while BytesStream.Position < BytesStream.Size do
      begin
        case BytesStream.ReadByte of
          $01: {Version}
          begin
            if BytesStream.ReadByte <> 1 then
              Abort;
          end;
          $02: {User name}
          begin
            Len := BytesStream.ReadByte;
            SetLength(Buffer, Len);
            BytesStream.ReadBuffer(Buffer[0], Length(Buffer));
            {$IFDEF FPC}
            FSerialNumberData.wUserName := TEncoding.UTF8.GetString(Buffer);
            {$ELSE}
            WStrPLCopy(@FSerialNumberData.wUserName, TEncoding.UTF8.GetString(
              Buffer), Length(FSerialNumberData.wUserName) - 1);
            {$ENDIF}
          end;
          $03: {E-mail}
          begin
            Len := BytesStream.ReadByte;
            SetLength(Buffer, Len);
            BytesStream.ReadBuffer(Buffer[0], Length(Buffer));
            {$IFDEF FPC}
            FSerialNumberData.wEMail := TEncoding.UTF8.GetString(Buffer);
            {$ELSE}
            WStrPLCopy(@FSerialNumberData.wEMail, TEncoding.UTF8.GetString(
              Buffer), Length(FSerialNumberData.wEMail) - 1);
            {$ENDIF}
          end;
          $04: {Hardware ID}
          begin
            BytesStream.Seek(BytesStream.ReadByte, soFromCurrent);
          end;
          $05: {License expiration date}
          begin
            FSerialNumberData.dtExpire.bDay := BytesStream.ReadByte;
            FSerialNumberData.dtExpire.bMonth := BytesStream.ReadByte;
            FSerialNumberData.dtExpire.wYear := BytesStream.ReadWord;
          end;
          $06: {Maximum operation time}
          begin
            FSerialNumberData.bRunningTime := BytesStream.ReadByte;
          end;
          $07: {Product code}
          begin
            if BytesStream.ReadQWord <> FProductCode then
              Abort;
          end;
          $08: {User data}
          begin
            FSerialNumberData.nUserDataLength := BytesStream.ReadByte;
            BytesStream.ReadBuffer(FSerialNumberData.bUserData,
              FSerialNumberData.nUserDataLength);
          end;
          $09: {Maximum build date}
          begin
            FSerialNumberData.dtMaxBuild.bDay := BytesStream.ReadByte;
            FSerialNumberData.dtMaxBuild.bMonth := BytesStream.ReadByte;
            FSerialNumberData.dtMaxBuild.wYear := BytesStream.ReadWord;
          end;
          $FF: {Checksum}
          begin
            HashData := PByte(BytesStream.Memory) + DataStart;
            HashSize := BytesStream.Position - DataStart - 1;
            {$IFDEF FPC}
            Digest := SHA1Buffer(HashData^, HashSize);
            if NtoBE(BytesStream.ReadDWord) <> PLongWord(@Digest)^ then
              Abort;
            {$ELSE}
            Digest := THashSHA1.Create;
            Digest.Update(HashData^, HashSize);
            if THash.ToBigEndian(BytesStream.ReadDWord) <> PLongWord(
              @Digest.HashAsBytes[0])^ then
                Abort;
            {$ENDIF}
            Break;
          end
        else
          Abort;
        end;
      end;
    finally
      BytesStream.Free;
    end;
    {Loop finished and we check data}
    if (LongWord(FSerialNumberData.dtExpire) <> 0) and
      (Date > EncodeDate(
        FSerialNumberData.dtExpire.wYear,
        FSerialNumberData.dtExpire.bMonth,
        FSerialNumberData.dtExpire.bDay)) then
      begin
        FSerialNumberData.nState := SERIAL_STATE_FLAG_DATE_EXPIRED;
        Exit(FSerialNumberData.nState);
      end;
    if (LongWord(FSerialNumberData.dtMaxBuild) <> 0) and
      (GetBuildDate > EncodeDate(
        FSerialNumberData.dtMaxBuild.wYear,
        FSerialNumberData.dtMaxBuild.bMonth,
        FSerialNumberData.dtMaxBuild.bDay)) then
      begin
        FSerialNumberData.nState := SERIAL_STATE_FLAG_MAX_BUILD_EXPIRED;
        Exit(FSerialNumberData.nState);
      end;
    {Everything appears to be fine}
    FSerialNumberData.nState := SERIAL_STATE_SUCCESS;
    Result := FSerialNumberData.nState;
  except
    FSerialNumberData.nState := SERIAL_STATE_FLAG_INVALID;
    Result := FSerialNumberData.nState;
  end;
end;

function TSerialDecoder.VMProtectGetSerialNumberData(
  Data: PVMProtectSerialNumberData; DataSize: Integer): Boolean;
begin
  Result := SizeOf(FSerialNumberData) = DataSize;
  if Result then
    Move(FSerialNumberData, Data^, DataSize);
end;

procedure TSerialDecoder.CheckSerialBlackList;
const
  BlackList: TArray<string> = [{$I BlackList.inc}];
var
  Value, Hash: string;
  Stream: TMemoryStream;
begin
  {$IFDEF FPC}
  Hash := MD5Print(MD5Buffer(FSerialNum[0], Length(FSerialNum)));
  {$ELSE}
  Stream := TMemoryStream.Create;
  try
    Stream.WriteBuffer(FSerialNum[0], Length(FSerialNum));
    Stream.Position := 0;
    Hash := THashMD5.GetHashString(Stream);
  {$ENDIF}
  for Value in BlackList do
    if Value = Hash then
      Abort;
  {$IFNDEF FPC}
  finally
    Stream.Free;
  end;
  {$ENDIF}
end;

{$IFNDEF FPC}

function TBytesStream.ReadByte: Byte;
begin
  ReadBuffer(Result, SizeOf(Result));
end;

function TBytesStream.ReadWord: Word;
begin
  ReadBuffer(Result, SizeOf(Result));
end;

function TBytesStream.ReadDWord: UInt32;
begin
  ReadBuffer(Result, SizeOf(Result));
end;

function TBytesStream.ReadQWord: UInt64;
begin
  ReadBuffer(Result, SizeOf(Result));
end;

{$ENDIF}

end.

SerialDecoder := TSerialDecoder.Create;
SerialDecoder.SetProductCode(UInt64($XXXXXXXXXXXXXXX));//<- в VMP файле это Base64, его надо сконвертировать в число UInt64.
SerialDecoder.SetPublicExp('AAEAAQ==');
SerialDecoder.SetPublicMod('сюда публичный ключ в Base64');
Flags := SerialDecoder.VMProtectSetSerialNumber('текст ключа что ввел пользователь');
if Flags <> 0 then
begin
  //Что-то не так, проверяйте SERIAL_STATE_FLAG_***
end
else
begin
  Info := Default(TVMProtectSerialNumberData);
  if SerialDecoder.VMProtectGetSerialNumberData(@Info, SizeOf(Info)) then
  //Все хорошо, достаем из ключа данные 
end;