POINT Software Programming/PPROG1.ISO/pascal/swag/sorting.swg/0054_Fast Sort Text Files.pas

Pascal/Delphi Source File | 1995-02-28 | 30.4 KB | 891 lines

{$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,P-,Q-,R-,S-,T-,V-,X-,Y-}
{$M 65520,1024,655360}

(* {$DEFINE NoDupes} *)
(* uncomment the above line if you don't want duplicate lines *)

(* {$DEFINE NoPlus} *)
(* uncomment the above line if you want to delete '+' characters
   terminating lines  *)

Program TSort;
 (*
   sort text file(s) in the current directory
   sort inputfile(s) outputfile
     case insensitive sort, skipping empty and duplicate lines

     inputfile(s) up to 248.
       DOS wildcards supported for input files
       input files are not altered
       abort if file error input file (file does not exist, read error)

     outputfile:
       if outputfile already does exist, it won't be sorted in memory,
       but instead only file merged with the temporary files
       ( so it has to be sorted already! ).

     setting DOS errorlevel to 0 on success, 1 if an error occurred.

   the more files to merge together, the slower the filemerge.
   all textlines will be written to temporary files, so there must be
   free disk space of at least the total size of the files to sort.

   if necessary, increase files= in config.sys and reboot,
   or run Quarterdeck's files.com or a similar program
   to increase the number of filehandles allowed by DOS
   (max 99 for DOS 2.x; max 254 for DOS 3.x or later).

   Author: Eddy Thilleman, september 1994
   written in Borland Pascal version 7.01
   Donated to the public domain. No rights reserved.
 *)

Uses
  Dos;

const
  NumbFiles= 254;
type
  fht      = array[1..NumbFiles] of byte;
var
  NewFHT   : fht;
  OldFHT   : longint;
  OldSize  : word;

Const
  NoFAttr : word =   $1C;  { dir-, volume-, system attributen }
  FAttr   : word =   $23;  { readonly-, hidden-, archive attributes }
  MaxNrLines = 10000;  { max # lines to sort in memory in one run }
  MaxNrFiles =   248;  { max 249 open files (248 temp. files + 1 dest.file) }
  BufSize    =  8192;  { 8 KB for input- and output buffers }
  SmallBufS  =  1024;  { 1 KB for input temp.files }

Type
  String3   = String[ 3];
  String12  = String[12];
  LineStr   = String;
  ptrLine   = ^LineStr;
  BufType   = array [1..BufSize] of char;
  SmallBufT = array [1..SmallBufS] of char;
  tTxtFile  = record
                TxtFile  : text;
                Line     : string;
                EndOfFile: boolean;
                Error    : boolean;
                SmallBuf : SmallBufT;
              end;
  pTxtFile  = ^tTxtFile;

Const
  WhiteSpace : string3 = #00#09#255;

Var
  MarkPtr   : pointer;        { marks start of Heapmemory }
  aPtrLines : array [1..MaxNrLines] of ptrLine;
  aPtrFiles : array [1..MaxNrFiles] of pTxtFile;
  Line0     : String;         { temporary line }
  Line1     : String;         { temporary line 1 for upper case }
  Line2     : String;         { temporary line 2 for upper case }
  NrLine    : word;           { current # of line in memory }
  NrLines   : word;           { number of lines in memory   }
  InputFile : text;           { input file   }
  OutputFile: text;           { output file  }
  DestFile  : String;         { filename of destination file }
  SourceBuf : BufType;        { source text buffer      }
  DestBuf   : BufType;        { destination text buffer }
  FR        : SearchRec;      { FileRecord              }
  FMask     : String12;       { FileMask                }
  TempDir   : String3;        { temporary directory     }
  TempFile  : String;         { temporary output file   }
  TempNr    : byte;           { for name temp. file     }
  tNr,tMaxNr: byte;           { for name temp. file     }
  Temp      : String3;        { name for temp. file     }
  Exists    : boolean;
  ParamNr   : byte;
  OldExitProc : Pointer;
  t         : ptrLine;
  Ready     : boolean;
  divisor   : word;           { divisor for showing # of lines merged
                                inversely proportional to # of files  }
  fName     : string12;       { for padding filename }
  display   : string[79];
  number    : string[ 5];


procedure SetCursorOff; assembler;
asm
  mov  AH,$01
  mov  CX,$2B0C
  int  $10
end;

procedure SetCursorOn; assembler;
asm
  mov  AH,$01
  mov  CX,$0B0C
  int  $10
end;


function HeapFunc( Size: word ): byte; far; assembler;
  { return value of
      0 : failure, run-time error, immediate abortion
      1 : failure, New or GetMem returns a nil pointer
      2 : success, retry
    Borland Pascal Language Guide, page 265
    "HeapError variable"
  }
asm
  mov  ax, 1
end  { HeapFunc };


procedure MakeNewFHT;
  { create a new expanded file handle table }
begin
  Oldsize := MemW[PrefixSeg:$32];            { Store the old FHT size     }
  OldFHT  := MemL[PrefixSeg:$34];            { Store the old FHT address  }
  FillChar(NewFHT,NumbFiles,$ff);            { Fill new table with 255    }
  MemW[PrefixSeg:$32] := NumbFiles;          { Put new size in the psp    }
  MemL[PrefixSeg:$34] := longint(@NewFHT);   { new FHT address in psp     }
  move(Mem[PrefixSeg:$19],NewFHT,$15);       { put contents of old to new }
end; { MakeNewFHT }


function OpenTextFile( var InF: text; name: string; var buffer; size: word ): boolean;
begin
  Assign( InF, Name );
  SetTextBuf( InF, buffer, size );
  Reset( InF );
  OpenTextFile := (IOResult = 0);
end  { OpenTextFile };


function CreateTextFile( var OutF: text; name: string; var buffer: BufType ): boolean;
begin
  Assign( OutF, Name );
  SetTextBuf( OutF, buffer );
  Rewrite( OutF );
  CreateTextFile := (IOResult = 0);
end  { CreateTextFile };


function Exist( Name : string ) : Boolean;
  { Return true if directory or file with the same name is found}
var
  F    : file;
  Attr : Word;
begin
  Assign( F, Name );
  GetFAttr( F, Attr );
  Exist := (DosError = 0)
end;


function fExist( fName: string ) : boolean;
begin
  fExist := ( FSearch(fName,'') <> '' );
end;


procedure UniekeEntry( var Naam : string3 );
const
  min   = 128;
var
  Nbyte : array [0..3] of byte absolute Naam;
  Exists : boolean;

begin
  Nbyte [0] :=  3;  { filename of 3 characters }

  Exists := True;
  Nbyte [1] := 255;
  while (Nbyte [1] >= min) and Exists do
  begin
    Nbyte [2] := 255;
    while (Nbyte [2] >= min) and Exists do
    begin
      Nbyte [3] := 255;
      while (Nbyte [3] >= min) and Exists do
      begin
        Exists := Exist( Naam );
        if Exists then dec (Nbyte [3]);
      end;
      if Exists then dec (Nbyte [2]);
    end;
    if Exists then dec (Nbyte [1]);
  end;
end;  { UniekeEntry }


function fRename( var Source, Dest: string ): boolean; assembler;
  { rename file or move file on same drive  }
  { *no* error checking!                    }
  { source and dest will be zero terminated }
  { by adding the ASCII zero char to both   }
  { so there must be room left for one char }
  { but that is not checked                 }
  { (byte length is not affected)           }
asm     push  ds          { save ds                       }
        xor   ax, ax      { clear ax                      }

        lds   si, source  { DS:SI = @source               }
        mov   al, [si]    { load length byte              }
        inc   si          { point to first char           }
        mov   dx, si      { DS:DX = @source (for dos)     }
        add   si, ax      { get beyond end of string      }
        mov   [si], ah    { zero terminated string        }

        les   di, dest    { ES:DI = @dest                 }
        mov   al, [di]    { load length byte              }
        inc   di          { point to first char           }
        mov   si, di      { ES:DI = @dest (for dos)       }
        add   si, ax      { get beyond end of string      }
        mov   [si], ah    { zero terminated string        }

        mov   ah, 56h     { dos function rename file      }
        mov   cl, 23h     { file attribute mask           }
        int   21h         { call dos to rename file       }

        mov   ax, 0       { assume false return value     }
        jc    @exit       { error, return false           }
        inc   ax          { return value true             }
@exit:  pop   ds          { restore ds                    }
end;  { fRename }


procedure StrCopy( var Str1, Str2: string ); assembler;
  { copy str1 to str2 }
asm     mov   dx, ds      { save DS                       }
        lds   si, str1    { load in DS:SI pointer to str1 }
        cld               { string operations forward     }
        les   di, str2    { load in ES:DI pointer to str2 }
        xor   ch, ch      { clear CH                      }
        mov   cl, [si]    { length str1 --> CX            }
        inc   cx          { include length byte           }
    rep movsb             { copy str1 to str2             }
@exit:  mov   ds, dx      { finished, restore DS          }
end  { StrCopy };


procedure Byte2zStr( n, width: byte; var str: string ); assembler;
  { Byte to string with leading zeros }
asm
        std                 { string operations backwards }
        mov   al, [n]       { numeric value to convert    }
        mov   cl, [width]   { width of str                }
        xor   ch, ch        { clear ch                    }
        jcxz  @exit         { done?                       }
        les   di, str       { adress of str               }
        mov   [di], cl      { length of str               }
        add   di, cx        { start with last char str    }
@start: aam                 { divide al by 10             }
        add   al, 30h       { convert remainder to char   }
        stosb               { store digit                 }
        xchg  al, ah        { swap remainder and quotient }
        dec   cl            { count down                  }
        jcxz  @exit         { done?                       }
        jmp   @start        { next digit                  }
@exit:
end  { Byte2zStr };


procedure Upper( var Str: String ); assembler;
asm      mov   dx, ds                 { save DS                   }
         mov   bx, 1961h              { upper- and lower limit    }
         lds   si, str                { DS:SI = @str              }
         cld                          { string operations forward }
         lodsb                        { load length byte          }
         mov   cl, al                 { and put it in cx          }
         xor   ch, ch                 { clear ch                  }
         shr   cx, 1                  { divide length by 2        }
         jnc   @part1                 { if lenght even, part1     }
         lodsb                        { load first char           }
         sub   al, bl                 { lowercase letter?         }
         cmp   al, bh                 { lowercase letter?         }
         ja    @part1                 { if no lowercase letter    }
  @loop: sub   byte ptr[si-1],'a'-'A' { convert to uppercase      }
 @part1: jcxz  @exit                  { done                      }
         lodsw                        { load next two chars       }
         sub   al, bl                 { lowercase letter?         }
         cmp   al, bh                 { lowercase letter?         }
         ja    @part2                 { if no lowercase letter    }
         sub   byte ptr[si-2],'a'-'A' { convert to uppercase      }
 @part2: dec   cx                     { count down                }
         sub   ah, bl                 { lowercase letter?         }
         cmp   ah, bh                 { lowercase letter?         }
         ja    @part1                 { if no lowercase letter    }
         jmp   @loop                  { convert to uppercase      }
  @exit: mov   ds, dx
end; { Upper }


procedure White2Space( var Str: string; const WhiteSpace: string ); assembler;
  { replace white space chars in Str by spaces
    the string WhiteSpace contains the chars to replace }
asm     push  ds                 { save DS                       }
        cld                      { string operations forwards    }
        les   di, str            { ES:DI points to Str           }
        xor   cx, cx             { clear cx                      }
        mov   cl, [di]           { length Str in cl              }
        jcxz  @exit              { if length of Str = 0, exit    }
        inc   di                 { point to 1st char of Str      }
        mov   dx, cx             { store length of Str           }
        mov   bx, di             { pointer to Str                }
        lds   si, WhiteSpace     { DS:SI points to WhiteSpace    }
        mov   ah, [si]           { load length of WhiteSpace     }

@start: cmp   ah, 0              { more chars WhiteSpace left?   }
        jz    @exit              { no, exit                      }
        inc   si                 { point to next char WhiteSpace }
        mov   al, [si]           { next char to hunt             }
        dec   ah                 { ah counting down              }
        xor   dh, dh             { clear dh                      }
        mov   cx, dx             { restore length of Str         }
        mov   di, bx             { restore pointer to Str        }
        mov   dh, ' '            { space char                    }
@scan:
  repne scasb                    { the hunt is on                }
        jnz   @next              { white space found?            }
        mov   [di-1], dh         { yes, replace that one         }
@next:  jcxz  @start             { if no more chars in Str       }
        jmp   @scan              { if more chars in Str          }
@exit:  pop   ds                 { we are finished.              }
end  { White2Space };


procedure RTrim( var Str: string ); assembler;
  { remove trailing spaces from str }
asm     { setup }
        std                      { string operations backwards   }
        les   di, str            { ES:DI points to Str           }
        xor   cx, cx             { clear cx                      }
        mov   cl, [di]           { length Str in cl              }
        jcxz  @exit              { if length of Str = 0, exit    }
        mov   bx, di             { bx points to Str              }
        add   di, cx             { start with last char in Str   }
        mov   al, ' '            { hunt for spaces               }

        { remove trailing spaces }
   repe scasb                    { the hunt is on                }
        jz    @null              { only spaces?                  }
        inc   cx                 { no, don't lose last char      }
@null:  mov   [bx], cl           { overwrite length byte of Str  }
@exit:
end  { RTrim };


procedure LTrim( var Str: string ); assembler;
  { remove leading white space from str }
asm     push  ds                 { save DS                            }
        cld                      { string operations forward          }
        lds   si, str            { DS:SI points to Str                }
        xor   cx, cx             { clear cx                           }
        mov   cl, [si]           { length Str --> cl                  }
        jcxz  @exit              { if length Str = 0, exit            }
        mov   bx, si             { save pointer to length byte of Str }
        inc   si                 { 1st char of Str                    }
        mov   di, si             { pointer to 1st char of Str --> di  }
        mov   al, ' '            { hunt for spaces                    }
        xor   dx, dx             { clear dx                           }

        { look for leading spaces }
   repe scasb                    { the hunt is on                     }
        jz    @done              { if only spaces, we are done        }
        inc   cx                 { no, don't lose 1st non-blank char  }
        dec   di                 { no, don't lose 1st non-blank char  }
        mov   dx, cx             { new lenght of Str                  }
        xchg  di, si             { swap si and di                     }
    rep movsb                    { move remaining part of Str         }
@done:  mov   [bx], dl           { new length of Str                  }
@exit:  pop   ds                 { finished, restore DS               }
end  { LTrim };


procedure Pad( var Str: String; len: byte ); assembler;
  { pad str with spaces while length str < len }
  { len must not be greater than size( str )   }
  { this is not checked!                       }
asm
             les   di, str            { ES:DI = @str               }
             cld                      { string operations forward  }
             xor   ax, ax             { clear ax                   }
             mov   al, [di]           { load length byte in al     }
             and   al, al             { length str = 0?            }
             jz    @exit              { yes, done                  }

             xor   cx, cx             { clear cx                   }
             mov   cl, len            { load new length            }
             mov   bl, cl             { store new length           }
             sub   cl, al             { len - length str           }
             jna   @exit              { length str >= len          }

             mov   [di], bl           { set new length             }
             add   di, ax             { get to end of str          }
             inc   di                 { get beyond end of str      }
             mov   ax, '  '           { fill with spaces           }
             shr   cx, 1              { (len-length) / 2           }
             jnc   @pad               { if (len-lenght) even, pad  }
             mov   [di], al           { if odd # of spaces to fill }
             jcxz  @exit              { if only one space, exit    }
             inc   di                 { next destination           }
   @pad: rep stosw                    { pad with spaces            }
  @exit:
end; { Pad }


function LineOK( var str: string ) : Boolean; assembler;
  { Line contains chars > ASCII 20h ? }
asm     mov   dx, ds         { save DS                          }
        xor   ax, ax         { assume false return value        }
        xor   cx, cx         { clear cx                         }
        lds   si, str        { load in DS:SI pointer to Str     }
        mov   cl, [si]       { length Str --> cx                }
        jcxz  @exit          { if no characters, exit           }
        inc   si             { point to 1st character           }

        { look for chars > ASCII 20h }
@start: mov   bl, [si]       { load character                   }
        cmp   bl, ' '        { char > ASCII 20h?                }
        ja    @yes           { yes, return true                 }
        inc   si             { next character                   }
        dec   cx             { count down                       }
        jcxz  @exit          { if no more characters left, exit }
        jmp   @start         { try again                        }
@yes:   mov   ax, 1          { return value true                }
@exit:  mov   ds, dx         { restore DS                       }
end  { LineOK };


procedure Sorting( min, max: word );
var
  n : byte;
  x : longint;

  {$S+}
  function IsLess( i1, i2: word ): boolean;
  begin
    StrCopy( aPtrLines[i1]^, Line1 );
    StrCopy( aPtrLines[i2]^, Line2 );
    Upper( Line1 );
    Upper( Line2 );
    IsLess := ( Line1 < Line2 );
  end;

  procedure Swap( var a, b: ptrLine );
  begin
    t := a;
    a := b;
    b := t;
  end;

  procedure QuickSort( left, right: word );
    { Case insensitive QuickSort }
  var
    lower, upper, middle: word;
  begin
    lower  := left;
    upper  := right;
    middle := (left+right) div 2;
    repeat
      while IsLess( lower , middle ) do inc( lower );
      while IsLess( middle, upper  ) do dec( upper );
      if lower <= upper then
      begin
        swap( aPtrLines[lower], aPtrLines[upper] );  { swap pointers }
        inc( lower );
        dec( upper );
      end;
    until lower > upper;
    if left  < upper then QuickSort( left , upper );
    if lower < right then QuickSort( lower, right );
  end  { QuickSort };
  {$S-}

  function Sorted: boolean;
  Var
    i: word;
  begin
    Sorted := True;
    x := 0;
    For i := 1 to Pred( Max ) do
      if IsLess( Succ( i ), i ) then
      begin
        Sorted := False;
        inc( x );
      end;
    { end for i loop }
  end;

begin  { Sorting }
  n := 0;
  Str( NrLines:5, number );
  display := fName + ':' + Temp + '  ' + number + ' lines   Sorting ';
  while not Sorted do
  begin
    inc( n );
    write( #13, display, n:5,' ',x:5 );
    QuickSort( min, max );
  end;
  writeln( #13, display, n:5,' ',x:5 );
end;  { Sorting }


procedure TestLines;
var
  i   : word;
  len : byte;

  procedure TrimLine;
  begin
    White2Space( aPtrLines[i]^, WhiteSpace );  { white space to spaces   }
    RTrim( aPtrLines[i]^ );                    { remove trailing spaces  }
    len := length( aPtrLines[i]^ );
  end;

{$IFDEF NoPlus}
  procedure TrimPlus;
  begin
    TrimLine;
    while aPtrLines[i]^[len] = '+' do
    begin
      dec( len );
      aPtrLines[i]^[0] := chr( len );
      TrimLine;
    end;
  end;
{$ENDIF}

begin
  for i := 1 to NrLines do
  begin
    len := length( aPtrLines[i]^ );
{$IFDEF NoPlus}
    TrimPlus;
{$ELSE}
    TrimLine;
{$ENDIF}
    if ((len = 0) or not LineOK( aPtrLines[i]^ )) then
      aPtrLines[i] := nil;             { invalid Line }
  end;
end;  { TestLine }


procedure Process( var SourceFile : string12 );
begin
  if OpenTextFile( InputFile, SourceFile, SourceBuf, BufSize ) then
  begin
    while not EOF( InputFile ) and (IOResult = 0) do
    begin
      inc( TempNr );
      Byte2zStr( TempNr, 3, Temp );
      TempFile := TempDir + '\' + Temp;
      write( fName, ':', Temp, '  ' );
      if CreateTextFile( OutputFile, TempFile, DestBuf ) then
      begin
        { read lines from input files }
        Mark( MarkPtr );
        NrLine := 1;
        if (Length( Line0 ) = 0) then ReadLn( InputFile, Line0 );
        GetMem( aPtrLines[NrLine], Length( Line0 ) + 1 );

        while not EOF(InputFile) and (IOResult = 0)
            and (NrLine <= MaxNrLines) and (aPtrLines[NrLine] <> nil) do
        begin
          StrCopy( Line0, aPtrLines[NrLine]^ );
          ReadLn( InputFile, Line0 );
          Inc( NrLine );
          if (NrLine <= MaxNrLines) then
            GetMem( aPtrLines[NrLine], Length( Line0 )+1 );
        end; { while not memory full }

        if ((NrLine <= MaxNrLines) and (aPtrLines[NrLine] <> nil)) then
        begin
          if EOF(InputFile) then
          begin
            aPtrLines[NrLine]^ := Line0;
            Line0 := '';
          end;
        end
        else
          Dec( NrLine );
        NrLines := NrLine;
        Write( NrLines:5, ' lines' );

        { Trim Lines }
        TestLines;

        { sort pointers }
        Sorting( 1, NrLines );

        { write sorted lines in temp files }
        for NrLine := 1 to NrLines do
        begin
          if (aPtrLines[NrLine] <> nil) then
            Writeln( OutputFile, aPtrLines[NrLine]^ );
          if (IOResult <> 0) then
          begin
            writeln( 'Error reading ', TempFile );
            halt( 1 );
          end;
          aPtrLines[NrLine]^ := '';
          aPtrLines[NrLine] := nil;
        end;
        Release( MarkPtr );
        Close( OutputFile );
      end  { if CreateTextFile }
      else
      begin
        writeln(' error creating file ', TempFile );
        Halt( 1 );
      end;  {if CreateTextFile }
    end;  {while not eof}
    Close( InputFile );
  end   { if OpenTextFile }
  else
    writeln(' error opening file ', SourceFile );
  { endif OpenTextFile }
end  { Sorting };


procedure MergeSort;
var nr: byte;
    count: longint;

{$IFDEF NoDupes}
  function IsEqual( i1, i2: word ): boolean;
  begin
    StrCopy( aPtrFiles[i1]^.Line, Line1 );
    StrCopy( aPtrFiles[i2]^.Line, Line2 );
    Upper( Line1 );
    Upper( Line2 );
    IsEqual := ( Line1 = Line2 );
  end;
{$ENDIF}

  function IsLess( i1, i2: word ): boolean;
  begin
    StrCopy( aPtrFiles[i1]^.Line, Line1 );
    StrCopy( aPtrFiles[i2]^.Line, Line2 );
    Upper( Line1 );
    Upper( Line2 );
    IsLess := ( Line1 < Line2 );
  end;

begin
  tNr := 1;
  tMaxNr := TempNr;
  if TempNr > MaxNrFiles then tMaxNr := MaxNrFiles;
  Mark( MarkPtr );

  New( aPtrFiles[tNr] );
  while (tNr < tMaxNr) and (aPtrFiles[tNr] <> nil) do
  begin
    Inc( tNr );
    New( aPtrFiles[tNr] );
  end;
  if (aPtrFiles[tNr] = nil) then dec( tNr );

  tMaxNr := tNr;
  for tNr := 1 to tMaxNr do    { open temp files and read first line }
  begin
    Byte2zStr( tNr, 3, Temp );
    TempFile := TempDir + '\' + Temp;
    if not OpenTextFile( aPtrFiles[tNr]^.TxtFile, TempFile, aPtrFiles[tNr]^.SmallBuf, SmallBufS ) then
    begin
      writeln( 'Error opening ', TempFile );
      halt( 1 );
    end;
    ReadLn( aPtrFiles[tNr]^.TxtFile, aPtrFiles[tNr]^.Line );
    if (IOResult <> 0) then
    begin
      writeln( 'Error reading ', TempFile );
      halt( 1 );
    end;
    aPtrFiles[tNr]^.EndOfFile := EOF( aPtrFiles[tNr]^.TxtFile );
    aPtrFiles[tNr]^.Error := (IOResult <> 0);
  end;
  divisor := (4000 div tMaxNr);

  if CreateTextFile( OutputFile, DestFile, DestBuf ) then
  begin
    count := 0;
    nr := 1;
    Ready := False;
    while not Ready do
    begin
      for tNr := 1 to tMaxNr do      { take alphabetically the first line }
      begin
        if tNr <> nr then
        begin
          if Length( aPtrFiles[tNr]^.Line ) > 0 then
          begin
{$IFDEF NoDupes}
            while IsEqual( tNr, nr )
            and not aPtrFiles[tNr]^.EndOfFile
            and not aPtrFiles[tNr]^.Error
            do     { no duplicates }
            begin
              ReadLn( aPtrFiles[tNr]^.TxtFile, aPtrFiles[tNr]^.Line );
              aPtrFiles[tNr]^.Error := (IOResult <> 0);
              aPtrFiles[tNr]^.EndOfFile := EOF( aPtrFiles[tNr]^.TxtFile );
            end;
{$ENDIF}
            if IsLess( tNr, nr ) then
              nr := tNr;
          end;  { if Length( aPtrFiles[tNr]^.Line ) > 0 }
        end;  { if tNr <> nr }
      end;  { for tNr := 1 to tMaxNr loop }

      if Length( aPtrFiles[nr]^.Line ) > 0 then
      begin
        StrCopy( aPtrFiles[nr]^.Line, Line1 );
        Upper( Line1 );
{$IFDEF NoDupes}
        if (Line1 <> Line0) then
        begin
{$ENDIF}
          writeln( OutputFile, aPtrFiles[nr]^.Line );
          if (IOResult <> 0) then
          begin
            writeln( 'Error writing ', DestFile );
            halt( 1 );
          end;
          inc( count );
          if (count mod divisor) = 0 then write( #13,'Merging ', count:7 );
{$IFDEF NoDupes}
        end;
{$ENDIF}
        StrCopy( aPtrFiles[nr]^.Line, Line0 );       { last written line }
        Upper( Line0 );
        aPtrFiles[nr]^.Line := '';
      end;

      StrCopy( aPtrFiles[nr]^.Line, Line1 );
      Upper( Line1 );
      while (not aPtrFiles[nr]^.EndOfFile and not aPtrFiles[nr]^.Error)
      and (
{$IFDEF NoDupes}
      (Line1 = Line0) or
{$ENDIF}
      (Length( aPtrFiles[nr]^.Line ) = 0)) do
      begin
        ReadLn( aPtrFiles[nr]^.TxtFile, aPtrFiles[nr]^.Line );
        aPtrFiles[nr]^.Error := (IOResult <> 0);
        aPtrFiles[nr]^.EndOfFile := EOF( aPtrFiles[nr]^.TxtFile );
        StrCopy( aPtrFiles[nr]^.Line, Line1 );
        Upper( Line1 );
      end;

      if Length( aPtrFiles[nr]^.Line ) = 0 then
      begin
        tNr := 1;        { the first non-empty line }
        while Length( aPtrFiles[tNr]^.Line ) = 0 do inc( tNr );
        if (tNr <= tMaxNr) then nr := tNr;
      end;

      Ready := True;
      tNr := 1;
      while (tNr <= tMaxNr) and Ready do         { check for more lines }
      begin
        if (Length( aPtrFiles[tNr]^.Line ) > 0) then Ready := False;
        inc( tNr );
      end;
    end;  { while not Ready }
    Close( OutputFile );
    Writeln( #13,'Merged ', count:7, ' lines' );
  end;  { if CreateTextFile }

  for tNr := 1 to tMaxNr do
  begin
    Close( aPtrFiles[tNr]^.TxtFile );      { close and delete all temp files }
    Erase( aPtrFiles[tNr]^.TxtFile );
  end;
  Release( MarkPtr );
end  { MergeSort };


{$F+}
procedure OurExitProc;
begin
  ExitProc := OldExitProc;

  { Restore Old File Handle Table }
  MemW[PrefixSeg:$32] := OldSize;
  MemL[PrefixSeg:$34] := OldFHT;

  SetCursorOn;
end;
{$F-}


begin
  {set up our exit handler}

  OldExitProc := ExitProc;
  ExitProc := @OurExitProc;

  if ParamCount > 1 then           { parameters: inputfile(s) outputfile }
  begin
    SetCursorOff;
    Line0 := '';
    UniekeEntry( TempDir );
    if not Exists then
    begin
      MkDir( TempDir );
      if (IOResult=0) then
      begin
        HeapError := @HeapFunc;
        DestFile := ParamStr( ParamCount );
        TempNr := 0;

        if fExist( DestFile ) then
        begin                              { if outputfile already exist }
          inc( TempNr );
          Byte2zStr( TempNr, 3, Temp );
          TempFile := TempDir + '\' + Temp;   { move it to the temp directory }
          if fRename( DestFile, TempFile ) then
            writeln( DestFile, ':', Temp, '  ' )
          else
            dec( TempNr );
        end;  { if fExist( DestFile ) }

        for ParamNr := 1 to (ParamCount-1) do         { all inputfile(s) }
        begin
          FMask := ParamStr( ParamNr );               { filemask         }
          FindFirst(FMask, FAttr, FR);
          while DosError = 0 do
          begin
            StrCopy( FR.Name, fName );
            Pad( fName, 12 );
            Process( FR.Name );
            FindNext( FR );
          end;
        end;  { all inputfile(s) }

        { if one temp file rename it to destination, else merge sort }
        if TempNr = 1 then
        begin
          Byte2zStr( TempNr, 3, Temp );
          TempFile := TempDir + '\' + Temp;
          if not fRename( TempFile, DestFile ) then
            writeln( 'Could not rename ',TempFile,' to ',DestFile );
          {}
        end
        else
        begin
          MakeNewFHT;
          MergeSort;
        end;
        RmDir( TempDir );     { remove temporary directory }
      end   { if IOResult=0 }
      else
        writeln( 'Cannot create temporary directory!' );
      { }
    end;  { if not Exists TempDir }
  end   { if ParamCount > 1 }
  else
    WriteLn( 'Sort inputfile(s) outputfile ' );
  { }
end.