Programmer 7500/MAX_PROGRAMMERS.iso/INFO/TURBOPAS/TUR6_102.ZIP/DISKARC.INC

Text File | 1986-01-01 | 7.0 KB | 281 lines

{  This module has used routines that were  writen by Michael Quinlin }
{  for used in creating a turbo pascal arc program.  I have used his coding }
{  for reading the arc file and creating the directory information from it. }
{  My thanks and gratitude go to him for this coding. }

type long    = record           { used to simulate long (4 byte) integers }
                 l, h : integer
               end;

const BLOCKSIZE = 128;
      NUMFILES  = 1;

var
               fil     : file;
               rw      : char;
               buf     : array [1..BLOCKSIZE] of char;
               next    : integer;
               endfile : boolean;
               lastout : char;

const arcmarc = 26;              { special archive marker }
      arcver  = 6;               { archive header version code }
      strlen  = 100;             { standard string length }
      fnlen   = 12;              { file name length - 1 }

type strtype = string[strlen];
     fntype  = array[0..fnlen] of char;

type heads   = record
                 name   : fntype;
                 size   : long;
                 date   : integer;
                 time   : integer;
                 crc    : integer;
                 length : long
               end;

var hdrver              : byte;
    arcname             : strtype;
    arcdate             : integer;
    arctime             : integer;
    arcopen             : boolean;
    FilePosition        : real;

procedure abort(s : strtype);
  begin
    writeln('ABORT: ', s);
    halt(1)
  end;

function fn_to_str(var fn : fntype) : strtype;
{ convert strings from C format (trailing 0) to Turbo Pascal format (leading
    length byte). }
  var s : strtype;
      i : integer;
  begin
    s := '';
    i := 0;
    while fn[i] <> #0 do begin
      s := s + fn[i];
      i := i + 1
    end;
    fn_to_str := s
  end;

function unsigned_to_real(u : integer) : real;
{ convert unsigned integer to real }
{ note: INT is a function that returns a REAL!!!}
  begin
    if u >= 0 then unsigned_to_real := Int(u)
    else if u = $8000 then unsigned_to_real := 32768.0
    else unsigned_to_real := 65536.0 + u
  end;

function long_to_real(l : long) : real;
{ convert long integer to a real }
{ note: INT is a function that returns a REAL!!! }
  var r : real;
      s : (POS, NEG);
  const rcon = 65536.0;
  begin
    if l.h >= 0 then begin
      r := Int(l.h) * rcon;
      s := POS
    end else begin
      s := NEG;
      if l.h = $8000 then r := rcon * rcon
      else r := Int(-l.h) * rcon
    end;
    r := r + unsigned_to_real(l.l);
    if s = NEG then long_to_real := -r
    else long_to_real := r
  end;

procedure Read_Block;
  begin
      if EOF(fil) then endfile := TRUE
      else BlockRead(fil, buf, 1);
      next := 1;
  end;


function fopen(var name : strtype) : boolean;
{ only binary I/O supported; }
  begin
    {$I-}
    assign(fil, name);
    {$I+}
    if ioresult <> 0 then begin
      fopen := FALSE;
      exit;
    end;

    {$I-}
    reset(fil);
    {$I+}
    if ioresult <> 0 then begin
      fopen := FALSE;
    exit
    end;
    endfile  := FALSE;
    rw := 'R';
    Read_Block;
    FilePosition := 0.0;
    fopen := TRUE
  end;

function fgetc : char;
  begin
      if endfile then fgetc := chr(0)
      else begin
        fgetc := buf[next];

        if next = BLOCKSIZE then Read_Block
        else next := next + 1
      end;
  end;

function fgetb : byte;
  begin
      if endfile then fgetb := 0
      else begin
        fgetb := ord(buf[next]);
        if next = BLOCKSIZE then Read_Block
        else next := next + 1
      end;
  end;

function feof : boolean;
  begin
    feof := endfile
  end;

procedure fclose;
  begin
      close(fil);
  end;

procedure do_seek(offset : real);
  var i, ofs, rec : integer;
      c           : char;
  begin
    rec := Trunc(Offset / BLOCKSIZE);
    ofs := Trunc(Offset - (Int(rec) * BLOCKSIZE));  { Int converts to Real }
    seek(fil, rec);
    Read_Block;
    for i := 1 to ofs do c := fgetc;
  end;

procedure fseek(offset : real);
{ only works with input files }
  var b,c : real;
  begin
      FilePosition := FilePosition + offset;
      do_seek(FilePosition)
  end;

procedure fread(var buf; reclen, numrec : integer);
  var i, n : integer;
      b : array [1..MaxInt] of char absolute buf;
  begin
    n := reclen * numrec;
    for i := 1 to n do b[i] := fgetc;
    FilePosition := FilePosition + n + 2;
  end;

function readhdr(var hdr : heads) : boolean;
{ FALSE = eof found; TRUE = header found }
  var name : fntype;
      try  : integer;
  begin
    try := 20;

    if feof then begin
      readhdr := FALSE;
      exit
    end;

    while fgetb <> arcmarc do begin
      if try = 0 then abort(arcname + ' is not an archive');
      try := try - 1;
      if feof then abort('Archive length error')
    end;

    hdrver := fgetb;
    if hdrver < 0 then abort('Invalid header in archive ' + arcname);
    if hdrver = 0 then begin   { special end of file marker }
      readhdr := FALSE;
      exit
    end;
    if hdrver > arcver then begin
      fread(name, sizeof(char), fnlen{, f});
      writeln('I dont know how to handle file ', fn_to_str(name),
        ' in archive ', arcname);
      writeln('I think you need a newer version of DISKOVER.');
      halt(1)
    end;

    if hdrver = 1 then begin
      fread(hdr, sizeof(heads) - sizeof(long), 1);
      hdrver := 2;
      hdr.length := hdr.size
    end else
      fread(hdr, sizeof(heads), 1);
    readhdr := TRUE
  end;

procedure openarc;
  begin
    if not fopen(arcname) then
      arcopen := FALSE
    else
      arcopen := TRUE;
  end;

procedure lstfile(var hdr : heads);{ ArcList : SortArray; i : integer);}
  var yr, mo, dy : integer;
      hh, mm, ss : integer;
      b          : integer;
      fn         : strtype;
      rlen, rsiz : real;
      aorp       : char;
      sthold     : string[7];
      s          : string[2];

  procedure twodig(n : integer);
    begin
      str(n:2, s);
      if s[1] = ' ' then s[1] := '0';
      if s[2] = ' ' then s[2] := '0';
    end;


  begin
    fn := fn_to_str(hdr.name);
    rlen := long_to_real(hdr.length);
    rsiz := long_to_real(hdr.size);

    yr := (hdr.date shr 9) and $7F;
    mo := (hdr.date shr 5) and $0F;
    dy := hdr.date and $1F;

    hh := (hdr.time shr 11) and $1F;
    mm := (hdr.time shr 5) and $3F;
    ss := (hdr.time and $1F) * 2;

    ArcList[ArcSrn] := ReadDrive + fn;
    for b := length(fn) to 12 do ArcList[ArcSrn] := ArcList[ArcSrn] + ' ';
    twodig(mo);
    ArcList[ArcSrn] := ArcList[ArcSrn] + s + '-';
    twodig(dy);
    ArcList[ArcSrn] := ArcList[ArcSrn] + s + '-';
    twodig((yr + 80) mod 100);
    ArcList[ArcSrn] := ArcList[ArcSrn] + s + '  ';
    twodig(hh);
    ArcList[ArcSrn] := ArcList[ArcSrn] + s + ':';
    twodig(mm);
    Str(rlen:7:0,sthold);
    ArcList[ArcSrn] := ArcList[ArcSrn] + s + sthold + '     ';
  end;