HomeWare 14/HOMEWARE14.bin/utils2/merge215.arj/MERGE115.PAS

Pascal/Delphi Source File | 1994-04-20 | 12KB | 425 lines

(* MERGEFILE v1.15  4/20/94

   MERGE v1.15 released to the public domain on 4/20/94 by the author.  The
   code may not be exemplary, but the original was written in a hurry (which
   is also my excuse for why there are not any comments) by someone who has
   not used Pascal in a LONG, LONG TIME.  I probably won't spend much more
   time fixing this one up either; the shareware version will get most of my
   attention.  I'm supplying the code in case someone actually wants to play
   around with it or to provide a humorous diversion for the serious
   programmer.  I've tried to find all the bugs, but you never really know.
   If you have any comments or find a problem with this or the shareware
   version, I'd like to hear from you.  You're not required to be
   "registered."  You can contact me at the following address:

                                 Hal Parks
                                 404B W. Oak
                                 Carbondale, IL 62901

   See the HISTORY.DOC that should accompany this program for comments on the
   revisions.

   Happy merging!                                                          *)

program merge;

uses crt, dos;

const
   MinPar   = 1;
   MaxPar   = 5;
   MaxOpt   = 2;
   MinFil   = 1;
   MaxFil   = 3;
   MaxStr   = 255;
   ProgName = '   MERGEFILE v1.15.  Released to Public Domain by author Hal Parks (4/20/94)';
   HelpMsg  = 'For help, enter MERGE without any parameters.';

type
   namstrg  = string[MaxStr];
   namearr  = array[1..MaxFil] of namstrg;

var
   ScrnOut,               (* so screen output can be redirected *)
   List1In,
   List2In,
   MergeOut : text;
   Line1,
   Line2,
   Line1C,
   Line2C,
   LastLine,
   FName    : namstrg;
   FNames   : namearr;
   ErCode,
   FilCnt,
   OptCnt   : integer;
   Ascend,
   CaseSen,
   NoDup    : boolean;

function Upper(name:namstrg) : namstrg;

var x:integer;

begin
   for x := 1 to length(name) do
      name[x] := upcase(name[x]);
   Upper := name
end; { function Upper }

procedure Help;

begin
   writeln(ScrnOut);
   writeln(ScrnOut, ProgName);
   writeln(ScrnOut);
   writeln(ScrnOut, '       Syntax:  MERGE FileName1 [FileName2] [FileName3] [/C] [/D] [/K]');
   writeln(ScrnOut);
   writeln(ScrnOut, '   FileName1 and FileName2 are the input files and must both be sorted lists.');
   writeln(ScrnOut, '   The merged list is written to FileName3 if it is given (the input files');
   writeln(ScrnOut, '   are unchanged), otherwise the last file name serves as both an input and');
   writeln(ScrnOut, '   the output file and is overwritten.  Entering only one file name "merges"');
   writeln(ScrnOut, '   the file on itself (e.g., to remove duplicates from a sorted list).  MERGE');
   writeln(ScrnOut, '   defaults to case sensitive in ascending order ("H" will appear before');
   writeln(ScrnOut, '   "h"), using the entire input line as the merge key, and discarding any');
   writeln(ScrnOut, '   duplicates in either or both input files.  Entering "/C" (without the');
   writeln(ScrnOut, '   quotes) on the command line results in the merge not being case sensitive');
   writeln(ScrnOut, '   and "/K" will keep all duplicates.  Using "/D" will cause the merge to be');
   writeln(ScrnOut, '   in descending order (the lists must also be sorted in descending order).');
   writeln(ScrnOut, '   Lines up to 255 characters can be merged.  If the files to merge are not');
   writeln(ScrnOut, '   in the current directory, the full path must be entered with the file');
   writeln(ScrnOut, '   name.  MERGE does not need to be in the same directory as the files if it');
   writeln(ScrnOut, '   is on the path or invoked by specifying its directory.  File names and');
   writeln(ScrnOut, '   options are not case sensitive and can be entered in any sequence.');
   writeln(ScrnOut, '   Entering MERGE without any parameters will display this HELP screen.');
   writeln(ScrnOut);
   writeln(ScrnOut, 'Happy Merging! ');
   close(ScrnOut);
   HALT(0)
end; { procedure Help }

procedure Error;

begin
   writeln(ScrnOut);

   case ErCode of
     8 : writeln(ScrnOut, 'Aborting - "', LastLine, '" is not a valid option.');

     7 : writeln(ScrnOut, 'Aborting - there is a maximum of three filenames.');

     6 : writeln(ScrnOut, 'Aborting - no filename specified.');

     5 : writeln(ScrnOut, 'Aborting - incorrect use of parameters and/or options.');

     4 : writeln(ScrnOut, 'Aborting - too many parameters on the command line.');

  1, 3 : begin
            writeln(ScrnOut, 'Aborting - "', FNames[1], '" not found.');
            if (ErCode = 3) then
               writeln(ScrnOut, '         - "', FNames[2], '" not found.')
         end;

     2 : writeln(ScrnOut, 'Aborting - "', FNames[2], '" not found.')
   end; { case ErCode }

   writeln(ScrnOut);
   writeln(ScrnOut, HelpMsg);
   close(ScrnOut);
   HALT(ErCode)
end; { procedure Error }

procedure Parse;

var x:integer;

function OptionC(option:namstrg) : boolean;

begin
   if option = '/C' then OptionC := true
    else OptionC := false
end; { OptionC }

function OptionD(option:namstrg) : boolean;

begin
   if option = '/D' then OptionD := true
    else OptionD := false
end; { OptionD }

function OptionK(option:namstrg) : boolean;

begin
   if option = '/K' then OptionK := true
    else OptionK := false
end; { OptionK }

(* So there is a comment or two.  I had to put this function in because while
   playing around with the program I found that if you stuck in an invalid
   option switch, the code would try to find a file by that name and strange
   things could happen. *)

function NotOption(option:namstrg) : boolean;

begin
   if pos('/',option) = 1 then NotOption := true
    else NotOption := false
end; { NotOption }

begin { procedure Parse }
   x := 0;
   FilCnt := 0;
   OptCnt := 0;
   NoDup := true;
   Ascend := true;
   CaseSen := true;

   if paramcount > MaxPar then ErCode := 4
    else

      while (x < paramcount) and (ErCode = 0) do
      begin
         x := x + 1;
         FName := Upper(paramstr(x));

         if OptionC(FName) then
         begin
            OptCnt := OptCnt + 1;
            CaseSen := false
         end

          else if OptionD(FName) then
         begin
            OptCnt := OptCnt + 1;
            Ascend := false
         end

          else if OptionK(FName) then
         begin
            OptCnt := OptCnt + 1;
            NoDup := false
         end

          else if NotOption(FName) then
         begin
            LastLine := FName;
            ErCode := 8
         end

          else
         begin
            FilCnt := FilCnt + 1;
            if FilCnt <= MaxFil then FNames[FilCnt] := FName
             else ErCode := 7
         end { if else }
      end; { while }

   if ErCode = 0 then
      if OptCnt > MaxOpt then ErCode := 5
       else if FilCnt < MinFil then ErCode := 6;

   if ErCode > 0 then Error
end; { procedure Parse }

procedure GetParam;

var path : dirstr;
    name : namestr;
     ext : extstr;

function FileExists(var fil:text) : boolean;

begin
   {$i-} reset(fil); close(fil); {$i+}
   FileExists := (IoResult=0)
end; { FileExists }

procedure OutExists(name:namstrg);

var ch:char;

begin
   writeln;
   write('"', name, '" exists.  Overwrite it? (Y/N) ');
   ch := readkey;
   writeln(ch);
   if upcase(ch) <> 'Y' then
   begin
      close(ScrnOut);
      HALT(0)
   end
end; { OutExists }

begin { procedure GetParam }
   Parse;

(* use Turbo Pascal FEXPAND function to store the full path for "FName" *)

   FNames[1] := FEXPAND(FNames[1]);
   assign(List1In, FNames[1]);
   if not FileExists(List1In) then ErCode := 1
    else if FilCnt = 1 then OutExists(FNames[1]);

   if FilCnt > 1 then
   begin
      FNames[2] := FEXPAND(FNames[2]);
      assign(List2In, FNames[2]);
      if not FileExists(List2In) then ErCode := ErCode + 2
       else if (FilCnt = 2) and (ErCode = 0) then OutExists(FNames[2])
   end;

   if ErCode > 0 then Error;

(* oops, a little problem I overlooked when I got rid of the CLEANUP
   procedure and just renamed the "temp" file with the output file's name: if
   your current directory wasn't the same directory as the input files, the
   output file wouldn't be in the right directory; use Turbo Pascal FSPLIT
   procedure to get the path to the output file if we need a work file so it
   will be in the right directory *)

   if FilCnt = 3 then FNames[3] := FEXPAND(FNames[3])
    else
   BEGIN
      if FilCnt = 1 then FSPLIT(FNames[1], path, name, ext)
       else FSPLIT(FNames[2], path, name, ext);
      FNames[3] := path + '#temp_m#.$$$'
   END;

   assign(MergeOut, FNames[3]);
   if (FilCnt = 3) and FileExists(MergeOut) then OutExists(FNames[3]);

   reset(List1In);
   if FilCnt > 1 then reset(List2In);
   rewrite(MergeOut)
end; { procedure GetParam }

procedure DoMerge;

var FileRec : SearchRec;

procedure DoLine1;
begin
   if Line1C <> LastLine then
   begin
      LastLine := Line1C;
      writeln(MergeOut, Line1)
   end
    else if not NoDup then writeln(MergeOut, Line1);

   readln(List1In, Line1);
   Line1C := Line1;
   if not CaseSen then Line1C := Upper(Line1C)
end; { DoLine1 }

procedure DoLine2;
begin
   if Line2C <> LastLine then
   begin
      LastLine := Line2C;
      writeln(MergeOut, Line2)
   end
    else if not NoDup then writeln(MergeOut, Line2);

   readln(List2In, Line2);
   Line2C := Line2;
   if not CaseSen then Line2C := Upper(Line2C)
end; { DoLine2 }

procedure DoLine12;
begin
   if Line1C <> LastLine then
   begin
      LastLine := Line1C;
      writeln(MergeOut, Line1);
      if not NoDup then writeln(MergeOut, Line2)
   end
    else if not NoDup then
   begin
      writeln(MergeOut, Line1);
      writeln(MergeOut, Line2)
   end;

   readln(List1In, Line1);
   readln(List2In, Line2);
   Line1C := Line1;
   Line2C := Line2;

   if not CaseSen then
   begin
      Line1C := Upper(Line1C);
      Line2C := Upper(Line2C)
   end
end; { DoLine12 }

begin { procedure DoMerge }
   GetParam;
   readln(List1In, Line1);
   Line1C := Line1;

   if FilCnt = 1 then Line2C := ''
    else
   begin
      readln(List2In, Line2);
      Line2C := Line2
   end;

   if not CaseSen then
   begin
      Line1C := Upper(Line1C);
      Line2C := Upper(Line2C)
   end;

(* One more comment to remind myself why I'm reading/writing until the line is
   empty instead of EOF:  EOF becomes true when the last line is read, and
   since I'm doing a priming read, if I did the "while" until EOF, I would
   lose the last line of the input file; it would not get the chance to
   "writeln". *)

   LastLine := '';
   while (Line1C <> '') and (Line2C <> '') do
      if Line1C = Line2C then DoLine12
       else if Ascend then
         if Line1C < Line2C then DoLine1
          else DoLine2
       else if Line1C > Line2C then DoLine1
       else DoLine2;

   while Line1C <> '' do
      DoLine1;

   while Line2C <> '' do
      DoLine2;

   close(List1In);
   if FilCnt > 1 then close(List2In);
   close(MergeOut);

(* I added this so an input file wouldn't be deleted if an error caused the
   output file's size to be zero; use Turbo Pascal FINDFIRST procedure to get
   the file size ("FileRec" is type "SearchRec" defined in the DOS unit    *)

   FINDFIRST(FNames[3], 0, FileRec);
   if FileRec.Size = 0 then erase(MergeOut)
    else if FilCnt = 1 then
   begin
      erase(List1In);
      rename(MergeOut, FNames[1])
   end
    else if FilCnt = 2 then
   begin
      erase(List2In);
      rename(MergeOut, FNames[2])
   end;

   close(ScrnOut);
   HALT(0)
end; { procedure DoMerge }

begin { Merge }
   ErCode := 0;
   assign(ScrnOut, '');
   rewrite(ScrnOut);
   if paramcount < MinPar then Help else DoMerge
end. { Merge }