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.

  Slightly modified 10/05/2004 by Werner Cirsovius
}
 
const
  ProgramVersion   = '1.01';

  BufferSize       = 127;    { maximum size of data buffer-1 }
  EntriesPerBuffer =   4;    { (BufferSize+1)/32 }
  maxent           = 128;    { maximum dir entries this program will take }
  NamLen           =   8;    { length of CP/M filename }
  ExtLen           =   3;    { length of CP/M extension }
  LIBLen           =  32;    { length of library entry }
  RecLen           = 128;    { length of CP/M buffer }

  ActStat          = $00;
  PasStat          = $ff;
  DelStat          = $fe;

  WorkFile         = 'WORK-$$$.LBR';

type
  TimeType     = integer;
  FileNameType = array[1..11] of char;
  LibFileType  = file;

  EntryType    = record
                   status         : byte;
                   name           : array[1..NamLen] of char;
                   ext            : array[1..ExtLen] of char;
                   index          : integer;
                   length         : integer;
                   CRC            : integer;
                   CreationDate   : integer;
                   LastChangeDate : integer;
                   CreationTime   : TimeType;
                   LastChangeTime : TimeType;
                   PadCount       : byte;
                   filler         : array[27..31] of byte;
                 end;
  EntryPtr     = ^EntryType;

  hexstr       = string[  4];
  filename     = string[ 12];
  maxstr       = string[255];

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

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;
begin
  if (ParamCount=1) then CommandLine:=ParamStr(1)
                    else CommandLine:=''
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[succ((j and $0f))];
    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 NamLen+ExtLen do name[i]:=' ';
  dotpos:=pos('.',f);
  if (dotpos>0) then endname:=pred(dotpos)
                else endname:=length(f);
  for i:=1 to length(f) do f[i]:=upcase(f[i]);
  if (dotpos>0) then
     for i:=1 to ExtLen do
         if f[dotpos+i]<>' ' then name[NamLen+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 NamLen do Dir[n]^.name[i]:=name[i];
  for i:=1 to ExtLen do Dir[n]^.ext[i]:=name[i+NamLen];
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
    match:=true;
    with Dir[entry]^ do
    begin
      if (status<>ActStat) then match:=false;
      if match then
         for k:=1 to NamLen do if name[k]<>lookup[k]        then match:=false;
      if match then
         for k:=1 to ExtLen do if  ext[k]<>lookup[NamLen+k] then match:=false;
    end;
    NamesMatch:=match;
  end;
 
begin {FindMember}
  MakeName(f,lookup);
  found:=false;
  i:=1;
  while (not found and (i<NumEntries)) do if NamesMatch(i) then found:=true
                                                           else i:=succ(i);

  if ((active=1) or not found) then FindMember:=0
                               else FindMember:=i
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,pred(i));
  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 pred(EntriesPerBuffer) do move(Dir[member+i]^,buffer[LIBLen*i],LIBLen);
    blockwrite(lib,buffer,1);
    member:=member+EntriesPerBuffer
  end;
  DirectoryChanged:=false
end;

procedure ZeroEntry(n: integer);
begin
  fillchar(Dir[n]^,LIBLen,chr(0));             {clear the record}
  fillchar(Dir[n]^.name[1],NamLen+ExtLen,' '); {clear file name}
  Dir[n]^.status:=PasStat;                     {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<>ActStat) and (Dir[b]^.status<>ActStat)) then ok:=2;
    if ((Dir[a]^.status<>ActStat) and              (ok=0)      ) then ok:=1;
    if ((Dir[b]^.status<>ActStat) 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:=succ(x)
    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 {SortDir}
  for i:=1 to NumEntries-1 do if (Dir[i]^.status<>ActStat) then ZeroEntry(i);
  for i:=1 to NumEntries-2 do
  begin
    for j:=succ(i) to pred(NumEntries) do if larger(i,j) then swap(i,j);
  end;
end;

procedure CreateDirectory;
var
  i            : integer;
begin
  rewrite(library);

  clrscr;
  writeln('Creating a new library.  Name = ',LibName);
  write('How many entries? ');
  readln(i);
  NumEntries:=succ(i); {add 1 for Directory entry}
  i:=NumEntries MOD EntriesPerBuffer;
  if (i<>0) then NumEntries:=NumEntries+(EntriesPerBuffer-i);

  for i:=0 to pred(NumEntries) do
  begin
    new(Dir[i]);
    ZeroEntry(i);
  end;

  Dir[0]^.status:=ActStat; {directory entry is always used}
  Dir[0]^.length:=NumEntries DIV EntriesPerBuffer;
  active:=1;
  unused:=pred(NumEntries);
  deleted:=0;
  WriteDirectoryToDisk(library);
end;

procedure GetDirectory;
var
  i,offset     : integer;
begin
  offset:=0;
  DirectoryChanged:=false;
  LibSize:=(succ(filesize(library))) DIV 8;  {in kilobytes}
  blockread(library,buffer,1);
  new(Dir[0]);                     {make space for directory header}
  move(buffer[0],Dir[0]^,LIBLen);  {move header entry}
  NumEntries:=(RecLen*Dir[0]^.length) DIV LIBLen;
  for i:=1 to pred(NumEntries) 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[LIBLen*(i-offset)],Dir[i]^,LIBLen);
  end;
  active:=1;
  unused:=0;
  deleted:=0;
  for i:=1 to pred(NumEntries) do
      if (Dir[i]^.status=ActStat) then active:=succ(active)
                                  else if (Dir[i]^.status=DelStat) then deleted:=succ(deleted)
                                                                   else unused:=succ(unused);
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 pred(NumEntries) do with Dir[i]^ do
  begin
    if (status<>PasStat) then
    begin
      for j:=1 to NamLen do write(name[j]);
      write('.');
      for j:=1 to ExtLen do write(ext[j]);
      write(' ',index:8,length:8,'   ',hex(CRC));
      if (status=DelStat) then write('   deleted');
      writeln;
    end;
  end;
  writeln(^M^J,active,' active, ',unused,' unused, ',deleted,' deleted: ',active+unused+deleted,' total entries.');
  WaitKey;
end;

function validFile(msg,illms:maxstr):boolean;
begin
  clrscr;
  write('Enter ',msg,': ');
  readln(fname2);
  if (length(fname2)>0) then validFile:=true
                        else
                        begin
                          writeln(illms);
                          validFile:=false
                        end;
end;

procedure Extract;
var
  i,blocknum,
  bytenum      : integer;
begin
  if validFile('filename to extract','member was not found!!') 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;
        bytenum:=0;
        while (blocknum<=length) do
        begin
          blockread(library,buffer,1);
          if (blocknum<length) then blockwrite(file2,buffer,1)
                               else
                               begin
                                 close(file2); {save disk info}
                                 assign(SizeFile,fname2);
                                 reset(SizeFile);
                                 seek(SizeFile,filesize(SizeFile));
                                 while (bytenum<((RecLen-PadCount) MOD RecLen)) do
                                 begin
                                   write(SizeFile,buffer[bytenum]);
                                   bytenum:=succ(bytenum)
                                 end;
                                 close(SizeFile);
                                 reset(file2); {for later close}
                                end;
                                blocknum:=succ(blocknum)
        end;
      end;
      close(file2);
    end;
  end;
  WaitKey;
end;

procedure Delete;
var
  i            : integer;
  ok           : boolean;
begin
  if validFile('member to delete',fname2+' does not exist.') then
  begin
    i:=FindMember(fname2);
    if (i>0) then
    begin
      ok:=Confirm;
      write('Member ',fname2);
      if ok then
      begin
        Dir[i]^.status:=DelStat;
        deleted:=succ(deleted);
        active:=pred(active);
        writeln(' was deleted.');
        DirectoryChanged:=true;
      end else writeln(' was NOT deleted.')
    end;
    WaitKey;
   end;
end;

procedure Undelete;
var
  i            : integer;
  ok           : boolean;
begin
  if validFile('member to undelete',fname2+' does not exist.') then
  begin
    i:=FindMember(fname2);
    if (i>0) then
    begin
      Dir[i]^.status:=ActStat;
      deleted:=pred(deleted);
      active:=succ(active);
      writeln(fname2,' was undeleted.');
      DirectoryChanged:=true;
    end;
    WaitKey;
  end;
end;

procedure Add;
var
  EntryLength,
  EntryIndex,
  SizeOfFile,
  number,i     : integer;
begin
  number:=0;
  i:=1;
  while ((number=0) and (i<NumEntries)) do
  begin
    if ((Dir[i]^.status=PasStat) and (number=0)) then number:=i
                                                 else i:=succ(i);
  end;
  clrscr;
  if (number>0) then
  begin
    if validFile('member to add','There are no available places to put this entry.') then
    begin
      if (FindMember(fname2)=0) then
      begin
        assign(SizeFile,fname2);
        {$I-}reset(SizeFile){$I+};
        if (IOresult=0) then
        begin
          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]^,LIBLen,chr(0)); {status:=ActStat}
          Dir[number]^.index:= EntryIndex;
          Dir[number]^.length:=EntryLength;
          Dir[number]^.PadCount:=(RecLen-(SizeOfFile MOD RecLen)) and pred(RecLen);
          PutName(fname2,number);
          unused:=pred(unused);
          active:=succ(active);
          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;
  WaitKey;
end;

procedure Reorganize;
var
  i,j          : integer;
begin
  SortDir;
  assign(file2,WorkFile);
  reset(library);
  rewrite(file2);
  WriteDirectoryToDisk(file2);
  for i:=1 to pred(NumEntries) do with Dir[i]^ do
  begin
    if ((status=ActStat) 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.');
  WaitKey;
end;

procedure Help;
begin
  clrscr;
  writeln('Library Utility Commands:',^M^J);
  writeln('Directory - gives the listing of this library''s directory');
  writeln('Add       - add a new member, can''t be duplicate');
  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('A - add member');
    gotoxy(10,09); write('E - extract 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
      repeat until keypressed;
      read(kbd,selection);
      selection:=upcase(selection);
    until (selection in ['D','A','E','K','U','R','X','?']);
    writeln(selection);
    case selection of
      'D': Directory;
      'A': Add;
      'E': Extract;
      'K': Delete;
      'U': Undelete;
      'R': Reorganize;
      '?': Help;
    end;
  until selection='X';
  if DirectoryChanged then WriteDirectoryToDisk(library);
  close(library);
end;

begin {MAIN}
  LibName:=Parse(CommandLine);
  if length(LibName)=0 then HelpCmdLine
                       else Menu;
end.