home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
RBBS in a Box Volume 1 #2
/
RBBS_vol1_no2.iso
/
014r
/
movewipe.zip
/
MOVEWIPE.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1986-11-29
|
21KB
|
1,037 lines
{╔════════════════════════════════════════════════════════════════════════╗
║ MOVE.COM by Lawrence Spiwak 08/19/86 ║
║ ║
╚════════════════════════════════════════════════════════════════════════╝}
program Move_File_Across_Subdirs;
const
BufSize = 20000;
type
String2 = string[2];
String4 = string[4];
String255 = string[255];
RegType = record ax,bx,cx,dx,bp,si,di,ds,es,flags : integer end;
var
NextFile : boolean;
InputFile : string[12];
OutputFile : string[12];
InPath : string[243];
OutPath : string[243];
File1 : string[255];
File2 : string[255];
FileIn : file;
FileOut : file;
Handle1 : integer;
Handle2 : integer;
Attribute : integer;
Names : array[1..600] of string[12];
DataBlock : array [1..BufSize] of byte;
CompBlock : array [1..BufSize] of byte;
ErrorA : byte;
I,J,K : integer;
BlocksRead : integer;
PutUp : string[37];
Address1 : string[37];
Address2 : string[19];
OKToProceed : boolean;
Regs : RegType;
Bytes1 : integer;
Bytes2 : byte;
Bytes3 : integer;
Bytes4 : byte;
Buffer : string[127];
CmdLine : string[127] absolute cseg:$80;
Sort : boolean;
Retry : boolean;
procedure Convert_Cases(var InputString : String255);
var
Temp : char;
A,B : integer;
begin
B:=length(InputString);
for A:=1 to B do begin
Temp:=InputString[A];
InputString[A]:=UpCase(Temp);
end;
end;
procedure Translate;
var
Index : integer;
begin
PutUp:='NNWDXHQD/BPL!azM`xqfmdd!Rqhx`lw0/01';
Address1:='311FVmjufqthux!Amue$03/4';
Address2:='Ndmaptsmf+!EM41:/2';
for Index:=1 to Length(PutUp) do
if Odd(Index) then
PutUp[Index]:=chr(ord(PutUp[Index])-1)
else
PutUp[Index]:=chr(ord(PutUp[Index])+1);
for Index:=1 to Length(Address1) do
if Odd(Index) then
Address1[Index]:=chr(ord(Address1[Index])-1)
else
Address1[Index]:=chr(ord(Address1[Index])+1);
for Index:=1 to Length(Address2) do
if Odd(Index) then
Address2[Index]:=chr(ord(Address2[Index])-1)
else
Address2[Index]:=chr(ord(Address2[Index])+1);
Writeln(PutUp);
Writeln;
end;
function LegalFile(FileName : String255) : Boolean;
var
Legal : boolean;
A : integer;
begin
Legal:=True;
for A:=1 to length(Filename) do
if not(FileName[A] in ['A'..'Z','\','*','?','-','_','$','.',':','1'..'9']) then
Legal:=False;
LegalFile:=Legal;
end;
procedure Get_Command_Line;
var
Temp : char;
TempFile : string[255];
A,B,C : integer;
begin
Buffer:=CmdLine;
{$V-} Convert_Cases(Buffer) {$V+};
A:=1;
while (Buffer[1]=' ') and (A<(Length(Buffer)+1)) do begin
Buffer:=Copy(Buffer,2,Length(Buffer)-1);
A:=A+1;
end;
A:=1; B:=0;
while (A<Length(Buffer)+1) and (B=0) do
if not (Buffer[A] in ['!'..'_']) then
B:=A
else
A:=A+1;
TempFile:=Copy(Buffer,1,B-1);
if Length(TempFile)<1 then begin
Writeln;
Write('Specify: ');
TextColor(White);
Writeln('MOVEWIPE source_file destination_file /S');
TextColor(Yellow);
Writeln;
Writeln('To move multiple files using wildcards, you must specify the destination path');
Writeln('only (or another wildcard). For example:');
Writeln;
Writeln(' MOVEWIPE d1:dir1\dir2\filename.* d2:dir3\dir4\*.*');
Writeln;
Writeln('Files selected with the wildcard cannot be moved to a single file.');
Writeln('Single files cannot be copied to wildcard files. Files selected with');
Writeln('the wildcard cannot be renamed in the copying process. However, single');
Writeln('files may be renamed by simply specifying a different destination name.');
Writeln('If the destination name is not found the current filename will be used.');
Writeln;
Writeln('An optional switch "/S" allows the user to sort the directory by filename.');
Writeln;
Writeln('If you find this program of use, please send $10 in contributions to:');
Writeln;
Writeln(' ',copy(PutUp,17,15));
Writeln(' ',Address1);
Writeln(' ',Address2);
Halt;
end;
C:=Length(Buffer)-B+1;
Buffer:=Copy(Buffer,B,C);
if not (Buffer[1]=' ') then begin
Writeln('Specify a Destination File');
Halt;
end
else
Buffer:=Copy(Buffer,2,Length(Buffer)-1);
if not (LegalFile(TempFile)) then begin
Writeln('Illegal source filename');
Halt;
end;
B:=0;
for A:=length(TempFile) downto 1 do
if (((TempFile[A]='\') or (TempFile[A]=':')) and (B=0)) then
B:=A;
if (B>0) then begin
A:=Length(TempFile);
InputFile:=Copy(TempFile,B+1,(A-B));
InPath:=Copy(TempFile,1,B);
if InputFile='' then begin
Writeln('Specify an Input File');
Halt;
end;
end
else begin
InputFile:=TempFile;
InPath:=''
end;
if (Length(InPath)=2) and (InPath[2]=':') then begin
GetDir(Ord(InPath[1])-64,InPath);
if InPath[Length(InPath)]<>'\' then
InPath:=InPath+'\';
end
else if InPath='' then begin
GetDir(0,InPath);
if InPath[Length(InPath)]<>'\' then
InPath:=InPath+'\';
end;
A:=1;
while (Buffer[1]=' ') and (A<Length(Buffer)) do begin
Buffer:=Copy(Buffer,2,Length(Buffer)-1);
A:=A+1;
end;
A:=1; B:=0;
while (A<128) and (B=0) do
if not (Buffer[A] in ['!'..'_']) then
B:=A
else
A:=A+1;
TempFile:=Copy(Buffer,1,B-1);
Buffer:=Copy(Buffer,B,Length(Buffer)-Length(TempFile));
B:=Length(TempFile);
if not (LegalFile(TempFile)) then begin
Writeln('Illegal destination filename');
Halt;
end;
B:=0;
for A:=length(TempFile) downto 1 do
if (((TempFile[A]='\') or (TempFile[A]=':')) and (B=0)) then B:=A;
if (B>0) then begin
A:=Length(TempFile);
OutputFile:=Copy(TempFile,B+1,(A-B));
OutPath:=Copy(TempFile,1,B);
end
else begin
OutputFile:=TempFile;
OutPath:='';
end;
if (Length(OutPath)=2) and (OutPath[2]=':') then begin
GetDir(Ord(OutPath[1])-64,OutPath);
if OutPath[Length(OutPath)]<>'\' then
OutPath:=OutPath+'\';
end
else if OutPath='' then begin
GetDir(0,OutPath);
if OutPath[Length(OutPath)]<>'\' then
OutPath:=OutPath+'\';
end;
A:=1;
while (Buffer[1]=' ') and (A<(Length(Buffer)+1)) do begin
Buffer:=Copy(Buffer,2,Length(Buffer)-1);
A:=A+1;
end;
end;
procedure Check_Input_File;
var
FileThere : boolean;
Index : integer;
Temp : integer;
begin
with Regs do begin
File1:=InPath+InputFile+chr(0);
Index:=0;
Attribute:=0;
Temp:=1;
while (Attribute<>Temp) and (Index<5) do begin
ax:=$4300; {Get attribute}
ds:=seg(File1);
dx:=ofs(File1)+1;
Intr($21,Regs);
Attribute:=cx;
ax:=$4300; {Get attribute again for safecheck. Check up to 5 times}
ds:=seg(File1);
dx:=ofs(File1)+1;
Intr($21,Regs);
Temp:=cx;
Index:=Index+1;
end;
if Attribute<>Temp then begin
TextColor(LightRed);
Writeln;
Writeln('Error reading attributes : Transient values returned. Program aborted.');
Halt;
end;
ax:=$4301; {Set attribute to null}
cx:=$0000;
ds:=seg(File1);
dx:=ofs(File1)+1;
Intr($21,Regs);
Assign(FileIn,InPath+InputFile);
{$I-} Reset(FileIn) {I$+};
FileThere:=(IOresult=0);
if FileThere then
Close(FileIn);
if not FileThere then begin
Writeln('File ',InPath,InputFile,' not found.');
Halt;
end;
end;
end;
procedure Check_Output_File;
var
Temp : char;
FileThere : boolean;
CheckFile : string[255];
begin
Temp:='Y';
File2:=OutPath+OutputFile+chr(0);
Assign(FileIn,OutPath+OutputFile);
{$I-} Reset(FileIn) {I$+};
FileThere:=(IOresult=0);
if FileThere then
Close(FileIn);
if FileThere then begin
ClrEOL;
Write('File ',OutPath+OutputFile,' found. Do you wish to overwrite? (Y/N)');
repeat
Read(kbd,Temp);
until (Upcase(Temp) in ['Y','N']);
end;
NextFile:=True;
if Upcase(Temp)='N' then begin
write(' N');
NextFile:=False;
end
else
with Regs do begin
ax:=$4301; {Get/Set Attribute}
cx:=0;
ds:=seg(File2);
dx:=ofs(File2)+1;
Intr($21,Regs);
if (flags and 1)>1 then
NextFile:=False;
end;
Write(chr(13));
ClrEOL;
if not(NextFile) then begin
Write(InPath,InputFile,' to ',OutPath,OutputFile,' ');
TextColor(LightRed+Blink);
if ((Regs.flags and 1)>1) and (Regs.ax = 5) then
Writeln('Access Denied.')
else
Writeln('Not Moved.');
TextColor(Yellow);
end;
end;
procedure Read_And_Write;
var
Error1 : integer;
Error2 : integer;
begin
File1:=InPath+InputFile+chr(0);
File2:=OutPath+OutputFile+chr(0);
Error1:=0;
Error2:=0;
with Regs do begin
ax:=$3D02; { Open Input File }
ds:=seg(File1);
dx:=ofs(File1)+1;
Intr($21,Regs);
if (flags and 1)>0 then begin
TextColor(LightRed);
Write('Error opening Source : ');
Case ax of
3: begin
Writeln('No such path. Program aborted.');
TextColor(Yellow);
Halt;
end;
4: begin
Writeln('No handle available. Close all files before attempting');
Writeln('MOVEWIPE. Program aborted.');
Halt;
end;
end;
end;
Handle1:=ax; { Store File Handle }
Error1:=flags and 1;
If Error1=0 then begin
ax:=$3C00; { Open/Create Output File }
ds:=seg(File2);
dx:=ofs(File2)+1;
cx:=$0000;
Intr($21,Regs);
if ((flags and 1)>0) and (ax=5) then begin
OutPath:=OutPath+OutputFile+'\';
OutputFile:=InputFile;
File2:=OutPath+OutputFile+chr(0);
ax:=$3C00; {Open/Create Again Assuming Directory}
ds:=seg(File2);
dx:=ofs(File2)+1;
cx:=$0000;
Intr($21,Regs);
end;
if (flags and 1)>0 then begin
TextColor(LightRed);
Writeln;
Write('Error creating Destination : ');
Case ax of
3: Writeln('No such path as ',Outpath);
4: begin
Writeln;
Writeln('No handle available. Close all files before attempting MOVEWIPE.');
end;
5: begin
Writeln('Access denied to file.');
Writeln('You may be trying to copy a file to a directory name.');
Writeln('Please check before continuing. Program aborted.');
end;
end;
TextColor(White);
Halt;
end;
Handle2:=ax;
Writeln(File1,'to ',File2); ClrEOL;
Write('Copying,');
Bytes1:=0;
Bytes2:=0;
Bytes3:=0;
Bytes4:=0;
repeat
ax:=$3F00; { Read bytes from Input File }
bx:=Handle1;
cx:=BufSize;
ds:=seg(DataBlock);
dx:=ofs(DataBlock);
Intr($21,Regs);
BlocksRead:=ax; { Number of bytes actually read }
Error1:=flags and 1;
if (BlocksRead=BufSize) then
Bytes2:=Bytes2+1
else
Bytes1:=BlocksRead;
if BlocksRead>0 then begin
ax:=$4000; { Write block to Output File }
bx:=Handle2;
cx:=BlocksRead;
ds:=seg(DataBlock);
dx:=ofs(DataBlock);
Intr($21,Regs);
end;
Error2:=flags and 1;
if (ax=BufSize) then
Bytes4:=Bytes4+1
else
Bytes3:=ax;
until (BlocksRead<>BufSize) or (ax<>BlocksRead) or (Error1=1) or (Error2=1);
end;
if (BlocksRead<>ax) or (Error1=1) or (Error2=1) then begin
if Error1=1 then
Write('error reading source file,')
else
Write('error writing destination file,');
OKToProceed:=False;
end
else
OKToProceed:=True;
end;
end;
procedure Verify_File;
var
I : integer;
begin
write(' verifying,');
with Regs do begin
ax:=$4200; {Goto beginning of file}
bx:=Handle1;
cx:=$0000;
dx:=$0000;
Intr($21,Regs);
ax:=$4200; {Goto beginning of file}
bx:=Handle2;
cx:=$0000;
dx:=$0000;
Intr($21,Regs);
{InLine($51/$56/$57/$50);
InLine($06/$1E/$07/$BE/DataBlock/$BF/CompBlock/$B9/$4E20/$8A/$24);
InLine($88/$25/$46/$47/$E2/$F8/$07);
InLine($58/$5F/$5E/$59);}
repeat
FillChar(DataBlock,SizeOf(DataBlock),0);
FillChar(CompBlock,SizeOf(CompBlock),0);
ax:=$3F00;
bx:=Handle1;
cx:=BufSize;
ds:=seg(DataBlock);
dx:=ofs(DataBlock);
Intr($21,Regs);
if ax>0 then begin
cx:=ax;
ax:=$3F00;
bx:=Handle2;
ds:=seg(CompBlock);
dx:=ofs(CompBlock);
Intr($21,Regs);
end;
ErrorA:=0;
I:=1;
While (I<=BufSize) and (ErrorA=0) do begin
if CompBlock[I]<>DataBlock[I] then
ErrorA:=1;
I:=I+1;
end;
{InLine($51/$56/$57/$50);
InLine($53/$06/$1E/$07/$BE/CompBlock/$BF/DataBlock/$B9/$4E20/$8A/$24);
InLine($8A/$FC/$8A/$25/$3A/$E7/$75/$06/$46/$47/$E2/$F2/$7A/$05);
InLine($C6/$06/ErrorA/$01/$407/$5B);
InLine($58/$5F/$5E/$59);}
if (ErrorA=1) then
OKToProceed:=False
else
OKToProceed:=True;
until (not OKToProceed) or (ax<>BufSize);
if OKToProceed then
Write(' pass,')
else
Write(' fail,');
end;
end;
procedure Close_Files;
begin
with regs do begin
ax:=$3E00; {Close Files}
bx:=Handle2;
Intr($21,Regs);
ax:=$3E00;
bx:=Handle1;
Intr($21,Regs);
ax:=$4301;
cx:=Attribute;
if not (OKToProceed) then begin
ds:=seg(File1);
dx:=ofs(File1)+1;
end
else begin
ds:=seg(File2);
dx:=ofs(File2)+1;
end;
Intr($21,Regs);
Write(' done.');
GotoXY(1,WhereY-1);
Write(File1,'to ',File2);
if (OKToProceed) then begin
TextColor(LightGreen);
Writeln(' Moved.');
TextColor(Yellow);
end
else begin
TextColor(LightRed+Blink);
Writeln(' Not moved.');
TextColor(Yellow);
end;
end;
end;
procedure Delete_Input;
var
Count : integer;
begin
Write(' wiping and deleting input,');
with Regs do begin
ax:=$4200; {Goto beginning of file}
bx:=Handle1;
cx:=$0000;
dx:=$0000;
Intr($21,Regs);
FillChar(DataBlock,SizeOf(DataBlock),0);
if (Bytes2<>0) then begin
for Count:=1 to Bytes2 do begin
ax:=$4000;
bx:=Handle1;
cx:=BufSize;
ds:=seg(DataBlock);
dx:=ofs(DataBlock);
Intr($21,Regs);
end;
end;
if (Bytes1<>0) then begin
ax:=$4000;
bx:=Handle1;
cx:=Bytes1;
ds:=seg(DataBlock);
dx:=ofs(DataBlock);
Intr($21,Regs);
end;
Close_Files;
ax:=$4100; {Delete file}
ds:=seg(File1);
dx:=ofs(File1)+1;
Intr($21,Regs);
K:=K+1;
end;
end;
procedure Delete_Output;
var
count : integer;
Temp : char;
begin
Write(' wiping and deleting output,');
with Regs do begin
ax:=$4200; {Goto beginning of file}
bx:=Handle2;
cx:=$0000;
dx:=$0000;
Intr($21,Regs);
FillChar(DataBlock,SizeOf(DataBlock),0);
if (Bytes4<>0) then begin
for Count:=1 to Bytes4 do begin
ax:=$4000;
bx:=Handle2;
cx:=BufSize;
ds:=seg(DataBlock);
dx:=ofs(DataBlock);
Intr($21,Regs);
end;
end;
if (Bytes3<>0) then begin
ax:=$4000;
bx:=Handle2;
cx:=Bytes3;
ds:=seg(DataBlock);
dx:=ofs(DataBlock);
Intr($21,Regs);
end;
Close_Files;
ax:=$4100; {Delete file}
ds:=seg(File2);
dx:=ofs(File2)+1;
Intr($21,Regs);
ClrEOL;
TextColor(LightRed);
if (J-K)>0 then
Write((J-K),' files left. ');
Write('Do you wish to Abort, Continue, or Retry (A/C/R)?');
Temp:=' ';
repeat
repeat
Sound(440);
Delay(100);
Sound(880);
Delay(100);
Until (KeyPressed);
Read(kbd,Temp);
Until (UpCase(Temp) in ['A','C','R']);
NoSound;
Write(chr(13));
ClrEOL;
TextColor(Yellow);
if (UpCase(Temp)='A') then
Halt;
if (UpCase(Temp)='R') then begin
Retry:=True;
GotoXY(1,WhereY-1);
ClrEOL;
end
else
Retry:=False;
end;
end;
procedure Sort_Dir(Num:integer);
var
I : integer;
Done : boolean;
Temp : string[20];
begin
if Num>1 then begin
repeat
Done:=True;
for I:=2 to Num do
if Names[I-1] > Names[I] then begin
Temp:=Names[I];
Names[I]:=Names[I-1];
Names[I-1]:=Temp;
Done:=False;
end;
until (Done);
end;
end;
procedure Dir_List;
var
DTA : array [1..53] of byte;
Mask : string [127];
NamR : string [20];
Error,I : integer;
Wild : boolean;
begin
J:=2;
FillChar(DTA,SizeOf(DTA),0);
FillChar(Mask,SizeOf(Mask),0);
FillChar(NamR,SizeOf(NamR),0);
with Regs do begin
ax:=$1A00;
ds:=seg(DTA);
dx:=ofs(DTA);
Intr($21,Regs);
Error:=0;
Mask:=InPath+InputFile+chr(0);
ax:=$4E00;
ds:=seg(Mask);
dx:=ofs(Mask)+1;
cx:=$0003;
Intr($21,Regs);
Error:=ax and $FF;
I:=1;
if (Error = 0) then repeat
NamR[I]:=chr(mem[seg(DTA):ofs(DTA)+29+I]);
I:=I+1;
until not (NamR[I-1] in [' '..'~']) or (I>20);
NamR[0]:=chr(I-1);
Names[1]:=NamR;
while (Error=0) and (J<601) do begin
Error:=0;
ax:=$4F00;
cx:=$0003;
Intr($21,Regs);
Error:=ax and $FF;
I:=1;
repeat
NamR[I]:=chr(mem[seg(DTA):ofs(DTA)+29+I]);
I:=I+1;
Until not (NamR[I-1] in [' '..'~']) or (I>20);
NamR[0]:=chr(I-1);
if (Error=0) then begin
Names[J]:=NamR;
J:=J+1;
end;
end;
Wild:=False;
K:=1;
for I:=1 to Length(InputFile) do
if (InputFile[I]='?') or (InputFile[I]='*') then
Wild:=True;
if Wild then begin
if Length(Buffer)<>0 then begin
if not (UpCase(Buffer[2])='S') then begin
Writeln('Switch not recognized. Directory will not be sorted.')
end
else
begin
Sort_Dir(J-1);
Writeln('Directory sort:');
end;
end;
Wild:=False;
if (OutputFile='') or (OutputFile='*.*') or (OutputFile='*') then begin
I:=1;
While (I<J) do begin
if Names[I]<>'' then begin
InputFile:=Names[I];
OutputFile:=Names[I];
if (InPath+InputFile)=(OutPath+OutputFile) then begin
Writeln('A file cannot be copied onto itself. Specify another directory or drive.');
Halt;
end;
Check_Input_File;
Check_Output_File;
Retry:=False;
repeat
if NextFile then begin
Read_And_Write;
if (OKToProceed) then
Verify_File;
if (OKToProceed) then
Delete_Input
else
Delete_Output;
end;
until (Retry=False);
end;
I:=I+1;
end;
end
else begin
OutPath:=Outpath+OutputFile+'\';
I:=1;
While (I<J) do begin
if Names[I]<>'' then begin
InputFile:=Names[I];
OutputFile:=Names[I];
if (InPath+InputFile)=(OutPath+OutputFile) then begin
Writeln('A file cannot be copied onto itself. Specify another directory or drive.');
Halt;
end;
Check_Input_File;
Check_Output_File;
Retry:=False;
repeat
if NextFile then begin
Read_And_Write;
if (OKToProceed) then
Verify_File;
if (OKToProceed) then
Delete_Input
else
Delete_Output;
end;
until (Retry=False);
end;
I:=I+1;
end;
end;
end
else begin
Wild:=False;
for I:=1 to Length(OutputFile) do
if (OutputFile[I]='?') or (OutputFile[I]='*') then
Wild:=True;
if Wild then begin
Writeln('Single files cannot be copied to a wildcard. Use a specific destination name.');
Halt;
end
else begin
if OutputFile='' then
OutputFile:=InputFile;
if (InPath+InputFile)=(OutPath+OutputFile) then begin
Writeln('A file cannot be copied onto itself. Specify another directory or drive.');
Halt;
end;
Check_Input_File;
Check_Output_File;
If NextFile then begin
Read_And_Write;
if (OKToProceed) then
Verify_File;
if (OKToProceed) then
Delete_Input
else
Delete_Output;
end;
end;
end;
end;
end;
BEGIN {Main program}
Translate;
OKToProceed:=True;
Get_Command_Line;
Dir_List;
ClrEOL;
END. {Main program}