Sort TStrings objects with extra functionality ala UNIX style parameters #172

unit SuperSort;

interface

uses 
  Classes,SysUtils;

// ==========================================================================
// Class TSuperSort
// Mike Heydon Nov 2002
//
// Sort class that implements Unix style sorts including ..
//
// SWITCHES
// --------
// -k [StartPos,EndPos]  - Keyfield to sort on. Start and End pos in string
// -d [Field Delimiter]  - Delimter to use with -f switch. default = SPACE
// -f [FieldNumber]      - Zero based field number delimeted by -d
//
// OPTIONS SET
// ============
// srtDescending         - Sort descending
// srtIgnoreCase         - Ignore case when sorting
// srtIgnoreBlank        - Ignore leading blanks
// srtEvalNumeric        - Treat sort items as NUMERIC
//
// ==========================================================================

type
  // Sort Options
  TSuperSortOptions = (
    srtDescending,srtIgnoreCase, srtIgnoreBlank,srtEvalNumeric
  );
  TSuperSortOptionSet = set of TSuperSortOptions;

  // ============
  // TSuperSort
  // ============
  TSuperSort = class(TObject)
  protected
    function GetKeyString(const Line : string) : string;
    procedure QuickSortStrA(SL : TStrings);
    procedure QuickSortStrD(SL : TStrings);
    procedure ResolveSwitches(Switches : array of string);
  private
    FSortTime : TDateTime;
    FIsSwitches,
    FIsPositional,
    FIsDelimited,
    FDescending,
    FIgnoreCase,
    FIgnoreBlank,
    FEvalDateTime,
    FEvalNumeric : boolean;
    FFieldNum,
    FStartPos,FEndPos : integer;
    FDelimiter : char;
  public
    procedure SortStrings(StringList : TStrings; Switches : array of string;
      Options : TSuperSortOptionSet = []);
    property SortTime : TDateTime read FSortTime;
  end;

// --------------------------------------------------------------------------
implementation

const
  BLANK    = -1;
  EMPTYSTR = '';

// ================================================
// INTERNAL CALL
// Resolve switches and set internal variables
// ================================================

procedure TSuperSort.ResolveSwitches(Switches : array of string);
var
  i : integer;
  Sw,Data : string;
begin
  FStartPos := BLANK;
  FEndPos := BLANK;
  FFieldNum := BLANK;
  FDelimiter := ' ';
  FIsPositional := false;
  FIsDelimited := false;

  for i := Low(Switches) to High(Switches) do
  begin
    Sw := trim(Switches[i]);
    Data := trim(copy(Sw,3,1024));
    Sw := UpperCase(copy(Sw,1,2));

    // Delimiter
    if Sw = '-D' then
    begin
      if length(Data) > 0 then FDelimiter := Data[1];
    end;

    // Field Number
    if Sw = '-F' then
    begin
      FIsSwitches := true;
      FIsDelimited := true;
      FFieldNum := StrToIntDef(Data,BLANK);
      Assert(FFieldNum <> BLANK,'Invalid -f Switch');
    end;

    // Positional Key
    if Sw = '-K' then
    begin
      FIsSwitches := true;
      FIsPositional := true;
      FStartPos := StrToIntDef(trim(copy(Data,1,pos(',',Data) - 1)),BLANK);
      FEndPos := StrToIntDef(trim(copy(Data,pos(',',Data) + 1,1024)),BLANK);
      Assert((FStartPos <> BLANK) and (FEndPos <> Blank),'Invalid -k Switch');
    end;
  end;
end;

// ====================================================
// INTERNAL CALL
// Resolve the Sort Key part of the string based on
// the Switches parameters
// ====================================================

function TSuperSort.GetKeyString(const Line : string) : string;
var
  Key : string;
  Numvar : double;
  DCount, i, DPos : integer;
  Tmp : string;
begin
  // Default
  Key := Line;
  // Extract Key from switches -k takes precedence
  if FIsPositional then
    Key := copy(Key,FStartPos,FEndPos)
  else
    if FIsDelimited then
    begin
      DPos := 0;
      DCount := 0;
      for i := 1 to length(Key) do
      begin
        if Key[i] = FDelimiter then
         inc(DCount);
        if DCount = FFieldNum then
        begin
           if FFieldNum = 0 then
             DPos := 1
           else
             DPos := i + 1;
          break;
        end;
      end;

      if DCount < FFieldNum then
        // No such Field Number
        Key := EMPTYSTR
      else
      begin
        Tmp := copy(Key,DPos,4096);
        DPos := pos(FDelimiter,Tmp);
        if DPos = 0 then
          Key := Tmp
        else
          Key := copy(Tmp,1,DPos - 1);
       end;
    end;

  // Resolve Options
  if FEvalNumeric then
  begin
    Key := trim(Key);
    // Strip any commas
    for i := length(Key) downto 1 do
      if Key[i] = ',' then delete(Key,i,1);
    try
      Numvar := StrToFloat(Key);
    except
      Numvar := 0.0;
    end;
    Key := FormatFloat('############0.000000',Numvar);
    // Leftpad num string
    Key := StringOfChar('0',20 - length(Key)) + Key;
  end;

  // Ignores N/A for Numeric and DateTime
  if not FEvalNumeric and not FEvalDateTime then
  begin
    if FIgnoreBlank then Key := trim(Key);
    if FIgnoreCase then Key := UpperCase(Key);
  end;

  Result := Key;
end;

// ==============================================
// INTERNAL CALL
// Recursive STRING quick sort routine ASCENDING.
// ==============================================

procedure TSuperSort.QuickSortStrA(SL : TStrings);

  procedure Sort(l,r : integer);
  var
    i, j : integer;
    x, Tmp : string;
  begin
    i := l;
    j := r;
    x := GetKeyString(SL[(l + r) div 2]);

    repeat
      while GetKeyString(SL[i]) < x do
        inc(i);
      while x  < GetKeyString(SL[j]) do 
        dec(j);
      if i <= j then 
      begin
        Tmp := SL[j];
        SL[j] := SL[i];
        SL[i] := Tmp;
        inc(i);
        dec(j);
      end;
    until i > j;

    if l < j then
      Sort(l,j);
    if i < r then
      Sort(i,r);
  end;

begin
  if SL.Count > 0 then 
  begin
    SL.BeginUpdate;
    Sort(0,SL.Count - 1);
    SL.EndUpdate;
  end;
end;

// ==============================================
// INTERNAL CALL
// Recursive STRING quick sort routine DECENDING
// ==============================================

procedure TSuperSort.QuickSortStrD(SL : TStrings);
  
  procedure Sort(l,r : integer);
  var 
    i, j : integer;
    x, Tmp : string;
  begin
    i := l;
    j := r;
    x := GetKeyString(SL[(l + r) div 2]);

    repeat
      while GetKeyString(SL[i]) > x do
        inc(i);
      while x  > GetKeyString(SL[j]) do
        dec(j);
      if i <= j then  
      begin
        Tmp := SL[j];
        SL[j] := SL[i];
        SL[i] := Tmp;
        inc(i);
        dec(j);
      end;
    until i > j;

    if l < j then
      Sort(l,j);
    if i < r then 
      Sort(i,r);
  end;

begin
  if SL.Count > 0 then
  begin
    SL.BeginUpdate;
    Sort(0,SL.Count - 1);
    SL.EndUpdate;
  end;
end;

// ====================
// Sort a stringlist
// ====================

procedure TSuperSort.SortStrings(StringList : TStrings;
  Switches : array of string; Options : TSuperSortOptionSet = []);
var
  StartTime : TDateTime;
begin
  StartTime := Now;
  FDescending := (srtDescending in Options);
  FIgnoreCase := (srtIgnoreCase in Options);
  FIgnoreBlank := (srtIgnoreBlank in Options);
  FEvalNumeric := (srtEvalNumeric in Options);
  ResolveSwitches(Switches);

  if FDescending then
    QuickSortStrD(StringList)
  else
    QuickSortStrA(StringList);

  FSortTime := Now - StartTime;
end;

end.