Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/SYSPC22.ZIP/SUBS1.PAS

Pascal/Delphi Source File | 1988-04-26 | 11.5 KB | 560 lines

    const chatnum:integer=0;
          lastonda:string[8]='00/00/00';
          lastonti:string[8]='00:00 xx';
          usedit:boolean=false;
          dogit:boolean=false;
          echo:boolean=true;

var local,online,chatmode,disconnected:boolean;

    nnu,Shell_return_code,foreg,backg,unum,ulvl,baudrate:integer;
    edit_user,senttol,replyt,replyguy,unam:mstr;
    baudstr,timebefore,daybefore:sstr;
    canon,sta,ns,nosys,imdone,validphone,telenet,feed,parity,fin,mnu:boolean;
    urec:userrec;
    logontime,logofftime,logonunum:integer;
    laston:string[8];
    sendtoistru,replyanon,ranon,dots,nochain,break,xpressed,requestchat,requestcom,reqspecial,
    modeminlock,modemoutlock,timelock,tempsysop,splitmode,
    fromdoor,texttrap,printerecho,uselinefeeds,usecapsonly,
    dload,endp,dontstop,nobreak,wordwrap,sysnext:boolean;
    regularlevel,numusers,curboardnum,lasty,
    turbooutptr,turboinptr,devicestackptr,linecount,curattrib,
    newups,newmsgs,reply,firstfree,lockedtime,screenseg,iocode:integer;
    cursection:configtype;
    curboardname:sstr;
    messagemenunames,input,chainstr:anystr;
    chatreason,lastprompt,errorparam,errorproc:lstr;
    curboard:boardrec;
    curdevice:ptr absolute dseg:$232;
    devicestack:array [1..10] of ptr;
    mes:message;
    syslogdat:array [0..maxsyslogdat] of syslogdatrec;
    numsyslogdat:integer;


const numsysfiles=17;
var tfile:file of buffer;
    mapfile:file of integer;
    ufile:file of userrec;
    mfile:file of mailrec;
    udfile:file of udrec;
    afile:file of arearec;
    bfile:file of bulrec;
    bdfile:file of boardrec;
    bifile:file of sstr;
    ffile:file of filerec;
    tofile:file of topicrec;
    chfile:file of choicerec;
    ddfile:file of baserec;
    efile:file of entryrec;
    dofile:file of doorrec;
    gfile:file of grouprec;
    logfile:file of logrec;
    sysfiles:array [1..numsysfiles] of file absolute tfile;
    ttfile:text;

function readchar:char; forward;
function charready:boolean; forward;
procedure writestr (s:anystr); forward;
procedure writeturbo (k:char); forward;
procedure breakout; forward;
procedure chat (gotospecial:boolean); forward;
procedure cls; forward;
procedure disconnect; forward;
procedure openbdfile; forward;
procedure closebdfile; forward;
procedure formatbdfile; forward;
procedure opentempbdfile; forward;
procedure closetempbdfile; forward;
procedure setuseraccflag (var u:userrec; bn:integer; ac:accesstype); forward;
procedure setalluserflags (var u:userrec; ac:accesstype); forward;
procedure readurec; forward;
procedure writeurec; forward;

procedure pushdevice;
begin
  if devicestackptr=10 then exit;
  devicestackptr:=devicestackptr+1;
  devicestack[devicestackptr]:=curdevice
end;

procedure popdevice;
begin
  if devicestackptr<1 then exit;
  curdevice:=devicestack[devicestackptr];
  devicestackptr:=devicestackptr-1
end;

function strr (n:integer):mstr;
var q:mstr;
begin
  str (n,q);
  strr:=q
end;

function streal (r:real):mstr;
var q:mstr;
begin
  str (r:0:0,q);
  streal:=q
end;

function valu (q:mstr):integer;
var i,s,pu:integer;
    r:real;
begin
  valu:=0;
  if length(q)=0 then exit;
  if not (q[1] in ['0'..'9','-']) then exit;
  if length(q)>5 then exit;
  val (q,r,s);
  if s<>0 then exit;
  if (r<=32767.0) and (r>=-32767.0)
    then valu:=round(r)
end;

procedure parse3 (s:lstr; var a,b,c:integer);
var p:integer;

  procedure parse1 (var n:integer);
  var ns:lstr;
  begin
    ns[0]:=#0;
    while (p<=length(s)) and (s[p] in ['0'..'9']) do begin
      ns:=ns+s[p];
      p:=p+1
    end;
    if length(ns)=0
      then n:=0
      else n:=valu(ns);
    if p<length(s) then p:=p+1
  end;

begin
  p:=1;
  parse1 (a);
  parse1 (b);
  parse1 (c)
end;

function realtime:real;
var r:regs;
    hu,s,m,h:byte;
begin
  r.ax:=$2c00;
  intr ($21,r);
  hu:=r.dx and 255;
  s:=r.dx shr 8;
  m:=r.cx and 255;
  h:=r.cx shr 8;
  realtime:=hu+100.0*s+100.0*60.0*m+100.0*60.0*60.0*h
end;

function timestr:sstr;
var h,h1,m:integer;
    r:regs;
    ms:sstr;
begin
  r.ax:=$2c00;
  intr ($21,r);
  h:=r.cx shr 8;
  m:=r.cx and 255;
  if h=0
    then h1:=12
    else if h<13
      then h1:=h
      else h1:=h-12;
  ms:=strr(m);
  if m<10 then ms:='0'+ms;
  ms:=strr(h1)+':'+ms+' ';
  if h>11
    then timestr:=ms+'pm'
    else timestr:=ms+'am'
end;

function timeval (q:sstr):integer;
var h,h1,m,t:integer;
    k:char;
begin
  parse3 (q,h1,m,t);
  k:=upcase(q[length(q)-1]);
  if h1 in [1..11]
    then
      begin
        h:=h1;
        if k='P' then h:=h+12
      end
    else
      if k='P'
        then h:=12
        else h:=0;
  timeval:=h*60+m
end;

function datestr:sstr;
var r:regs;
begin
  r.ax:=$2a00;
  intr ($21,r);
  datestr:=strr(r.dx shr 8)+'/'+strr(r.dx and 255)+'/'+strr(r.cx-1900)
end;

function later (d1,t1,d2,t2:sstr):boolean;
var m1,da1,y1,m2,da2,y2:integer;

  function latertime (t1,t2:sstr):boolean;
  var n1,n2:integer;
  begin
    latertime:=timeval(t1)>timeval(t2)
  end;

begin
  parse3 (d1,m1,da1,y1);
  parse3 (d2,m2,da2,y2);
  if y1=y2
    then if m1=m2
      then if da1=da2
        then later:=timeval(t1) > timeval(t2)
        else later:=da1>da2
      else later:=m1>m2
    else later:=y1>y2
end;

function upstring (s:anystr):anystr;
var cnt:integer;
begin
  for cnt:=1 to length(s) do s[cnt]:=upcase(s[cnt]);
  upstring:=s
end;

function lowstring (s:anystr):anystr;
var cnt:integer;

 begin
   for cnt:=1 to length(s) do begin
   if s[cnt] in ['A'..'Z'] then s[cnt]:=chr(ord(s[cnt])+32);
 end;
  lowstring:=s;
 end;

function match (s1,s2:anystr):boolean;
var cnt:integer;
begin
  match:=false;
  if length(s1)<>length(s2) then exit;
  for cnt:=1 to length(s1) do
    if upcase(s1[cnt])<>upcase(s2[cnt])
      then exit;
  match:=true
end;

procedure writelog (m,s:integer; prm:lstr);
var n:integer;
    l:logrec;
begin
  with l do begin
    menu:=m;
    subcommand:=s;
    date:=datestr;
    time:=timestr;
    param:=copy(prm,1,41)
  end;
  seek (logfile,filesize(logfile));
  write (logfile,l)
end;

procedure files30;
begin
  writeln (usr,'You MUST put FILES=30 in your CONFIG.SYS!');
  halt(4)
end;

function ioerrorstr (num:integer):lstr;
var tf:text;
    tmp:lstr;
    n,s:integer;
begin
  if num=243 then files30;
  assign (tf,'Ioerror.lst');
  reset (tf);
  if ioresult<>0 then begin
    ioerrorstr:='* Can''t open IOERROR.LST *';
    exit
  end;
  while not eof(tf) do begin
    readln (tf,tmp);
    val (tmp,n,s);
    if n=num then begin
      ioerrorstr:=tmp;
      close (tf);
      exit
    end
  end;
  close (tf);
  ioerrorstr:='Unidentified I/O error '+strr(num)
end;

procedure error (errorstr,proc,param:lstr);
var p,n:integer;
    pk:char;
    tf:text;
label found;
begin
  n:=ioresult;
  repeat
    p:=pos('%',errorstr);
    if p<>0 then begin
      pk:=copy(errorstr,p+1,1);
      delete (errorstr,p,2);
      case upcase(pk) of
        '1':insert (param,errorstr,p);
        'P':insert (proc,errorstr,p);
        'I':insert (ioerrorstr(iocode),errorstr,p)
      end
    end
  until p=0;
  pushdevice;
  assign (tf,'ErrLog');
  append (tf);
  if ioresult<>0
    then
      begin
        close (tf);
        rewrite (tf)
      end;
  writeln (tf,unam,' was on-line on ',datestr,' at ',timestr,' when:');
  writeln (tf,errorstr);
  writeln (tf);
  close (tf);
  n:=ioresult;
  writelog (0,4,errorstr);
  popdevice;
  writeln (errorstr)
end;

procedure fileerror (procname,filename:mstr);
begin
  error ('%I accessing %1 in %P',procname,filename)
end;

procedure che;
var i:integer;
begin
  i:=ioresult;
  case i of
    0,255:;
    243:files30;
    else
      begin
        iocode:=i;
        error ('Unexpected I/O error %I','','')
      end
  end
end;

function timeleft:integer;
var timeon:integer;
begin
  timeon:=timer-logontime;
  if timeon<0 then timeon:=timeon+1440;
  timeleft:=urec.timetoday-timeon
end;

function timetillevent:integer;
var n:integer;
begin
  if (length(eventtime)=0) or (length(eventbatch)=0) or
    (timedeventdate=datestr)
    then n:=1440
    else n:=timeval(eventtime)-timer;
  if n<0 then n:=n+1440;
  timetillevent:=n
end;

procedure settimeleft (tl:integer);
begin
  urec.timetoday:=timer+tl-logontime
end;

function devicename (name:lstr):boolean;
var f:file;
    n:integer absolute f;
    r:regs;
begin
  devicename:=false;
  assign (f,name);
  reset (f);
  if ioresult<>0 then exit;
  r.bx:=n;
  r.ax:=$4400;
  intr ($21,r);
  devicename:=(r.dx and 128)=128;
  close (f)
end;

function exist (n:lstr):boolean;
var f:file;
    i:integer;
begin
  assign (f,n);
  reset (f);
  i:=ioresult;
  exist:=i<>1;
  close (f);
  i:=ioresult
end;

procedure appendfile (name:lstr; var q:text);
var n:integer;
    b:boolean;
    f:file of char;
begin
  close (q);
  n:=ioresult;
  assign (q,name);
  assign (f,name);
  reset (f);
  b:=(ioresult<>0) or (filesize(f)=0);
  close (f);
  n:=ioresult;
  if b
    then rewrite (q)
    else append (q)
end;

procedure tab (n:anystr; np:integer);
var cnt:integer;
begin
  write (^B,n);
  for cnt:=length(n) to np-1 do write (' ')
end;

function yes:boolean;
begin
  if length(input)=0
    then yes:=false
    else yes:=upcase(input[1])='Y'
end;

function yesno (b:boolean):sstr;
begin
  if b
    then yesno:='Yes'
    else yesno:='No'
end;

function timeontoday:integer;
var timeon:integer;
begin
  timeon:=timer-logontime;
  if timeon<0 then timeon:=timeon+1440;
  timeontoday:=timeon
end;

function isopen (var ff):boolean;
var fi:fib absolute ff;
begin
  isopen:=fi.handle<>-1
end;

procedure textclose (var f:text);
var n:integer;
begin
  if isopen(f)
    then close (f);
  n:=ioresult
end;

procedure oldclose (var ff);
var f:file absolute ff;
    n:integer;
begin
  close (f);
  n:=ioresult
end;

procedure close (var ff);
var f:file absolute ff;
begin
  if isopen(f)
    then oldclose (f)
end;

function withintime (t1,t2:sstr):boolean;
var t,a,u:integer;
begin
  t:=timer;
  a:=timeval(t1);
  u:=timeval(t2);
  if a<=u
    then withintime:=(t>=a) and (t<=u)
    else withintime:=(t>=a) or (t<=u)
end;

function sysopisavail:boolean;
begin
  case sysopavail of
    available:sysopisavail:=true;
    notavailable:sysopisavail:=false;
    bytime:sysopisavail:=withintime (availtime,unavailtime)
  end
end;

function sysopavailstr:sstr;
const strs:array [available..notavailable] of string[9]=
        ('Yes','By time: ','No');
var tstr:sstr;
    tmp:availtype;
begin
  tstr:=strs[sysopavail];
  if sysopavail=bytime
    then
      begin
        if sysopisavail
          then tmp:=available
          else tmp:=notavailable;
        tstr:=tstr+strs[tmp]
      end;
  sysopavailstr:=tstr
end;

function singularplural (n:integer; m1,m2:mstr):mstr;
begin
  if n=1
    then singularplural:=m1
    else singularplural:=m2
end;

function s (n:integer):sstr;
begin
  s:=singularplural (n,'','s')
end;

function numthings (n:integer; m1,m2:mstr):lstr;
begin
  numthings:=strr(n)+' '+singularplural (n,m1,m2)
end;

procedure thereisare (n:integer);
begin
  write ('There ');
  if n=1
    then write ('is 1 ')
    else
      begin
        write ('are ');
        if n=0
          then write ('no ')
          else write (n,' ')
       end
end;

procedure thereare (n:integer; m1,m2:mstr);
begin
  thereisare (n);
  if n=1
    then write (m1)
    else write (m2);
  writeln ('.')
end;