CP/M/CPM_CDROM.iso/cpm/turbopas/tp/utl2/lu11.pzs/LU11.PAS

Pascal/Delphi Source File | 1994-07-23 | 16.8 KB | 542 lines

program LibraryUtility;
{ written 10/09/84 by Steve Freeman
  This program was written to function as Gary Novosielski's LU.  As such it
  will function as a utility to manipulate library members under any operating
  system which will support TURBO Pascal.  Minor rewrites may be necessary for
  other versions of Pascal.
  This program is placed into the Public Domain by the author and, as a Public
  Domain program, may NOT be used for commercial purposes.}
{ modified by R.T. Moss 10/12/85 for Turbo Pascal Version 2.0
  original program had fatal I/O errors at runtime.
  changed version number to 1.10
  added 1K buffer for faster Add & Extract }

const ProgramVersion = '1.10';
      BufferSize = 127;      { maximum size of data buffer - 1 }
      EntriesPerBuffer = 4;  { (BufferSize+1)/32 }
      maxent = 128;          { maximum dir entries this program will take }
      BigBuffSize = 1023;    { large size for buffer to speedup Add & Extract }

type TimeType = integer;
     FileNameType = array[1..11] of char;
     LibFileType = file;
     EntryType = record
                   status: byte;
                   name: array[1..8] of char;
                   ext:  array[1..3] of char;
                   index: integer;
                   length: integer;
                   CRC: integer;
                   CreationDate: integer;
                   LastChangeDate: integer;
                   CreationTime: TimeType;
                   LastChangeTime: TimeType;
                   filler: array[26..31] of byte;
                 end;
     EntryPtr = ^EntryType;
     hexstr = string[4];
     maxstr = string[255];
     filename = string[14];

var buffer: array[0..BufferSize] of byte;
    BigBuff: array[0..BigBuffSize] of byte;
    library, file2: file;
    DirectoryChanged: boolean;
    LibName, fname: filename;
    LibSize, NumEntries: integer;
    LibEntry: EntryType;
    Dir: array[0..maxent] of EntryPtr;
    active, unused, deleted: integer;

  procedure WaitKey;
    var c: char;
    begin
      write(^M^J,'Press any key to continue...');
      repeat until keypressed;
      read(kbd,c);
    end;

  function Confirm: boolean;
    var c: char;
    begin
      write('Confirm operation (Y/N): ');
      repeat
        read(kbd,c);
        c:=upcase(c);
      until (c in ['Y','N']);
      writeln(c);
      if c = 'Y' then Confirm:=true else Confirm:=false
    end;

  function CommandLine: maxstr;
    var len, i: integer;
        str: maxstr;
    begin
      str:='';
      len:=mem[$80];
      if len>1 then for i:=2 to len do str:=str + chr(mem[$80+i]);
      CommandLine:=str;
    end;

  function hex(num: integer): hexstr;
    var i, j: integer;
        h: string[16];
        str: hexstr;
    begin
      str:='0000';   h:='0123456789ABCDEF';   j:=num;
      for i:=4 downto 1 do
      begin
        str[i]:=h[(j and 15)+1];
        j:=j shr 4;
      end;
      hex:=str;
    end;

  procedure MakeName(f: filename; var name: FileNameType);
    var dotpos, endname, i: integer;
    begin
      for i:=1 to 11 do name[i]:=' ';
      dotpos:=pos('.',f);
      if dotpos > 0 then endname:=dotpos-1 else endname:=length(f);
      for i:=1 to length(f) do f[i]:=upcase(f[i]);
      if dotpos > 0 then
        for i:=1 to 3 do
          if f[dotpos+i]<>' ' then name[8+i]:=f[dotpos+i];
      for i:=1 to endname do name[i]:=f[i];
    end;

  procedure PutName(f: filename; n: integer);
    var i: integer;
        name: FileNameType;
    begin
      MakeName(f,name);
      for i:=1 to 8 do Dir[n]^.name[i]:=name[i];
      for i:=1 to 3 do Dir[n]^.ext[i] :=name[i+8];
    end;

  function FindMember(f: filename): integer;
    var member, dotpos, endname, i, k: integer;
        lookup: FileNameType;
        found: boolean;

    function NamesMatch(entry: integer): boolean;
      var match: boolean;
      begin
        NamesMatch:=true;
        with Dir[entry]^ do
        begin
          if status = $FF then NamesMatch:=false;
          for k:=1 to 8 do if name[k]<>lookup[k] then NamesMatch:=false;
          for k:=1 to 3 do if ext[k]<>lookup[8+k] then NamesMatch:=false;
        end;
      end;

    begin
      MakeName(f,lookup);
      found:=false;   i:=1;
      if (active = 1) and (deleted = 0)
        then FindMember := 0
        else
          begin
            repeat
              if NamesMatch(i)
                then found := true
                else i := i + 1;
            until found or (i > NumEntries);
            if found
               then FindMember := i
               else FindMember := 0;
           end;
     end;

  function Parse(f: filename): filename;
    var i: integer;
    begin
      for i:=1 to length(f) do f[i]:=upcase(f[i]);
      i:=pos('.',f);
      if i>0 then f:=copy(f,1,i-1);
      f:=f + '.LBR';
      Parse:=f;
    end;

  procedure WriteDirectoryToDisk(var lib: LibFileType);
    var member, i: integer;
    begin
      reset(lib);
      member:=0;
      while member < NumEntries  do
      begin
        for i:=0 to EntriesPerBuffer-1 do move(Dir[member+i]^,buffer[32*i],32);
        blockwrite(lib,buffer,1);
        member:=member + 4
      end;
      DirectoryChanged:=false
    end;

  procedure ZeroEntry(n: integer);
    begin
      fillchar(Dir[n]^,32,chr(0));      {clear the record}
      fillchar(Dir[n]^.name[1],11,' '); {clear file name}
      Dir[n]^.status:=-1;               {mark unused}
    end;

  procedure SortDir;
    var i, j: integer;

    function larger(a, b: integer): boolean;
      var ok, x: integer;
          c1, c2: char;
      begin
        ok:=0;   x:=1;
        if (Dir[a]^.status <> 0) and (Dir[b]^.status <> 0) then ok:=2;
        if (Dir[a]^.status <> 0) and (ok = 0) then ok:=1;
        if (Dir[b]^.status <> 0) and (ok = 0) then ok:=2;
        while (x < 12) and (ok=0) do
        begin
          c1:=Dir[a]^.name[x];   c2:=Dir[b]^.name[x];
          if c1 > c2 then ok:=1;
          if c1 < c2 then ok:=2;
          x:=x + 1
        end;
        if ok=1 then larger:=true else larger:=false
      end;

    procedure swap(x, y: integer);
      var temp: EntryPtr;
      begin
        temp  :=Dir[x];
        Dir[x]:=Dir[y];
        Dir[y]:=temp
      end;

    begin
      for i:=1 to NumEntries-1 do
        if Dir[i]^.status <> 0 then ZeroEntry(i);
      for i:=1 to NumEntries-2 do
        for j:=i+1 to NumEntries-1 do
          if larger(i,j) then swap(i,j);
    end;

  procedure CreateDirectory;
    var i: integer;
    begin
      rewrite(library);
      clrscr;  writeln('Creating a new library.  Name = ',LibName);
      write('How many entries? ');  readln(i);
      NumEntries:=i + 1; {add 1 for Directory entry}
      i:=NumEntries MOD 4;
      if i<>0 then NumEntries:=NumEntries + (4 - i);
      for i:=0 to NumEntries-1 do
      begin
        new(Dir[i]);
        ZeroEntry(i);
      end;
      Dir[0]^.status:=0; {directory entry is always used}
      Dir[0]^.length:=NumEntries DIV 4;
      active:=1;   unused:=NumEntries - 1;   deleted:=0;
      WriteDirectoryToDisk(library);
      LibSize := NumEntries DIV 32;
      if LibSize < 1 then LibSize := 1;
    end;

 procedure GetDirectory;
    var i, offset: integer;
    begin
      offset:=0;   DirectoryChanged:=false;
      LibSize:=(1 + filesize(library)) DIV 8;  {in kilobytes}
      blockread(library,buffer,1);
      new(Dir[0]);                 {make space for directory header}
      move(buffer[0],Dir[0]^,32);  {move header entry}
      NumEntries:=(128 * Dir[0]^.length) DIV 32;
      for i:=1 to NumEntries-1 do
      begin
        if (i MOD EntriesPerBuffer) = 0 then
        begin {read next block}
          blockread(library,buffer,1);
          offset:=offset + EntriesPerBuffer;
        end;
        new(Dir[i]);
        move(buffer[32*(i-offset)],Dir[i]^,32);
      end;
      active:=1;   unused:=0;   deleted:=0;
      for i:=1 to NumEntries-1 do
       if Dir[i]^.status=0 then active:=active + 1
       else if Dir[i]^.status=$FE then deleted:=deleted + 1
       else unused:=unused + 1;
    end;

  procedure OpenLibrary;
    begin
      assign(library,LibName);
      {$I-} reset(library) {$I+};
      if IOresult=0 then GetDirectory else CreateDirectory;
    end;

  procedure Directory;
    var i, j: integer;
    begin
      clrscr;
      writeln('Library ',LibName,' is ',LibSize,'K',^M^J);
      writeln('  name          index  length    CRC');
      writeln('------------------------------------');
      for i:=1 to NumEntries-1 do
      with Dir[i]^ do
      begin
        if status<>$FF then
        begin
          for j:=1 to 8 do write(name[j]);
          write('.');
          for j:=1 to 3 do write(ext[j]);
          write(' ',index:8,length:8,'   ',hex(CRC));
          if status=$FE then write('   deleted');
          writeln;
        end;
      end;
      writeln(^M^J,active,' active, ',unused,' unused, ',deleted,' deleted: ',active+unused+deleted,' total entries.');
      WaitKey;
    end;

  procedure Extract;
    var fname2: filename;
        i, blocknum, blocksleft: integer;
    begin
      clrscr;
      write('Enter filename to extract: ');  readln(fname2);
      if length(fname2)>0 then
      begin
        i:=FindMember(fname2);
        if i>0 then
        begin
          assign(file2,fname2);
          rewrite(file2);
          with Dir[i]^ do
          begin
            seek(library,index);
            blocknum:=1;   blocksleft:=length;
            repeat {copy data from library to file2}
              if blocksleft >= 4 then   {write 1k blocks if possible}
                begin
                  blockread(library,BigBuff,4);
                  blockwrite(file2,BigBuff,4);
                  blocksleft := blocksleft - 4;
                end
              else                     {finish with 128 char blocks}
                begin                  { if necessary              }
                  blockread(library,buffer,1);
                  blockwrite(file2,buffer,1);
                  blocksleft := blocksleft - 1;
                end;
            until blocksleft = 0;
          end;
          close(file2);
        end
        else writeln('member was not found!!');
      end;
      WaitKey;
    end;

  procedure Delete;
    var fname2: filename;
        i: integer;
        ok: boolean;
    begin
      clrscr;
      write('Enter member to delete: ');  readln(fname2);
      if length(fname2)>0 then
      begin
        i:=FindMember(fname2);
        if i>0 then
        begin
          ok:=Confirm;
          write('Member ',fname2);
          if ok then
          begin
            Dir[i]^.status:=$FE;
            deleted:=deleted + 1;
            active:=active - 1;
            writeln(' was deleted.');
            DirectoryChanged:=true;
          end
          else writeln(' was NOT deleted.')
        end
        else writeln(fname2,' does not exist.');
        WaitKey;
      end;
    end;

  procedure Undelete;
    var fname2: filename;
        i: integer;
        ok: boolean;
    begin
      clrscr;
      write('Enter member to undelete: ');  readln(fname2);
      if length(fname2)>0 then
      begin
        i:=FindMember(fname2);
        if i>0 then
        begin
          Dir[i]^.status:=0;
          deleted:=deleted - 1;
          active:=active + 1;
          writeln(fname2,' was undeleted.');
          DirectoryChanged:=true;
        end
        else writeln(fname2,' does not exist.');
        WaitKey;
      end;
    end;

  procedure Add;
    var fname2: filename;
        EntryLength, EntryIndex, SizeOfFile, number, i, blocksleft: integer;
    begin
      number:=0;   i:=1;
      while (number = 0) and (i < NumEntries) do
        if (Dir[i]^.status=$FF) and (number=0) then number:=i else i:=i + 1;
      clrscr;
      if number > 0 then
      begin
        write('Enter member to add: ');  readln(fname2);
        if length(fname2)>0 then
        begin
          writeln('checking library directory');
          i := FindMember(fname2);
          if i = 0 then
          begin
            assign(file2,fname2);
            {$I-} reset(file2) {$I+};
            if IOresult=0 then
            begin
              SizeOfFile:=filesize(file2);
              EntryIndex :=filesize(library);
              EntryLength:=filesize(file2);
              writeln('Adding ', fname2, ' ', EntryLength);
              seek(library,EntryIndex);
              blocksleft := EntryLength;
              repeat  {copy from file2 to library}
                if blocksleft >= 4 then
                  begin     {use 1k blocks if possible}
                    blockread(file2,BigBuff,4);
                    blockwrite(library,BigBuff,4);
                    blocksleft := blocksleft - 4;
                  end
                else
                  begin  {copy rest with 128 char blocks}
                    blockread(file2,buffer,1);
                    blockwrite(library,buffer,1);
                    blocksleft := blocksleft - 1;
                  end;
              until blocksleft = 0;
              close(file2);
              fillchar(Dir[number]^,32,chr(0)); {status:=0}
              Dir[number]^.index :=EntryIndex;
              Dir[number]^.length:=EntryLength;
              PutName(fname2,number);
              unused:=unused - 1;
              active:=active + 1;
              write('Member ',fname2,' was added.');
              DirectoryChanged:=true;
            end
            else writeln('File ',fname2,' was not found.');
          end
          else writeln(fname2,' is already a member.');
        end;
      end
      else writeln('There are no available places to put this entry.');
      WaitKey;
    end;

  procedure Reorganize;
    var i, j: integer;
    begin
      SortDir;
      assign(file2,'WORKLBR.$$$');
      reset(library);   rewrite(file2);
      WriteDirectoryToDisk(file2);
      for i:=1 to NumEntries-1 do
      with Dir[i]^ do
      begin
        if (status = 0) and (length > 0) then
        begin
          writeln('Copying: ',name,'.',ext,'  ',filepos(file2));
          seek(library,index);
          index:=filepos(file2);
          for j:=1 to length do
          begin
            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 HelpCmdLine;
    begin
      clrscr;
      writeln(^M^J,'You must enter a file name:');
      writeln(^M^J,'LU <filename>[.LBR]');
      writeln(^M^J,'NOTE: the .LBR suffix is optional.');
    end;

  procedure Help;
    begin
      clrscr;
      writeln('Library Utility Commands:',^M^J);
      writeln('Add       - add a new member, can''t be duplicate');
      writeln('Directory - gives the listing of this library''s directory');
      writeln('Extract   - copy a member out to its own file');
      writeln('Kill      - delete a member from the library');
      writeln('Undelete  - reverses the effects of a delete');
      writeln('Reorganize- compresses blank space in library');
      writeln('eXit      - terminate this program');
      writeln('Help      - gives this screen');
      WaitKey;
    end;

  procedure Menu;
    var selection: char;
    begin
      OpenLibrary;
      repeat
        clrscr;
        gotoxy(30,2);  write('Library Utility Menu');
        gotoxy(35,3);  write('version ',ProgramVersion);
        gotoxy(40-length(LibName) DIV 2,5);  write(LibName);
        gotoxy(10,07); write('D - directory');
        gotoxy(10,08); write('E - extract member');
        gotoxy(10,09); write('A - add member');
        gotoxy(10,10); write('K - delete member');
        gotoxy(10,11); write('U - undelete member');
        gotoxy(10,12); write('R - reorganize library');
        gotoxy(10,13); write('X - exit');
        gotoxy(10,14); write('? - help');
        gotoxy(20,20); write('choose one: ');
        repeat
          read(kbd,selection);
          selection:=upcase(selection);
        until (selection in ['A','D','E','K','R','U','X','?']);
        writeln(selection);
        case selection of
          'A': Add;
          'D': Directory;
          'E': Extract;
          '?': Help;
          'K': Delete;
          'R': Reorganize;
          'U': Undelete;
        end;
      until selection='X';
      if DirectoryChanged then WriteDirectoryToDisk(library);
      close(library);
    end;

begin
  LibName:=Parse(CommandLine); {CommandLine}
  if LibName = '.LBR' then HelpCmdLine else Menu;
end.