ftp.wwiv.com/ftp.wwiv.com.zip/ftp.wwiv.com/pub/MISC/MKDATE12.ZIP/block2.pas

Pascal/Delphi Source File | 2003-06-21 | 4KB | 220 lines

unit block2;

interface

uses
 block, sublist, message;

var
 headerfpos, msgfpos: longint;
 err: integer;

 membroot: treeroottype;
 p: sublistptr;

function frecname(p: pointer): string;
procedure ergor(p: pointer);
procedure ergow(p: pointer);
procedure lockclose;
function subopen(a: subfilesset): boolean;
function lockopen: boolean;
procedure error;
procedure err2(bx: byte; a: string);
procedure dserr(x: integer);

function blockopen(var q: blockfiletype): boolean;
procedure blockclose(var q: blockfiletype);
function lroot(var q: blockfiletype): longint;

implementation

uses
 dos;

const
 errmode: array[1..2] of string[7] = (
  'reading',
  'writing'
  );

 diskerr: array[1..8] of string[19] = (
  'File not found',
  'Path not found',
  'Access denied',
  'Invalid handle',
  'Not enough memory',
  'Invalid environment',
  'Invalid format',
  'No more files'
  );

function frecname(p: pointer): string;
 type
  bete = ^filerec;
 var
  q: bete absolute p;
 begin
  frecname := copy(q^.name, 1, pos(#0, q^.name) - 1)
 end;

procedure ergor(p: pointer);
 begin
  err := ioresult;
  if (err <> 0) then err2(1, frecname(p))
 end;

procedure ergow(p: pointer);
 begin
  err := ioresult;
  if (err <> 0) then err2(2, frecname(p))
 end;

procedure lockclose;
 begin
  blockclose(mainsub.headerf);
  blockclose(mainsub.msgf);
  blockclose(mainsub.memberf)
 end;

function subopen(a: subfilesset): boolean;
 var
  e: boolean;
  b: pathstr;
 begin
  lockclose;
  mainsub.name := p^.fname;
  e := true;
  b := p^.path + p^.fname;
  if e and (headerf in a) then
   begin
    assign(mainsub.headerf.filevar, b + '.HDR');
    e := blockopen(mainsub.headerf);
    if e then
     begin
      blockread(mainsub.headerf.filevar, mainsub.subinfo, 128);
      err := ioresult;
      e := (err = 0)
     end
   end;
  if e and (msgf in a) then
   begin
    assign(mainsub.msgf.filevar, b + '.MSG');
    e := blockopen(mainsub.msgf)
   end;
  if e and (memberf in a) then
   begin
    assign(mainsub.memberf.filevar, b + '.MBR');
    e := blockopen(mainsub.memberf);
    if e then
     begin
      blockread(mainsub.memberf.filevar, membroot, 12);
      err := ioresult;
      e := (err = 0)
     end
   end;
  subopen := e
 end;

function lockopen: boolean;
 var
  t: boolean;
 begin
  if mainsub.memberf.open then t := subopen([headerf, msgf])
  else t := subopen(allfiles);
  if t then
   if (lockfile(mainsub.headerf) and lockfile(mainsub.msgf) and
    (not(mainsub.memberf.open) or lockfile(mainsub.memberf))) then
    begin
     headerfpos := -1;
     msgfpos := -1
    end
   else
    begin
     lockclose;
     t := false
    end;
  lockopen := t
 end;

procedure error;
 begin
  lockclose;
  writeln('*** Error from DOS operation ***');
  write(#7);
  halt(1)
 end;

procedure err2(bx: byte; a: string);
 begin
  lockclose;
  writeln('*** Error ', errmode[bx], ' file ', a, ' ***');
  write(#7);
  halt(1)
 end;

procedure dserr(x: integer);
 begin
  write('DOS error ', x, ': ');
  case x of
    2: writeln(diskerr[1]);
    3: writeln(diskerr[2]);
    5: writeln(diskerr[3]);
    6: writeln(diskerr[4]);
    8: writeln(diskerr[5]);
   10: writeln(diskerr[6]);
   11: writeln(diskerr[7]);
   18: writeln(diskerr[8]);
  else writeln
  end;
  error
 end;

function blockopen(var q: blockfiletype): boolean;
 var
  foo: boolean;
 begin
  filemode := 66;
  reset(q.filevar, 1);
  err := ioresult;
  foo := (err = 0);
  if foo then
   begin
    blockread(q.filevar, q.header, 12);
    err := ioresult;
    foo := (err = 0);
    if foo then
     begin
      q.open := true;
      q.lock := 0;
      q.hlock := 0;
      q.recsize := q.header.recsize;
      q.offset := q.header.offset
     end
   end;
  blockopen := foo
 end;

procedure blockclose(var q: blockfiletype);
 begin
  while (q.lock + q.hlock) > 0 do unlockfile(q);
  if q.open then
   begin
    close(q.filevar);
    ergor(@q.filevar)
   end;
  fillchar(q, sizeof(blockfiletype), 0)
 end;

function lroot(var q: blockfiletype): longint;
 var
  fie: treeroottype;
 begin
  blockread(q.filevar, fie, 12);
  ergow(@q.filevar);
  lroot := fie.listroot
 end;

begin
 fillchar(mainsub, sizeof(mainsub), 0);
end.