home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / TURBOPAS / TP / UTL2 / LU11.PZS / LU11.PAS
Pascal/Delphi Source File  |  2000-06-30  |  17KB  |  542 lines
  1. program LibraryUtility;
  2. { written 10/09/84 by Steve Freeman
  3.   This program was written to function as Gary Novosielski's LU.  As such it
  4.   will function as a utility to manipulate library members under any operating
  5.   system which will support TURBO Pascal.  Minor rewrites may be necessary for
  6.   other versions of Pascal.
  7.   This program is placed into the Public Domain by the author and, as a Public
  8.   Domain program, may NOT be used for commercial purposes.}
  9. { modified by R.T. Moss 10/12/85 for Turbo Pascal Version 2.0
  10.   original program had fatal I/O errors at runtime.
  11.   changed version number to 1.10
  12.   added 1K buffer for faster Add & Extract }
  13.  
  14. const ProgramVersion = '1.10';
  15.       BufferSize = 127;      { maximum size of data buffer - 1 }
  16.       EntriesPerBuffer = 4;  { (BufferSize+1)/32 }
  17.       maxent = 128;          { maximum dir entries this program will take }
  18.       BigBuffSize = 1023;    { large size for buffer to speedup Add & Extract }
  19.  
  20. type TimeType = integer;
  21.      FileNameType = array[1..11] of char;
  22.      LibFileType = file;
  23.      EntryType = record
  24.                    status: byte;
  25.                    name: array[1..8] of char;
  26.                    ext:  array[1..3] of char;
  27.                    index: integer;
  28.                    length: integer;
  29.                    CRC: integer;
  30.                    CreationDate: integer;
  31.                    LastChangeDate: integer;
  32.                    CreationTime: TimeType;
  33.                    LastChangeTime: TimeType;
  34.                    filler: array[26..31] of byte;
  35.                  end;
  36.      EntryPtr = ^EntryType;
  37.      hexstr = string[4];
  38.      maxstr = string[255];
  39.      filename = string[14];
  40.  
  41. var buffer: array[0..BufferSize] of byte;
  42.     BigBuff: array[0..BigBuffSize] of byte;
  43.     library, file2: file;
  44.     DirectoryChanged: boolean;
  45.     LibName, fname: filename;
  46.     LibSize, NumEntries: integer;
  47.     LibEntry: EntryType;
  48.     Dir: array[0..maxent] of EntryPtr;
  49.     active, unused, deleted: integer;
  50.  
  51.   procedure WaitKey;
  52.     var c: char;
  53.     begin
  54.       write(^M^J,'Press any key to continue...');
  55.       repeat until keypressed;
  56.       read(kbd,c);
  57.     end;
  58.  
  59.   function Confirm: boolean;
  60.     var c: char;
  61.     begin
  62.       write('Confirm operation (Y/N): ');
  63.       repeat
  64.         read(kbd,c);
  65.         c:=upcase(c);
  66.       until (c in ['Y','N']);
  67.       writeln(c);
  68.       if c = 'Y' then Confirm:=true else Confirm:=false
  69.     end;
  70.  
  71.   function CommandLine: maxstr;
  72.     var len, i: integer;
  73.         str: maxstr;
  74.     begin
  75.       str:='';
  76.       len:=mem[$80];
  77.       if len>1 then for i:=2 to len do str:=str + chr(mem[$80+i]);
  78.       CommandLine:=str;
  79.     end;
  80.  
  81.   function hex(num: integer): hexstr;
  82.     var i, j: integer;
  83.         h: string[16];
  84.         str: hexstr;
  85.     begin
  86.       str:='0000';   h:='0123456789ABCDEF';   j:=num;
  87.       for i:=4 downto 1 do
  88.       begin
  89.         str[i]:=h[(j and 15)+1];
  90.         j:=j shr 4;
  91.       end;
  92.       hex:=str;
  93.     end;
  94.  
  95.   procedure MakeName(f: filename; var name: FileNameType);
  96.     var dotpos, endname, i: integer;
  97.     begin
  98.       for i:=1 to 11 do name[i]:=' ';
  99.       dotpos:=pos('.',f);
  100.       if dotpos > 0 then endname:=dotpos-1 else endname:=length(f);
  101.       for i:=1 to length(f) do f[i]:=upcase(f[i]);
  102.       if dotpos > 0 then
  103.         for i:=1 to 3 do
  104.           if f[dotpos+i]<>' ' then name[8+i]:=f[dotpos+i];
  105.       for i:=1 to endname do name[i]:=f[i];
  106.     end;
  107.  
  108.   procedure PutName(f: filename; n: integer);
  109.     var i: integer;
  110.         name: FileNameType;
  111.     begin
  112.       MakeName(f,name);
  113.       for i:=1 to 8 do Dir[n]^.name[i]:=name[i];
  114.       for i:=1 to 3 do Dir[n]^.ext[i] :=name[i+8];
  115.     end;
  116.  
  117.   function FindMember(f: filename): integer;
  118.     var member, dotpos, endname, i, k: integer;
  119.         lookup: FileNameType;
  120.         found: boolean;
  121.  
  122.     function NamesMatch(entry: integer): boolean;
  123.       var match: boolean;
  124.       begin
  125.         NamesMatch:=true;
  126.         with Dir[entry]^ do
  127.         begin
  128.           if status = $FF then NamesMatch:=false;
  129.           for k:=1 to 8 do if name[k]<>lookup[k] then NamesMatch:=false;
  130.           for k:=1 to 3 do if ext[k]<>lookup[8+k] then NamesMatch:=false;
  131.         end;
  132.       end;
  133.  
  134.     begin
  135.       MakeName(f,lookup);
  136.       found:=false;   i:=1;
  137.       if (active = 1) and (deleted = 0)
  138.         then FindMember := 0
  139.         else
  140.           begin
  141.             repeat
  142.               if NamesMatch(i)
  143.                 then found := true
  144.                 else i := i + 1;
  145.             until found or (i > NumEntries);
  146.             if found
  147.                then FindMember := i
  148.                else FindMember := 0;
  149.            end;
  150.      end;
  151.  
  152.   function Parse(f: filename): filename;
  153.     var i: integer;
  154.     begin
  155.       for i:=1 to length(f) do f[i]:=upcase(f[i]);
  156.       i:=pos('.',f);
  157.       if i>0 then f:=copy(f,1,i-1);
  158.       f:=f + '.LBR';
  159.       Parse:=f;
  160.     end;
  161.  
  162.   procedure WriteDirectoryToDisk(var lib: LibFileType);
  163.     var member, i: integer;
  164.     begin
  165.       reset(lib);
  166.       member:=0;
  167.       while member < NumEntries  do
  168.       begin
  169.         for i:=0 to EntriesPerBuffer-1 do move(Dir[member+i]^,buffer[32*i],32);
  170.         blockwrite(lib,buffer,1);
  171.         member:=member + 4
  172.       end;
  173.       DirectoryChanged:=false
  174.     end;
  175.  
  176.   procedure ZeroEntry(n: integer);
  177.     begin
  178.       fillchar(Dir[n]^,32,chr(0));      {clear the record}
  179.       fillchar(Dir[n]^.name[1],11,' '); {clear file name}
  180.       Dir[n]^.status:=-1;               {mark unused}
  181.     end;
  182.  
  183.   procedure SortDir;
  184.     var i, j: integer;
  185.  
  186.     function larger(a, b: integer): boolean;
  187.       var ok, x: integer;
  188.           c1, c2: char;
  189.       begin
  190.         ok:=0;   x:=1;
  191.         if (Dir[a]^.status <> 0) and (Dir[b]^.status <> 0) then ok:=2;
  192.         if (Dir[a]^.status <> 0) and (ok = 0) then ok:=1;
  193.         if (Dir[b]^.status <> 0) and (ok = 0) then ok:=2;
  194.         while (x < 12) and (ok=0) do
  195.         begin
  196.           c1:=Dir[a]^.name[x];   c2:=Dir[b]^.name[x];
  197.           if c1 > c2 then ok:=1;
  198.           if c1 < c2 then ok:=2;
  199.           x:=x + 1
  200.         end;
  201.         if ok=1 then larger:=true else larger:=false
  202.       end;
  203.  
  204.     procedure swap(x, y: integer);
  205.       var temp: EntryPtr;
  206.       begin
  207.         temp  :=Dir[x];
  208.         Dir[x]:=Dir[y];
  209.         Dir[y]:=temp
  210.       end;
  211.  
  212.     begin
  213.       for i:=1 to NumEntries-1 do
  214.         if Dir[i]^.status <> 0 then ZeroEntry(i);
  215.       for i:=1 to NumEntries-2 do
  216.         for j:=i+1 to NumEntries-1 do
  217.           if larger(i,j) then swap(i,j);
  218.     end;
  219.  
  220.   procedure CreateDirectory;
  221.     var i: integer;
  222.     begin
  223.       rewrite(library);
  224.       clrscr;  writeln('Creating a new library.  Name = ',LibName);
  225.       write('How many entries? ');  readln(i);
  226.       NumEntries:=i + 1; {add 1 for Directory entry}
  227.       i:=NumEntries MOD 4;
  228.       if i<>0 then NumEntries:=NumEntries + (4 - i);
  229.       for i:=0 to NumEntries-1 do
  230.       begin
  231.         new(Dir[i]);
  232.         ZeroEntry(i);
  233.       end;
  234.       Dir[0]^.status:=0; {directory entry is always used}
  235.       Dir[0]^.length:=NumEntries DIV 4;
  236.       active:=1;   unused:=NumEntries - 1;   deleted:=0;
  237.       WriteDirectoryToDisk(library);
  238.       LibSize := NumEntries DIV 32;
  239.       if LibSize < 1 then LibSize := 1;
  240.     end;
  241.  
  242.  procedure GetDirectory;
  243.     var i, offset: integer;
  244.     begin
  245.       offset:=0;   DirectoryChanged:=false;
  246.       LibSize:=(1 + filesize(library)) DIV 8;  {in kilobytes}
  247.       blockread(library,buffer,1);
  248.       new(Dir[0]);                 {make space for directory header}
  249.       move(buffer[0],Dir[0]^,32);  {move header entry}
  250.       NumEntries:=(128 * Dir[0]^.length) DIV 32;
  251.       for i:=1 to NumEntries-1 do
  252.       begin
  253.         if (i MOD EntriesPerBuffer) = 0 then
  254.         begin {read next block}
  255.           blockread(library,buffer,1);
  256.           offset:=offset + EntriesPerBuffer;
  257.         end;
  258.         new(Dir[i]);
  259.         move(buffer[32*(i-offset)],Dir[i]^,32);
  260.       end;
  261.       active:=1;   unused:=0;   deleted:=0;
  262.       for i:=1 to NumEntries-1 do
  263.        if Dir[i]^.status=0 then active:=active + 1
  264.        else if Dir[i]^.status=$FE then deleted:=deleted + 1
  265.        else unused:=unused + 1;
  266.     end;
  267.  
  268.   procedure OpenLibrary;
  269.     begin
  270.       assign(library,LibName);
  271.       {$I-} reset(library) {$I+};
  272.       if IOresult=0 then GetDirectory else CreateDirectory;
  273.     end;
  274.  
  275.   procedure Directory;
  276.     var i, j: integer;
  277.     begin
  278.       clrscr;
  279.       writeln('Library ',LibName,' is ',LibSize,'K',^M^J);
  280.       writeln('  name          index  length    CRC');
  281.       writeln('------------------------------------');
  282.       for i:=1 to NumEntries-1 do
  283.       with Dir[i]^ do
  284.       begin
  285.         if status<>$FF then
  286.         begin
  287.           for j:=1 to 8 do write(name[j]);
  288.           write('.');
  289.           for j:=1 to 3 do write(ext[j]);
  290.           write(' ',index:8,length:8,'   ',hex(CRC));
  291.           if status=$FE then write('   deleted');
  292.           writeln;
  293.         end;
  294.       end;
  295.       writeln(^M^J,active,' active, ',unused,' unused, ',deleted,' deleted: ',active+unused+deleted,' total entries.');
  296.       WaitKey;
  297.     end;
  298.  
  299.   procedure Extract;
  300.     var fname2: filename;
  301.         i, blocknum, blocksleft: integer;
  302.     begin
  303.       clrscr;
  304.       write('Enter filename to extract: ');  readln(fname2);
  305.       if length(fname2)>0 then
  306.       begin
  307.         i:=FindMember(fname2);
  308.         if i>0 then
  309.         begin
  310.           assign(file2,fname2);
  311.           rewrite(file2);
  312.           with Dir[i]^ do
  313.           begin
  314.             seek(library,index);
  315.             blocknum:=1;   blocksleft:=length;
  316.             repeat {copy data from library to file2}
  317.               if blocksleft >= 4 then   {write 1k blocks if possible}
  318.                 begin
  319.                   blockread(library,BigBuff,4);
  320.                   blockwrite(file2,BigBuff,4);
  321.                   blocksleft := blocksleft - 4;
  322.                 end
  323.               else                     {finish with 128 char blocks}
  324.                 begin                  { if necessary              }
  325.                   blockread(library,buffer,1);
  326.                   blockwrite(file2,buffer,1);
  327.                   blocksleft := blocksleft - 1;
  328.                 end;
  329.             until blocksleft = 0;
  330.           end;
  331.           close(file2);
  332.         end
  333.         else writeln('member was not found!!');
  334.       end;
  335.       WaitKey;
  336.     end;
  337.  
  338.   procedure Delete;
  339.     var fname2: filename;
  340.         i: integer;
  341.         ok: boolean;
  342.     begin
  343.       clrscr;
  344.       write('Enter member to delete: ');  readln(fname2);
  345.       if length(fname2)>0 then
  346.       begin
  347.         i:=FindMember(fname2);
  348.         if i>0 then
  349.         begin
  350.           ok:=Confirm;
  351.           write('Member ',fname2);
  352.           if ok then
  353.           begin
  354.             Dir[i]^.status:=$FE;
  355.             deleted:=deleted + 1;
  356.             active:=active - 1;
  357.             writeln(' was deleted.');
  358.             DirectoryChanged:=true;
  359.           end
  360.           else writeln(' was NOT deleted.')
  361.         end
  362.         else writeln(fname2,' does not exist.');
  363.         WaitKey;
  364.       end;
  365.     end;
  366.  
  367.   procedure Undelete;
  368.     var fname2: filename;
  369.         i: integer;
  370.         ok: boolean;
  371.     begin
  372.       clrscr;
  373.       write('Enter member to undelete: ');  readln(fname2);
  374.       if length(fname2)>0 then
  375.       begin
  376.         i:=FindMember(fname2);
  377.         if i>0 then
  378.         begin
  379.           Dir[i]^.status:=0;
  380.           deleted:=deleted - 1;
  381.           active:=active + 1;
  382.           writeln(fname2,' was undeleted.');
  383.           DirectoryChanged:=true;
  384.         end
  385.         else writeln(fname2,' does not exist.');
  386.         WaitKey;
  387.       end;
  388.     end;
  389.  
  390.   procedure Add;
  391.     var fname2: filename;
  392.         EntryLength, EntryIndex, SizeOfFile, number, i, blocksleft: integer;
  393.     begin
  394.       number:=0;   i:=1;
  395.       while (number = 0) and (i < NumEntries) do
  396.         if (Dir[i]^.status=$FF) and (number=0) then number:=i else i:=i + 1;
  397.       clrscr;
  398.       if number > 0 then
  399.       begin
  400.         write('Enter member to add: ');  readln(fname2);
  401.         if length(fname2)>0 then
  402.         begin
  403.           writeln('checking library directory');
  404.           i := FindMember(fname2);
  405.           if i = 0 then
  406.           begin
  407.             assign(file2,fname2);
  408.             {$I-} reset(file2) {$I+};
  409.             if IOresult=0 then
  410.             begin
  411.               SizeOfFile:=filesize(file2);
  412.               EntryIndex :=filesize(library);
  413.               EntryLength:=filesize(file2);
  414.               writeln('Adding ', fname2, ' ', EntryLength);
  415.               seek(library,EntryIndex);
  416.               blocksleft := EntryLength;
  417.               repeat  {copy from file2 to library}
  418.                 if blocksleft >= 4 then
  419.                   begin     {use 1k blocks if possible}
  420.                     blockread(file2,BigBuff,4);
  421.                     blockwrite(library,BigBuff,4);
  422.                     blocksleft := blocksleft - 4;
  423.                   end
  424.                 else
  425.                   begin  {copy rest with 128 char blocks}
  426.                     blockread(file2,buffer,1);
  427.                     blockwrite(library,buffer,1);
  428.                     blocksleft := blocksleft - 1;
  429.                   end;
  430.               until blocksleft = 0;
  431.               close(file2);
  432.               fillchar(Dir[number]^,32,chr(0)); {status:=0}
  433.               Dir[number]^.index :=EntryIndex;
  434.               Dir[number]^.length:=EntryLength;
  435.               PutName(fname2,number);
  436.               unused:=unused - 1;
  437.               active:=active + 1;
  438.               write('Member ',fname2,' was added.');
  439.               DirectoryChanged:=true;
  440.             end
  441.             else writeln('File ',fname2,' was not found.');
  442.           end
  443.           else writeln(fname2,' is already a member.');
  444.         end;
  445.       end
  446.       else writeln('There are no available places to put this entry.');
  447.       WaitKey;
  448.     end;
  449.  
  450.   procedure Reorganize;
  451.     var i, j: integer;
  452.     begin
  453.       SortDir;
  454.       assign(file2,'WORKLBR.$$$');
  455.       reset(library);   rewrite(file2);
  456.       WriteDirectoryToDisk(file2);
  457.       for i:=1 to NumEntries-1 do
  458.       with Dir[i]^ do
  459.       begin
  460.         if (status = 0) and (length > 0) then
  461.         begin
  462.           writeln('Copying: ',name,'.',ext,'  ',filepos(file2));
  463.           seek(library,index);
  464.           index:=filepos(file2);
  465.           for j:=1 to length do
  466.           begin
  467.             blockread (library,buffer,1);
  468.             blockwrite(file2,  buffer,1)
  469.           end
  470.         end
  471.       end;
  472.       WriteDirectoryToDisk(file2);
  473.       close(file2);   close(library);
  474.       erase(library); rename(file2,LibName);
  475.       reset(library);
  476.     end;
  477.  
  478.   procedure HelpCmdLine;
  479.     begin
  480.       clrscr;
  481.       writeln(^M^J,'You must enter a file name:');
  482.       writeln(^M^J,'LU <filename>[.LBR]');
  483.       writeln(^M^J,'NOTE: the .LBR suffix is optional.');
  484.     end;
  485.  
  486.   procedure Help;
  487.     begin
  488.       clrscr;
  489.       writeln('Library Utility Commands:',^M^J);
  490.       writeln('Add       - add a new member, can''t be duplicate');
  491.       writeln('Directory - gives the listing of this library''s directory');
  492.       writeln('Extract   - copy a member out to its own file');
  493.       writeln('Kill      - delete a member from the library');
  494.       writeln('Undelete  - reverses the effects of a delete');
  495.       writeln('Reorganize- compresses blank space in library');
  496.       writeln('eXit      - terminate this program');
  497.       writeln('Help      - gives this screen');
  498.       WaitKey;
  499.     end;
  500.  
  501.   procedure Menu;
  502.     var selection: char;
  503.     begin
  504.       OpenLibrary;
  505.       repeat
  506.         clrscr;
  507.         gotoxy(30,2);  write('Library Utility Menu');
  508.         gotoxy(35,3);  write('version ',ProgramVersion);
  509.         gotoxy(40-length(LibName) DIV 2,5);  write(LibName);
  510.         gotoxy(10,07); write('D - directory');
  511.         gotoxy(10,08); write('E - extract member');
  512.         gotoxy(10,09); write('A - add member');
  513.         gotoxy(10,10); write('K - delete member');
  514.         gotoxy(10,11); write('U - undelete member');
  515.         gotoxy(10,12); write('R - reorganize library');
  516.         gotoxy(10,13); write('X - exit');
  517.         gotoxy(10,14); write('? - help');
  518.         gotoxy(20,20); write('choose one: ');
  519.         repeat
  520.           read(kbd,selection);
  521.           selection:=upcase(selection);
  522.         until (selection in ['A','D','E','K','R','U','X','?']);
  523.         writeln(selection);
  524.         case selection of
  525.           'A': Add;
  526.           'D': Directory;
  527.           'E': Extract;
  528.           '?': Help;
  529.           'K': Delete;
  530.           'R': Reorganize;
  531.           'U': Undelete;
  532.         end;
  533.       until selection='X';
  534.       if DirectoryChanged then WriteDirectoryToDisk(library);
  535.       close(library);
  536.     end;
  537.  
  538. begin
  539.   LibName:=Parse(CommandLine); {CommandLine}
  540.   if LibName = '.LBR' then HelpCmdLine else Menu;
  541. end.
  542.