Programmer 7500/MAX_PROGRAMMERS.iso/INFO/TURBOPAS/APCLU.ZIP/APCLU.PAS

Pascal/Delphi Source File | 1980-01-01 | 16.3 KB | 508 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.

  This program was originally written by Steve Freeman and Upgraded to Version
  1.24 by John Plochner.  This version was converted by John Bingel to run
  exclusively on the NEC-APC, The IBM specific stuff was stripped out and all
  of the (yuk!!!) GO TO's were gotten rid of along with many other structural
  and programming problems.  This version is renamed APCLU  v1.00 to denote
  that it is for a specfic machine.

  The program only uses a subset of the info stored in the library:

          --- Makeup of a library entry header ---
      status           :  (Unused, in use, and deleted)
      name             :  (Name of member stored in library)
      ext              :  (Type "    "      "    "    "    )
      index            :  (where in lib this member is stored)
      length_of_member :  (it's length )
      CRC              :  (Cyclic Redundancy Check value)
      CreationDate     :  *** NOT IMPLEMENTED ***
      LastChangeDate   :  *** NOT IMPLEMENTED ***
      CreationTime     :  *** NOT IMPLEMENTED ***
      LastChangeTime   :  *** NOT IMPLEMENTED ***
      PadCount         : (used internally by LU)
      filler           : ( room for expansion )



        Modification history

       Version    Date       Who            Comments
       -------    ----       ---            --------
       1.01       12/10/85   John Bingel    Added CRC computation for added
                                            files.
       1.00       12/03/85   John Bingel    Made to work on NEC-APC. Changed
                                            so many things that it isn't
                                            feasible to mention them.
}

const V {ersion}       = '1.01';
      BufferSize       =  127;      { maximum size of data buffer - 1 }
      EntriesPerBuffer =  4;        { (BufferSize+1)/32 }
      maxent           =  128;      { maximum dir entries this program will take }
      Hell_Freezes_Over= False;     { Main driver loop termination... }
      esc              =  ^[;
      BS               =  ^H;
      CEOL             =  ^['[0K';
      CEOS             =  ^['[0J';
      HI               =  ^['[22m';
      LO               =  ^['[23m';
      CURSOR_OFF       =  ^['[>5h';
      CURSOR_ON        =  ^['[>5l';

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_of_member         : 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];
     string10     = string[10];
     filename     = string[14];
     maxstr       = string[255];

var buffer           : array[0..BufferSize] of byte;
    buff             : array[0..20479] of byte;
    library,
    file2            : file;
    SizeFile         : file of byte;
    DirectoryChanged : boolean;
    LibName,
    fname            : filename;
    LibSize,
    NumEntries       : integer;
    LibEntry         : EntryType;
    Dir              : array[0..maxent] of EntryPtr;
    active,
    unused,
    deleted          : integer;
    w_table : record x1,x2,y1,y2,
                   currx,curry : integer;
                   overwrote   : array[0..2048] of integer;
            end;
    screen : array[0..2048] of integer absolute $F000:0000;

{$I apclu-1.inc }   {      Window handlers and status line drivers }

  function Confirm: boolean;
    var c: char;
  begin
      w_write_s(' Confirm operation (Y/N): ');
      repeat
          read(kbd,c);
          c := upcase(c);
      until (c in ['Y','N']);
      w_write_c(c);
      confirm := (c = 'Y')
  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
      name := '           ';
      for i:=1 to length(f) do
          f[i] := upcase(f[i]);
      dotpos := pos('.',f);
      if dotpos > 0 then begin
          endname := dotpos-1;
          for i:=1 to 3 do
              if (f[ dotpos+i ] <> ' ')
              AND (DOTPOS + I <= LENGTH(F))then (* ONLY copy chars if they   *)
                                                (* are actually there! - jmp *)
                     name[8+i] := f[dotpos+i];
      end
      else
          endname := length(f);
      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
            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;
      while not(found) and (i<NumEntries) do
          if NamesMatch(i) then
              found := true
          else
              i := i + 1;

      if (active=1) or not(found) then
          FindMember := 0
      else
          FindMember := i
  end;

  function Parse(f: filename): filename;
  var i: integer;
  begin
      if f <> '' then 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';
      end;
      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 begin
          for j:=i+1 to NumEntries-1 do
              if larger(i,j) then
                  swap(i,j);
      end;
  end;

  procedure CreateDirectory;
  var i: integer;
  begin
      w_make(15,65,10,14);
      rewrite(library);
      w_write_s(' Creating a new library.  Name = ');
      w_write_s(LibName); w_writeln;
      w_write_s(' How many entries? ');  readln(i); w_writeln;
      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_of_member := NumEntries DIV 4;
      active         := 1;
      unused         := NumEntries - 1;
      deleted        := 0;
      WriteDirectoryToDisk(library);
      w_write_s(' Library created and initialized.');
      delay(250);
      LibSize := (1 + filesize(library)) DIV 8;  {in kilobytes}
      w_delete;
  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_of_member) 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
      gotoxy(3,6);  write(ceos,#$96,'  name          index  length    CRC ');
      gotoxy(41,6); write(#$96,'  name          index  length    CRC ',#$96);
      gotoxy(3,7);  write(#$93); for i := 5 to 79 do write(#$95); write(#$92);
      gotoxy(41,7); write(#$8F);
      gotoxy(41,5); write(#$91);
      for i:=1 to NumEntries-1 do
          with Dir[i]^ do begin
              if odd(i) then begin
                gotoxy(3,8+(i-1) div 2);
                write(#$96,ceol);
                end
              else begin
                gotoxy(41,8+ (i-1) div 2);
                 write(#$96,ceol);
              end;
              if status <> $FF then begin
                  if status=$FE then
                      write('*')
                  else write(' ');
                  for j:=1 to 8 do
                      write(name[j]);
                  write('.');
                  for j:=1 to 3 do
                      write(ext[j]);
                  write(' ',index:8,length_of_member:8,'   ',hex(CRC));
              end
              else write('  <empty>                            ');
              gotoxy(79,8+(i-1) div 2);
              write(#$96);
          end;  (* with *)
      gotoxy(41,8+(i-1) div 2);
      write(#$96);
      gotoxy(79,8+(i-1) div 2);
      write(#$96);
      gotoxy(3,9+(i-1) div 2);  write(#$9A);
      for i := 5 to 41 do write(#$95);
      write(#$90);
      for i := 43 to 79 do write(#$95);
      write(#$9B);
  end;

{$I apclu-2.inc } { command handlers - removed to include file for space reasons }

  procedure NewLib;
  var str : filename;
      x : integer;
  begin
      clrscr;
      gotoxy(3,1);
      write(#$98); for x := 4 to 25 do write(#$95); write(#$99);
      gotoxy(3,2); write(#$96,' Library Utility (LU) ',   #$96);
      gotoxy(3,3); write(#$96);gotoxy(26,3);        write(#$96);
      gotoxy(3,4); write(#$96,' APC version ',V,'     ',  #$96);
      gotoxy(3,5); write(#$9A);
      for x := 4 to 25 do write(#$95); write(#$9B);
      w_make(10,70,6,15);
      w_gotoxy(2,2);
      w_write_s('What library file do you want to use?              ');
      w_writeln;
      w_writeln;
      w_write_s('  Library name format is <filename>[.lbr]'); w_writeln;
      w_writeln;
      w_write_s('  The extention ".LBR" is assumed in all cases'); w_writeln;
      w_write_s('  A null filename (just press <CR>) exits the program.');
      w_gotoxy(40,2);
      write(cursor_on);
      readln(str);
      w_writeln;
      LibName := Parse(str);
      if length(LibName)=0 then begin
          gotoxy(1,23);
          halt;
      end;
      w_delete;
  end;

  procedure Menu;
  var selection: char;
      x : integer;
  begin
      OpenLibrary;

      {    draw character graphics on screen  --  set up display 'form' }

      gotoxy(26,1); write(#$91); for x :=27 to 78 do write(#$95); write(#$99);
      gotoxy(27,2);
      write('  Name: ',LibName,'':14-length(LibName),#$96);
      gotoxy(79,2); write(#$96);
      gotoxy(26,3);write(#$93);gotoxy(79,3);write(#$92);
      gotoxy(27,3); for x := 27 to 78 do write(#$95);
      gotoxy(79,4); write(#$96); gotoxy(3,5); write(#$93);
      for x := 4 to 25 do write(#$95); write(#$90);
      for x :=27 to 78 do write(#$95); write(#$92);
      gotoxy(49,1); write(#$91); gotoxy(63,1); write(#$91);
      gotoxy(49,3); write(#$8F); gotoxy(63,3); write(#$8F);
      gotoxy(49,5); write(#$90); gotoxy(63,5); write(#$90);

      repeat
          write(CURSOR_OFF);
          if w_table.x1 <> -1 then begin
              delay(250);
              w_delete;
          end;
          LibSize := (1 + filesize(library)) DIV 8;  {in kilobytes}

          { Update info on screen which could have changed cuz of last cmd }

          gotoxy(27,4);
          write(     '  Size: ',LibSize:3,'K bytes    ',#$96);
          gotoxy(50,2);
          write(' Total: ',active+deleted+unused - 1:3,'  ',#$96);
          gotoxy(50,4);
          write(     ' Active: ',active - 1:3,' ',#$96);
          gotoxy(64,2);
          write(' Erased: ',deleted:3,'  ');
          gotoxy(64,4);
          write(     ' Unused: ',unused:3);

          { turn on status line for function key input }

          Directory; { show updated library directory }
          set_status('X eXtract ','A Add     ','E Erase   ',
                     'U Unerase ','P Pack    ','H Help    ','Q Quit    ');
          repeat
              read(kbd,selection);
              selection := upcase(selection);
          until (selection in ['X','A','E','U','P','?','H','Q']);
          clear_status;
          write(CURSOR_ON);
          case selection of
                'A': Add;
                'X': Extract;
            'H','?': Help;
                'E': Delete; (* erase *)
                'P': Reorganize; (* pack *)
                'U': Undelete;
                'Q':;
          end;
      until selection='Q';
      if DirectoryChanged then WriteDirectoryToDisk(library);
      close(library);
  end;

begin {Main}
      write(LO);
      w_table.x1 := -1;
      repeat
            NewLib;
            Menu;
      until Hell_Freezes_Over;
end.