home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Frostbyte's 1980s DOS Shareware Collection
/
floppyshareware.zip
/
floppyshareware
/
USCX
/
TURBO-06.ZIP
/
LU-2.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1985-02-23
|
10KB
|
273 lines
procedure Extract;
var fname2: filename;
i, blocknum, bytenum: integer;
begin
w_make(15,65,20,23);
w_write_s(' Enter filename to extract: '); readln(fname2); w_writeln;
if length(fname2)>0 then begin
i := FindMember(fname2);
if i>0 then begin
if Dir[i]^.status = 0 then begin
assign(file2,fname2);
rewrite(file2);
with Dir[i]^ do begin
seek(library,index);
blocknum := 1;
bytenum := 0;
while blocknum <= length_of_member do begin
blockread(library,buffer,1);
if blocknum<length_of_member then
blockwrite(file2,buffer,1)
else begin
close(file2); {save disk info}
assign(SizeFile,fname2);
reset(SizeFile);
seek(SizeFile,filesize(SizeFile));
while bytenum < ((128 - PadCount) MOD 128) do begin
write(SizeFile,buffer[bytenum]);
bytenum := bytenum + 1
end;
close(SizeFile);
reset(file2); {for later close}
end;
blocknum := blocknum + 1
end;
end;
w_write_s(' Member "');
w_write_s(fname2);
w_write_s('" has been extracted.');
close(file2);
end
else if Dir[i]^.status = $FE then begin
w_write_s(' Member is erased - unerase before extracting');
end
else w_write_s(' INTERNAL ERROR #1 - Invalid member status');
end
else begin
w_write_s(' Member "');
w_write_s(fname2);
w_write_s('" is not in library! ');
end;
end;
end;
procedure Add;
label barge_in;
var fname2: filename;
EntryLength, EntryIndex, SizeOfFile, number, empty_i,i,x: integer;
ok : boolean;
begin
w_make(15,65,18,24);
number := 0; empty_i := 1;
while (number = 0) and (empty_i < NumEntries) do begin
if (Dir[empty_i]^.status=$FF) and (number=0) then
number := empty_i
else
empty_i := empty_i + 1;
end;
if number > 0 then begin
w_write_s(' Enter filename to add: '); readln(fname2); w_writeln;
if length(fname2)>0 then begin
i := FindMember(fname2);
if i <> 0 then begin
if Dir[i]^.status = 0 then begin
w_writeln;
w_write_s(' "');
w_write_s(fname2);
w_write_s('" is already a member!');
end
else if Dir[i]^.status = $FE then begin
w_write_s(' Added file will overwrite an erased member!');
w_writeln;
ok := confirm;
w_writeln;
if ok then begin
Dir[i]^.status := $FF;
Dir[i]^.name := ' ';
Dir[i]^.ext := ' ';
goto barge_in;
end;
end
else begin
w_writeln;
w_write_s(' INTERNAL ERROR #1 - Invalid member status');
end;
end
else begin
Barge_in: assign(SizeFile,fname2);
{$I-} reset(SizeFile) {$I+};
if IOresult=0 then begin
w_write_s(' Adding "');
w_write_s(fname2);
w_write_s('" to the library.');
w_writeln;
SizeOfFile := filesize(SizeFile);
close(SizeFile);
assign(file2,fname2);
reset(file2);
EntryIndex := filesize(library);
EntryLength := filesize(file2);
seek(library,EntryIndex);
while not(eof(file2)) do begin
blockread(file2,buffer,1);
blockwrite(library,buffer,1)
end;
close(file2);
fillchar(Dir[number]^,32,chr(0)); {status:=0}
Dir[number]^.index := EntryIndex;
Dir[number]^.length_of_member := EntryLength;
Dir[number]^.PadCount := (128 - (SizeOfFile MOD 128)) and $7F;
PutName(fname2,number);
unused := unused - 1;
active := active + 1;
w_write_s(' File "');
w_write_s(fname2);
w_write_s('" was added. ');
DirectoryChanged := true;
end
else begin
w_writeln;
w_write_s('File "');
w_write_s(fname2);
w_write_s('" was not found.');
end;
end;
end;
end
else begin
w_writeln;
w_write_s('There are no available entries to put this member.');
end;
end;
procedure Delete;
var fname2: filename;
i: integer;
ok: boolean;
begin
w_make(20,60,19,23);
w_write_s(' Enter member to delete: '); readln(fname2); w_writeln;
if length(fname2)>0 then begin
i := FindMember(fname2);
if i>0 then begin
if Dir[i]^.status = 0 then begin
ok := Confirm;
w_writeln;
w_write_s(' Member '); w_write_s(fname2);
if ok then begin
Dir[i]^.status := $FE;
deleted := deleted + 1;
active := active - 1;
w_write_s(' was deleted.');
DirectoryChanged := true;
end
else
w_write_s(' was NOT deleted.')
end
else begin (* status <> 0 *)
if dir[i]^.status = $FE then
w_write_s('member is already erased')
else
w_write_s(' INTERNAL ERROR #1 - Invalid member status');
end;
end
else begin
w_writeln; w_write_s(' "');
w_write_s(fname2); w_write_s('" does not exist.');
end;
end;
end;
procedure Undelete;
var fname2: filename;
i: integer;
ok: boolean;
begin
w_delete;
w_make(18,62,20,23);
w_write_s(' Enter member to unerase: '); readln(fname2); w_writeln;
if length(fname2)>0 then begin
i := FindMember(fname2);
if (i>0) then begin
if Dir[i]^.status = $FE then begin
Dir[i]^.status := 0;
deleted := deleted - 1;
active := active + 1;
w_write_s(' "');
w_write_s(fname2);
w_write_s('" was unerased.');
DirectoryChanged := true;
end
else w_write_s(' Can only unerase ERASED members!');
end
else begin
w_write_s(' "'); w_write_s(fname2);
w_write_s('" does not exist. ');
end;
end;
end;
procedure Reorganize;
var i, j: integer;
begin
w_make(17,64,21,23);
SortDir;
assign(file2,'WORK-$$$.LBR');
reset(library); rewrite(file2);
WriteDirectoryToDisk(file2);
for i:=1 to NumEntries-1 do
with Dir[i]^ do begin
if (status = 0) and (length_of_member > 0) then begin
w_gotoxy(1,1);
w_write_s(' Packing: "');
w_write_s(name); w_write_s(copy(' ',1,8-length(name)));
w_write_c('.');
w_write_s(ext);
w_write_s(copy(' ',1,3-length(ext)));
w_write_s('" sector 0 of ');
write(length_of_member);
w_gotoxy(33,1);
seek(library,index);
index := filepos(file2);
for j:=1 to length_of_member do begin
write(j:3,BS,BS,BS);
blockread (library,buffer,1);
blockwrite(file2, buffer,1)
end
end
end;
WriteDirectoryToDisk(file2);
close(file2); close(library);
erase(library); rename(file2,LibName);
reset(library);
end;
procedure Help;
begin
w_make(5,75,8,20);
w_write_s(' Library Utility commands:');
w_writeln;
w_write_s(' eXtract - copy a member from the library to its own file');
w_writeln;
w_write_s(' Add - add a new member (can NOT be already in library)');
w_writeln;
w_write_s(' Erase - removes a member from the library');
w_writeln;
w_write_s(' Unerase - reverses the effects of an erase');
w_writeln;
w_write_s(' Pack - compresses the library & discards erased members');
w_writeln;
w_write_s(' Quit - terminate this program');
w_writeln;
w_write_s(' Help, ? - gives this screen');
w_writeln;
w_writeln;
w_write_s(' Press <RETURN> when done reading message');
readln;
w_delete;
end;