stvarr.pas

条码控件： 一维条码控件 二维条码控件 PDF417Barcode MaxiCodeBarcode

{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStVMatrix.HeaderSize : LongInt;
begin
  Result := 0;
end;

procedure TStVMatrix.ReadHeader;
begin
  {does nothing by default}
  {can assume that FilePos = 0 when this is called}
end;

procedure TStVMatrix.Put(Row, Col : Cardinal; const Value);
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
{$IFOPT R+}
    if (Row >= Rows) or (Col >= Cols) then
      RaiseContainerError(stscBadIndex);
{$ENDIF}
    Move(Value, PChar(vmGetRowData(Row, True))[LongInt(Col)*FElSize], FElSize);
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStVMatrix.PutRow(Row : Cardinal; const RowValue);
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
{$IFOPT R+}
    if Row >= Rows then
      RaiseContainerError(stscBadIndex);
{$ENDIF}
    HugeMove(RowValue, vmGetRowData(Row, True)^, vmRowSize);
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStVMatrix.SortRows(KeyCol : Cardinal; Compare : TUntypedCompareFunc);
const
  StackSize = 32;
type
  Stack = array[0..StackSize-1] of LongInt;
var
  L : LongInt;
  R : LongInt;
  PL : LongInt;
  PR : LongInt;
  CurEl : Pointer;
  PivEl : Pointer;
  StackP : Integer;
  LStack : Stack;
  RStack : Stack;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if KeyCol >= Cols then
      RaiseContainerError(stscBadIndex);

    {Need at least 2 rows to sort}
    if FRows <= 1 then
      Exit;

    GetMem(CurEl, FElSize);
    try
      GetMem(PivEl, FElSize);

      {Initialize the stacks}
      StackP := 0;
      LStack[0] := 0;
      RStack[0] := FRows-1;

      {Repeatedly take top partition from stack}
      repeat

        {Pop the stack}
        L := LStack[StackP];
        R := RStack[StackP];
        Dec(StackP);

        {Sort current partition}
        repeat

          {Load the pivot element}
          Get((L+R) div 2, KeyCol, PivEl^);
          PL := L;
          PR := R;

          {Swap items in sort order around the pivot index}
          repeat
            Get(PL, KeyCol, CurEl^);
            while Compare(CurEl^, PivEl^) < 0 do begin
              Inc(PL);
              Get(PL, KeyCol, CurEl^);
            end;
            Get(PR, KeyCol, CurEl^);
            while Compare(PivEl^, CurEl^) < 0 do begin
              Dec(PR);
              Get(PR, KeyCol, CurEl^);
            end;
            if PL <= PR then begin
              if PL <> PR then
                {Swap the two elements}
                ExchangeRows(PL, PR);
              Inc(PL); {assume we'll never sort 2 billion elements}
              Dec(PR);
            end;
          until PL > PR;

          {Decide which partition to sort next}
          if (PR-L) < (R-PL) then begin
            {Right partition is bigger}
            if PL < R then begin
              {Stack the request for sorting right partition}
              Inc(StackP);
              LStack[StackP] := PL;
              RStack[StackP] := R;
            end;
            {Continue sorting left partition}
            R := PR;
          end else begin
            {Left partition is bigger}
            if L < PR then begin
              {Stack the request for sorting left partition}
              Inc(StackP);
              LStack[StackP] := L;
              RStack[StackP] := PR;
            end;
            {Continue sorting right partition}
            L := PL;
          end;

        until L >= R;
      until StackP < 0;

      FreeMem(PivEl, FElSize);
    finally
      FreeMem(CurEl, FElSize);
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStVMatrix.vmAllocateCache;
var
  I : Integer;
begin
  GetMem(vmCache, FCacheRows*SizeOf(TStCacheRec));
  FillChar(vmCache^, FCacheRows*SizeOf(TStCacheRec), 0);
  try
    for I := 0 to FCacheRows-1 do
      with vmCache^[I] do
        HugeGetMem(crRowData, vmRowSize);
  except
    vmDeallocateCache;
    raise;
  end;
  vmInvalidateCache;
end;

procedure TStVMatrix.vmDeallocateCache;
var
  I : Integer;
begin
  if Assigned(vmCache) then begin
    for I := FCacheRows-1 downto 0 do
      HugeFreeMem(vmCache^[I].crRowData, vmRowSize);
    if Assigned(vmCache) then
      FreeMem(vmCache, FCacheRows*SizeOf(TStCacheRec));
    vmCache := nil;
  end;
  FCacheRows := 0;
end;

procedure TStVMatrix.vmFlushCacheNode(CacheIndex : Integer);
begin
  with vmCache^[CacheIndex] do
    if crDirty > 0 then begin
      vmWriteRow(crRow, crRowData, True);
      crDirty := 0;
    end;
end;

function TStVMatrix.vmGetRowData(Row : Cardinal; MakeDirty : Boolean) : Pointer;
var
  CacheIndex, OldestIndex : Integer;
  OldestTime, Bytes : LongInt;
  TmpRowData : Pointer;
begin
  if not vmSearchCache(Row, CacheIndex) then begin
    {row not found in cache}
    if vmCacheCnt = FCacheRows then begin
      {cache full, must throw out oldest row in cache}
      OldestTime := MaxLongInt;
      OldestIndex := 0; {prevent D32 from generating a warning}
      for CacheIndex := 0 to vmCacheCnt-1 do
        with vmCache^[CacheIndex] do
          if crTime < OldestTime then begin
            OldestIndex := CacheIndex;
            OldestTime := crTime;
          end;
      vmFlushCacheNode(OldestIndex);
      dec(vmCacheCnt);
      TmpRowData := vmCache^[OldestIndex].crRowData;
      Move(vmCache^[OldestIndex+1], vmCache^[OldestIndex],
            (vmCacheCnt-OldestIndex)*SizeOf(TStCacheRec));
      vmCache^[vmCacheCnt].crRowData := TmpRowData;
      {find spot where row should now be inserted}
      vmSearchCache(Row, CacheIndex);
    end;

    {add row to cache}
    TmpRowData := vmCache^[vmCacheCnt].crRowData;
    Move(vmCache^[CacheIndex], vmCache^[CacheIndex+1],
          (vmCacheCnt-CacheIndex)*SizeOf(TStCacheRec));
    inc(vmCacheCnt);
    with vmCache^[CacheIndex] do begin
      crRowData := TmpRowData;
      crRow := Row;
      Bytes := FileSeek(vmDataF, HeaderSize+LongInt(Row)*vmRowSize, 0);
      if Bytes >= 0 then
        Bytes := FileRead(vmDataF, crRowData^, vmRowSize);
      if Bytes < 0 then
        RaiseContainerError(stscFileRead);
      {else if Bytes = 0 then}
        {row hasn't been written to yet}
        {HugeFillChar(crRowData^, vmRowSize, 0);}
      crDirty := 0;
    end;
  end;

  with vmCache^[CacheIndex] do begin
    Result := crRowData;
    if MakeDirty then
      crDirty := 1;
    crTime := vmIncCacheTime;
  end;
end;

function TStVMatrix.vmIncCacheTime : LongInt;
var
  I : Integer;
begin
  if vmCacheTime = MaxLongInt-1 then begin
    {reset time for all buffers}
    for I := 0 to vmCacheCnt-1 do
      vmCache^[I].crTime := 0;
    vmCacheTime := 0;
  end;
  inc(vmCacheTime);
  Result := vmCacheTime;
end;

procedure TStVMatrix.vmInvalidateCache;
begin
  vmCacheCnt := 0;
  vmCacheTime := 0;
end;

function TStVMatrix.vmSearchCache(Row : Cardinal; var CacheIndex : Integer) : Boolean;
var
  L, R, M : Integer;
  Comp : LongInt;
begin
  if vmCacheCnt = 0 then begin
    Result := False;
    CacheIndex := 0;
    Exit;
  end;

  {search cache for row using binary search}
  L := 0;
  R := vmCacheCnt-1;
  repeat
    M := (L+R) div 2;
    with vmCache^[M] do begin
      Comp := LongInt(Row)-LongInt(crRow);                             
      if Comp = 0 then begin
        {found row in cache}
        Result := True;
        CacheIndex := M;
        Exit;
      end else if Comp < 0 then
        R := M-1
      else
        L := M+1;
    end;
  until L > R;

  {not found, return where it should be inserted}
  Result := False;
  CacheIndex := M;
  if Comp > 0 then
    inc(CacheIndex);
end;

procedure TStVMatrix.vmSetCacheRows(CacheRows : Integer);
var
  I : Integer;
  NewCache : PStCacheArray;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if CacheRows = FCacheRows then
      Exit;

    if (CacheRows < 2) or (CacheRows > StMaxBlockSize div SizeOf(TStCacheRec)) then
      RaiseContainerError(stscBadSize);

    {allocate new cache descriptor array}
    GetMem(NewCache, CacheRows*SizeOf(TStCacheRec));
    FillChar(NewCache^, CacheRows*SizeOf(TStCacheRec), 0);

    try
      {allocate new buffers if any}
      for I := FCacheRows to CacheRows-1 do
        with NewCache^[I] do
          HugeGetMem(crRowData, vmRowSize);

      {transfer old cache buffers to new array}
      for I := 0 to FCacheRows-1 do
        if I < CacheRows then
          NewCache^[I] := vmCache^[I]
        else begin
          {number of buffers shrunk, get rid of excess buffers}
          if I < vmCacheCnt then
            vmFlushCacheNode(I);
          HugeFreeMem(vmCache^[I].crRowData, vmRowSize);
        end;

    except
      for I := CacheRows-1 downto 0 do
        HugeFreeMem(NewCache^[I].crRowData, vmRowSize);
      FreeMem(NewCache, CacheRows*SizeOf(TStCacheRec));
    end;

    {update cache in-use count}
    if vmCacheCnt > CacheRows then
      vmCacheCnt := CacheRows;

    {deallocate old cache}
    FreeMem(vmCache, FCacheRows*SizeOf(TStCacheRec));
    vmCache := NewCache;
    FCacheRows := CacheRows;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStVMatrix.vmSetRows(Rows : Cardinal);
var
  I : Integer;
  NewSize : LongInt;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if Rows = FRows then
      Exit;

    {validate new size}
    if (Rows = 0) or
    ProductOverflow(Rows, Cols) or
    ProductOverflow(LongInt(Rows)*LongInt(Cols), FElSize) then
      RaiseContainerError(stscBadSize);

    if Rows < FRows then begin
      {dump now-irrelevant rows from cache}
      for I := 0 to vmCacheCnt-1 do
        if vmCache^[I].crRow >= Rows then begin
          vmCacheCnt := I;
          break;
        end;
      {truncate data file}
      NewSize := HeaderSize+LongInt(Rows)*LongInt(Cols)*FElSize;
      if FileSeek(vmDataF, 0, 2) > NewSize then begin
        FileSeek(vmDataF, NewSize, 0);
        if not SetEndOfFile(vmDataF) then
          RaiseContainerError(stscFileWrite);
      end;
    end;

    FRows := Rows;
    FileSeek(vmDataF, 0, 0);
    WriteHeader;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStVMatrix.vmWriteRow(Row : Cardinal; Data : Pointer; Seek : Boolean);
var
  Bytes : LongInt;
begin
  if Seek then
    FileSeek(vmDataF, HeaderSize+LongInt(Row)*vmRowSize, 0);
  Bytes := FileWrite(vmDataF, Data^, vmRowSize);
  if (Bytes < 0) or (Bytes <> vmRowSize) then
    RaiseContainerError(stscFileWrite);
end;

procedure TStVMatrix.WriteHeader;
begin
  {does nothing by default}
  {can assume that FilePos = 0 when this is called}
end;


end.