stlist.pas

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

  try
{$ENDIF}
    if Assigned(L) then begin
      if Assigned(P) and (L.Count > 0) then begin
        {Patch the list into the current one}
        N := L.Head;
        Q := P.FNext;

        P.FNext := N;
        N.FPrev := P;

        if Assigned(Q) then begin
          N := L.Tail;
          N.FNext := Q;
          Q.FPrev := N;
        end;

        Inc(FCount, L.Count);
        lsLastI := -1;
      end;

      {Free L (but not its nodes)}
      L.IncNodeProtection;
      L.Free;
    end;
{$IFDEF ThreadSafe}
  finally
    L.LeaveCS;
    LeaveCS;
    LeaveClassCS;
  end;
{$ENDIF}
end;

procedure TStList.LoadFromStream(S : TStream);
var
  Data : pointer;
  Reader : TReader;
  StreamedClass : TPersistentClass;
  StreamedNodeClass : TPersistentClass;
  StreamedClassName : string;
  StreamedNodeClassName : string;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    Clear;
    Reader := TReader.Create(S, 1024);
    try
      with Reader do
        begin
          StreamedClassName := ReadString;
          StreamedClass := GetClass(StreamedClassName);
          if (StreamedClass = nil) then
            RaiseContainerErrorFmt(stscUnknownClass, [StreamedClassName]);
          if (not IsOrInheritsFrom(StreamedClass, Self.ClassType)) or
              (not IsOrInheritsFrom(TStList, StreamedClass)) then
            RaiseContainerError(stscWrongClass);
          StreamedNodeClassName := ReadString;
          StreamedNodeClass := GetClass(StreamedNodeClassName);
          if (StreamedNodeClass = nil) then
            RaiseContainerErrorFmt(stscUnknownNodeClass, [StreamedNodeClassName]);
          if (not IsOrInheritsFrom(StreamedNodeClass, conNodeClass)) or
              (not IsOrInheritsFrom(TStListNode, StreamedNodeClass)) then
            RaiseContainerError(stscWrongNodeClass);
          ReadListBegin;
          while not EndOfList do
            begin
              Data := DoLoadData(Reader);
              Append(Data);
            end;
          ReadListEnd;
        end;
    finally
      Reader.Free;
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStList.MoveToHead(P : TStListNode);
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if Assigned(P) then
      if P <> Head then begin
        with P do begin
          {Fix pointers of surrounding nodes}
          if FTail = P then
            FTail := FTail.FPrev
          else
            FNext.FPrev := FPrev;
          FPrev.FNext := FNext;

          FNext := FHead;
          FPrev := nil;
        end;
        FHead.FPrev := P;
        FHead := P;
     end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStList.Next(P : TStListNode) : TStListNode;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    Result := P.FNext;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStList.Nth(Index : LongInt) : TStListNode;
var
  MinI : LongInt;
  MinP : TStListNode;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if (Index < 0) or (Index >= FCount) then
      Result := nil
    else begin
      MinI := Index;
      MinP := FHead;
      if lsLastI >= 0 then
        {scan the fewest possible nodes}
        if Index <= lsLastI then begin
          if lsLastI-Index < Index then begin
            MinI := Index-lsLastI;
            MinP := lsLastP;
          end;
        end else if Index-lsLastI < FCount-1-Index then begin
          MinI := Index-lsLastI;
          MinP := lsLastP;
        end else begin
          MinI := Index-(FCount-1);
          MinP := FTail;
        end;

      Result := NthFrom(MinP, MinI);
      lsLastI := Index;
      lsLastP := Result;
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStList.NthFrom(P : TStListNode; Index : LongInt) : TStListNode;
var
  I : LongInt;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if Assigned(P) then begin
      if not (P is conNodeClass) then
        RaiseContainerError(stscBadType);
      if Index > 0 then begin
        for I := 1 to Index do begin
          P := P.FNext;
          if not Assigned(P) then
            break;
        end;
      end else begin
        for I := 1 to -Index do begin
          P := P.FPrev;
          if not Assigned(P) then
            break;
        end;
      end;
    end;
    Result := P;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStList.Place(Data : Pointer; P : TStListNode) : TStListNode;
var
  N : TStListNode;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if not Assigned(P) then
      Result := Insert(Data)
    else if P = FTail then
      Result := Append(Data)
    else begin
      N := TStListNode(conNodeClass.Create(Data));
      N.FPrev := P;
      N.FNext := P.FNext;
      P.FNext.FPrev := N;
      P.FNext := N;
      Inc(FCount);
      lsLastI := -1;
      Result := N;
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStList.PlaceBefore(Data : Pointer; P : TStListNode) : TStListNode;
var
  N : TStListNode;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if (not Assigned(P)) or (P = Head) then
      {Place the new element at the start of the list}
      Result := Insert(Data)
    else begin
      {Patch in the new element}
      N := TStListNode(conNodeClass.Create(Data));
      N.FNext := P;
      N.FPrev := P.FPrev;
      P.FPrev.FNext := N;
      P.FPrev := N;
      lsLastI := -1;
      Inc(FCount);
      Result := N;
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStList.Posn(P : TStListNode) : LongInt;
var
  I : LongInt;
  N : TStListNode;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if not Assigned(P) then
      Result := -1
    else begin
      if not (P is conNodeClass) then
        RaiseContainerError(stscBadType);
      I := 0;
      N := FHead;
      while Assigned(N) do begin
        if P = N then begin
          Result := I;
          exit;
        end;
        Inc(I);
        N := N.FNext;
      end;
      Result := -1;
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStList.Prev(P : TStListNode) : TStListNode;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    Result := P.FPrev;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStList.Sort;
const
  StackSize = 32;
type
  Stack = array[0..StackSize-1] of TStListNode;
var
  L : TStListNode;
  R : TStListNode;
  PL : TStListNode;
  PR : TStListNode;
  PivotData : Pointer;
  TmpData : Pointer;
  Dist : LongInt;
  DistL : LongInt;
  DistR : LongInt;
  StackP : Integer;
  LStack : Stack;
  RStack : Stack;
  DStack : array[0..StackSize-1] of LongInt;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    {Need at least 2 elements to sort}
    if Count <= 1 then
      Exit;
    lsLastI := -1;

    {Initialize the stacks}
    StackP := 0;
    LStack[0] := FHead;
    RStack[0] := FTail;
    DStack[0] := Count-1;

    {Repeatedly take top partition from stack}
    repeat

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

      if L <> R then
        {Sort current partition}
        repeat

          {Load the pivot element}
          PivotData := NthFrom(L, Dist div 2).Data;
          PL := L;
          PR := R;
          DistL := Dist;
          DistR := Dist;

          {Swap items in sort order around the pivot index}
          repeat
            while DoCompare(PL.Data, PivotData) < 0 do begin
              PL := PL.FNext;
              Dec(Dist);
              Dec(DistR);
            end;
            while DoCompare(PivotData, PR.Data) < 0 do begin
              PR := PR.FPrev;
              Dec(Dist);
              Dec(DistL);
            end;
            if Dist >= 0 then begin
              if PL <> PR then begin
                {Swap the two elements}
                TmpData := PL.Data;
                PL.Data := PR.Data;
                PR.Data := TmpData;
              end;
              if Assigned(PL.FNext) then begin
                PL := PL.FNext;
                Dec(Dist);
                Dec(DistR);
              end;
              if Assigned(PR.FPrev) then begin
                PR := PR.FPrev;
                Dec(Dist);
                Dec(DistL);
              end;
            end;
          until Dist < 0;

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

        until Dist <= 0;
    until StackP < 0;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStList.Split(P : TStListNode) : TStList;
var
  I : LongInt;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    I := Posn(P);
    if I < 0 then begin
      Result := nil;
      Exit;
    end;

    {Create and initialize the new list}
    Result := TStListClass(ClassType).Create(conNodeClass);
    Result.Compare := Compare;
    Result.OnCompare := OnCompare;
    Result.DisposeData := DisposeData;
    Result.OnDisposeData := OnDisposeData;
    Result.LoadData := LoadData;
    Result.OnLoadData := OnLoadData;
    Result.StoreData := StoreData;
    Result.OnStoreData := OnStoreData;
    Result.FHead := P;
    Result.FTail := FTail;
    Result.FCount := Count-I;
    Result.lsLastI := -1;

    {Truncate the old list}
    if Assigned(P.FPrev) then begin
      P.FPrev.FNext := nil;
      FTail := P.FPrev;
      P.FPrev := nil;
    end;
    if P = FHead then
      FHead := nil;
    FCount := I;
    lsLastI := -1;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStList.StoresPointers : Boolean;
begin
  Result := true;
end;

procedure TStList.StoreToStream(S : TStream);
var
  Writer : TWriter;
  Walker : TStListNode;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    Writer := TWriter.Create(S, 1024);
    try
      with Writer do
        begin
          WriteString(Self.ClassName);
          WriteString(conNodeClass.ClassName);
          WriteListBegin;
          Walker := Head;
          while Walker <> nil do
            begin
              DoStoreData(Writer, Walker.Data);
              Walker := Next(Walker);
            end;
          WriteListEnd;
        end;
    finally
      Writer.Free;
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

{$IFDEF ThreadSafe}
initialization
  Windows.InitializeCriticalSection(ClassCritSect);
finalization
  Windows.DeleteCriticalSection(ClassCritSect);
{$ENDIF}
end.