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