home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
DP Tool Club 19
/
CD_ASCQ_19_010295.iso
/
vrac
/
m218_ch1.zip
/
MERGE118.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1994-09-17
|
12KB
|
427 lines
(* MERGEFILE v1.18 9/17/94
MERGE v1.18 released to the public domain on 9/17/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 had
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 serious programmers.
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 be
glad 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.18. Released to Public Domain by author Hal Parks (9/17/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. Do');
writeln(ScrnOut, ' not enter the same file name more than once on the command line.');
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;
check that "DosError = 0" (in the DOS unit) before erasing any files *)
FINDFIRST(FNames[3], 0, FileRec);
if DosError = 0 then
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 }