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 >
Pascal/Delphi Source File  |  1985-02-23  |  10KB  |  273 lines
  1.  
  2.   procedure Extract;
  3.   var fname2: filename;
  4.       i, blocknum, bytenum: integer;
  5.   begin
  6.       w_make(15,65,20,23);
  7.       w_write_s(' Enter filename to extract: ');  readln(fname2); w_writeln;
  8.       if length(fname2)>0 then begin
  9.           i := FindMember(fname2);
  10.           if i>0 then begin
  11.               if Dir[i]^.status = 0 then begin
  12.                   assign(file2,fname2);
  13.                   rewrite(file2);
  14.                   with Dir[i]^ do begin
  15.                       seek(library,index);
  16.                       blocknum := 1;
  17.                       bytenum := 0;
  18.                       while blocknum <= length_of_member do begin
  19.                           blockread(library,buffer,1);
  20.                           if blocknum<length_of_member then
  21.                               blockwrite(file2,buffer,1)
  22.                           else begin
  23.                               close(file2); {save disk info}
  24.                               assign(SizeFile,fname2);
  25.                               reset(SizeFile);
  26.                               seek(SizeFile,filesize(SizeFile));
  27.                               while bytenum < ((128 - PadCount) MOD 128) do begin
  28.                                   write(SizeFile,buffer[bytenum]);
  29.                                   bytenum := bytenum + 1
  30.                               end;
  31.                               close(SizeFile);
  32.                               reset(file2); {for later close}
  33.                           end;
  34.                           blocknum := blocknum + 1
  35.                       end;
  36.                   end;
  37.                   w_write_s(' Member "');
  38.                   w_write_s(fname2);
  39.                   w_write_s('" has been extracted.');
  40.                   close(file2);
  41.               end
  42.               else if Dir[i]^.status = $FE then begin
  43.                   w_write_s(' Member is erased - unerase before extracting');
  44.               end
  45.               else w_write_s(' INTERNAL ERROR #1 - Invalid member status');
  46.           end
  47.           else begin
  48.               w_write_s(' Member "');
  49.               w_write_s(fname2);
  50.               w_write_s('" is not in library!       ');
  51.           end;
  52.       end;
  53.   end;
  54.  
  55.   procedure Add;
  56.   label barge_in;
  57.  
  58.   var fname2: filename;
  59.       EntryLength, EntryIndex, SizeOfFile, number, empty_i,i,x: integer;
  60.       ok : boolean;
  61.  
  62.   begin
  63.       w_make(15,65,18,24);
  64.       number := 0;   empty_i := 1;
  65.       while (number = 0) and (empty_i < NumEntries) do begin
  66.           if (Dir[empty_i]^.status=$FF) and (number=0) then
  67.               number := empty_i
  68.           else
  69.               empty_i := empty_i + 1;
  70.       end;
  71.  
  72.       if number > 0 then begin
  73.           w_write_s(' Enter filename to add: ');  readln(fname2); w_writeln;
  74.           if length(fname2)>0 then begin
  75.               i := FindMember(fname2);
  76.               if i <> 0 then begin
  77.                   if Dir[i]^.status = 0 then begin
  78.                       w_writeln;
  79.                       w_write_s(' "');
  80.                       w_write_s(fname2);
  81.                       w_write_s('" is already a member!');
  82.                   end
  83.                   else if Dir[i]^.status = $FE then begin
  84.                       w_write_s(' Added file will overwrite an erased member!');
  85.                       w_writeln;
  86.                       ok := confirm;
  87.                       w_writeln;
  88.                       if ok then begin
  89.                           Dir[i]^.status := $FF;
  90.                           Dir[i]^.name   := '        ';
  91.                           Dir[i]^.ext    := '   ';
  92.                           goto barge_in;
  93.                       end;
  94.                   end
  95.                   else begin
  96.                       w_writeln;
  97.                       w_write_s(' INTERNAL ERROR #1 - Invalid member status');
  98.                   end;
  99.               end
  100.               else begin
  101. Barge_in:         assign(SizeFile,fname2);
  102.             {$I-} reset(SizeFile) {$I+};
  103.                   if IOresult=0 then begin
  104.                       w_write_s(' Adding "');
  105.                       w_write_s(fname2);
  106.                       w_write_s('" to the library.');
  107.                       w_writeln;
  108.                       SizeOfFile := filesize(SizeFile);
  109.                       close(SizeFile);
  110.                       assign(file2,fname2);
  111.                       reset(file2);
  112.                       EntryIndex  := filesize(library);
  113.                       EntryLength := filesize(file2);
  114.                       seek(library,EntryIndex);
  115.                       while not(eof(file2)) do begin
  116.                           blockread(file2,buffer,1);
  117.                           blockwrite(library,buffer,1)
  118.                       end;
  119.                       close(file2);
  120.                       fillchar(Dir[number]^,32,chr(0)); {status:=0}
  121.                       Dir[number]^.index  := EntryIndex;
  122.                       Dir[number]^.length_of_member := EntryLength;
  123.                       Dir[number]^.PadCount := (128 - (SizeOfFile MOD 128)) and $7F;
  124.                       PutName(fname2,number);
  125.                       unused := unused - 1;
  126.                       active := active + 1;
  127.                       w_write_s(' File "');
  128.                       w_write_s(fname2);
  129.                       w_write_s('" was added.    ');
  130.                       DirectoryChanged := true;
  131.                   end
  132.                   else begin
  133.                       w_writeln;
  134.                       w_write_s('File "');
  135.                       w_write_s(fname2);
  136.                       w_write_s('" was not found.');
  137.                   end;
  138.               end;
  139.           end;
  140.       end
  141.       else begin
  142.           w_writeln;
  143.           w_write_s('There are no available entries to put this member.');
  144.       end;
  145.   end;
  146.  
  147.   procedure Delete;
  148.   var fname2: filename;
  149.       i: integer;
  150.       ok: boolean;
  151.   begin
  152.       w_make(20,60,19,23);
  153.       w_write_s(' Enter member to delete: ');  readln(fname2); w_writeln;
  154.       if length(fname2)>0 then begin
  155.           i := FindMember(fname2);
  156.           if i>0 then begin
  157.               if Dir[i]^.status = 0 then begin
  158.                   ok := Confirm;
  159.                   w_writeln;
  160.                   w_write_s(' Member '); w_write_s(fname2);
  161.                   if ok then begin
  162.                       Dir[i]^.status := $FE;
  163.                       deleted := deleted + 1;
  164.                       active := active - 1;
  165.                       w_write_s(' was deleted.');
  166.                       DirectoryChanged := true;
  167.                   end
  168.                   else
  169.                       w_write_s(' was NOT deleted.')
  170.               end
  171.               else begin  (* status <> 0 *)
  172.                   if dir[i]^.status = $FE then
  173.                       w_write_s('member is already erased')
  174.                   else
  175.                       w_write_s(' INTERNAL ERROR #1 - Invalid member status');
  176.               end;
  177.           end
  178.           else begin
  179.               w_writeln; w_write_s(' "');
  180.               w_write_s(fname2); w_write_s('" does not exist.');
  181.           end;
  182.       end;
  183.   end;
  184.  
  185.   procedure Undelete;
  186.   var fname2: filename;
  187.       i: integer;
  188.       ok: boolean;
  189.   begin
  190.       w_delete;
  191.       w_make(18,62,20,23);
  192.       w_write_s(' Enter member to unerase: ');  readln(fname2); w_writeln;
  193.       if length(fname2)>0 then begin
  194.           i := FindMember(fname2);
  195.           if (i>0) then begin
  196.               if Dir[i]^.status = $FE then begin
  197.                   Dir[i]^.status := 0;
  198.                   deleted := deleted - 1;
  199.                   active := active + 1;
  200.                   w_write_s(' "');
  201.                   w_write_s(fname2);
  202.                   w_write_s('" was unerased.');
  203.                   DirectoryChanged := true;
  204.               end
  205.               else w_write_s(' Can only unerase ERASED members!');
  206.           end
  207.           else begin
  208.               w_write_s(' "'); w_write_s(fname2);
  209.               w_write_s('" does not exist.    ');
  210.           end;
  211.       end;
  212.   end;
  213.  
  214.   procedure Reorganize;
  215.   var i, j: integer;
  216.   begin
  217.       w_make(17,64,21,23);
  218.       SortDir;
  219.       assign(file2,'WORK-$$$.LBR');
  220.       reset(library);   rewrite(file2);
  221.       WriteDirectoryToDisk(file2);
  222.       for i:=1 to NumEntries-1 do
  223.           with Dir[i]^ do begin
  224.               if (status = 0) and (length_of_member > 0) then begin
  225.                  w_gotoxy(1,1);
  226.                  w_write_s(' Packing: "');
  227.                  w_write_s(name); w_write_s(copy('        ',1,8-length(name)));
  228.                  w_write_c('.');
  229.                  w_write_s(ext);
  230.                  w_write_s(copy('   ',1,3-length(ext)));
  231.                  w_write_s('" sector   0 of ');
  232.                  write(length_of_member);
  233.                  w_gotoxy(33,1);
  234.                  seek(library,index);
  235.                  index := filepos(file2);
  236.                  for j:=1 to length_of_member do begin
  237.                       write(j:3,BS,BS,BS);
  238.                       blockread (library,buffer,1);
  239.                       blockwrite(file2,  buffer,1)
  240.                  end
  241.               end
  242.           end;
  243.       WriteDirectoryToDisk(file2);
  244.       close(file2);     close(library);
  245.       erase(library);   rename(file2,LibName);
  246.       reset(library);
  247.   end;
  248.  
  249.   procedure Help;
  250.   begin
  251.       w_make(5,75,8,20);
  252.       w_write_s('                   Library Utility commands:');
  253.       w_writeln;
  254.       w_write_s(' eXtract   - copy a member from the library to its own file');
  255.       w_writeln;
  256.       w_write_s(' Add       - add a new member (can NOT be already in library)');
  257.       w_writeln;
  258.       w_write_s(' Erase     - removes a member from the library');
  259.       w_writeln;
  260.       w_write_s(' Unerase   - reverses the effects of an erase');
  261.       w_writeln;
  262.       w_write_s(' Pack      - compresses the library & discards erased members');
  263.       w_writeln;
  264.       w_write_s(' Quit      - terminate this program');
  265.       w_writeln;
  266.       w_write_s(' Help, ?   - gives this screen');
  267.       w_writeln;
  268.       w_writeln;
  269.       w_write_s('        Press <RETURN> when done reading message');
  270.       readln;
  271.       w_delete;
  272.   end;
  273.