home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
World_Of_Computer_Software-02-385-Vol-1of3.iso
/
t
/
tcsel003.zip
/
SCOPY.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-10-16
|
4KB
|
167 lines
{$A+,B-,D-,E+,F-,I+,L-,N-,O-,R+,S+,V-}
{$M 16384,65536,655360}
program scopy;
uses
dos,
tpdos,
sundry,
strings;
type
buffer_type = array[0..65519] of byte;
buffptr = ^buffer_type;
var
f1,f2 : file;
fname1,
fname2,
NewFName,
OldDir : PathStr;
SRec : SearchRec;
errorcode : integer;
buffer : buffptr;
const
MakeNewName : boolean = false;
FilesCopied : word = 0;
MaxHeapSize = 65520;
function IOCheck(stop : boolean; msg : string): boolean;
var
error : integer;
begin
error := IOResult;
IOCheck := (error = 0);
if error <> 0 then begin
writeln(msg);
if stop then begin
ChDir(OldDir);
halt(error);
end;
end;
end;
procedure Initialise;
var
temp : string;
dir : DirStr;
name : NameStr;
ext : ExtStr;
begin
if MaxAvail < MaxHeapSize then begin
writeln('Insufficient memory');
halt;
end
else
new(buffer);
{I-} GetDir(0,OldDir); {$I+} if IOCheck(true,'') then;
case ParamCount of
0: begin
writeln('No parameters provided');
halt;
end;
1: begin
TempStr := ParamStr(1);
if not ParsePath(TempStr,fname1,fname2) then begin
writeln('Invalid parameter');
halt;
end;
{$I-} ChDir(fname2); {$I+} if IOCheck(true,'') then;
end;
2: begin
TempStr := ParamStr(1);
if not ParsePath(TempStr,fname1,fname2) then begin
writeln('Invalid parameter');
halt;
end
else
{$I-} ChDir(fname2); {$I+} if IOCheck(true,'') then;
TempStr := ParamStr(2);
if not ParsePath(TempStr,fname2,temp) then begin
writeln('Invalid parameter');
halt;
end;
FSplit(fname2,dir,name,ext);
if length(name) <> 0 then
MakeNewName := true;
end;
else begin
writeln('Too many parameters');
halt;
end;
end; { case }
end; { Initialise }
procedure CopyFiles;
var
result : word;
function MakeNewFileName(fn : string): string;
var
temp : string;
dir : DirStr;
name : NameStr;
ext : ExtStr;
numb : word;
begin
numb := 0;
FSplit(fn,dir,name,ext);
repeat
inc(numb);
if numb > 255 then begin
writeln('Invalid file name');
halt(255);
end;
ext := copy(Numb2Hex(numb),2,3);
temp := dir + name + ext;
writeln(temp);
until not ExistFile(temp);
MakeNewFileName := temp;
end; { MakeNewFileName }
begin
FindFirst(fname1,AnyFile,Srec);
while Doserror = 0 do begin
if (SRec.attr and $19) = 0 then begin
if MakeNewName then
NewFName := fname2
else
NewFName := SRec.name;
if ExistFile(NewFName) then
NewFName := MakeNewFileName(NewFName);
{$I-}
writeln('Copying ',SRec.name,' > ',NewFName);
assign(f1,SRec.name);
reset(f1,1);
if { =1= } IOCheck(false,'1. Cannot copy '+fname1) then begin
assign(f2,fname2);
rewrite(f2,1);
if IOCheck(false,'2. Cannot copy '+SRec.name) then
repeat
BlockRead(f1,buffer^,MaxHeapSize);
if IOCheck(false,'3. Cannot copy '+SRec.name) then
result := 0
else begin
BlockWrite(f2,buffer^,result);
if IOCheck(false,'4. Cannot copy '+NewFName) then
result := 0;
end;
until result < MaxHeapSize;
close(f1); close(f2);
if IOCheck(false,'Error while copying '+SRec.name) then;
end; { =1= }
end; { if SRec.attr }
FindNext(Srec);
end; { while Doserror = 0 }
end; { CopyFiles }
begin
Initialise;
CopyFiles;
ChDir(OldDir);
end.