Power-Programmierung/CD1.mdf/pascal/library/dos/communic/common/common.pas

Pascal/Delphi Source File | 1990-06-23 | 17.7 KB | 898 lines

unit common;

{This unit is based on Wayne Bell's realease of common.pas for WWIV 4.00
 and is now compatible with 5.0 and 5.5.  There are a few modifications
 in this version.

  1. It supports the modem and needs the Unit IBMCOM to work.

  2. It support several BBS types which are:
      Wildcat!
      WWIV
      DOOR.SYS
      Spitfire

  3. Has a SETUP function to set up the modem and such.

  4. Has a status line called SLINE that prints a line of infomation at
     the bottom of the screen.

  I hold no rights to this or any changes I made.  The only reason I did
  this is so that some of the excellent on-liners out there can be used
  on not onlt WWIV but other boards, and alos so they can be updated to
  later version of TP.  Hope to see many good on-liners on other boards
  then WWIV.
 }

interface

CONST strlen=160;

TYPE strr=string[strlen];
     userrec=record
               name:string[25];
               realname:string[14];
               laston:string[10];
               linelen:byte;
               pagelen:byte;
               sl:byte;
               age:byte;
               sex:char;
               callsign:string[8];
               gold:real;
             end;

var
    sysopf:text{[1024]};
    sysopffn:string[80];
    gfilespath,datapath:string[80];
    usernum:integer;
    incom,okansi,cs,so,hangup,local:boolean;
    timeon,timeleft:real;
    thisuser:userrec;

procedure pnt(c:char);
function timer:real;
function nsl:real;
function sysop1:boolean;
function sysop:boolean;
procedure sl1(i:strr);
procedure sysoplog(i:strr);
function tch(i:strr):strr;
function time:strr;
function date:strr;
function value(I:strr):integer;
function cstr(i:integer):strr;
function nam:strr;
function leapyear(yr:integer):boolean;
function days(mo,yr:integer):integer;
function daycount(mo,yr:integer):integer;
function daynum(dt:strr):integer;
function dat:strr;
procedure checkhangup;
procedure ansic(c:integer);
procedure sdc;
procedure pausescr;
procedure prompt(i:strr);
procedure print(i:strr);
procedure nl;
procedure prt(i:strr);
procedure ynq(i:strr);
procedure mpl(c:integer);
procedure tleft;
function empty:boolean;
function inkey:char;
procedure getkey(var c:char);
procedure cls;
function yn:boolean;
procedure input1(var i:strr; ml:integer; tf:boolean);
procedure input(var i:strr; ml:integer);
procedure inputl(var i:strr; ml:integer);
procedure onek(var c:char; ch:strr);
procedure wkey(var abort,next:boolean);
function ctim(rl:real):strr;
function tlef:strr;
function cstrr(rl:real; base:integer):strr;
procedure printa1(i:strr; var abort,next:boolean);
procedure printa(i:strr; var abort,next:boolean);
procedure printacr(i:strr; var abort,next:boolean);
procedure pfl(fn:strr; var abort:boolean; cr:boolean);
procedure printfile(fn:strr);
procedure iport;
procedure return;
procedure setup;
procedure sline (thisuser:userrec);

implementation

uses crt,dos,ibmcom;

var
 rp:registers;

procedure pnt;
begin
 if not(local) then
  com_tx(c);
end;

function timer;
var reg:registers;
    h,m,s,t:real;
begin
  reg.ax:=44*256;
  msdos(dos.registers(reg));
  h:=(reg.cx div 256);
  m:=(reg.cx mod 256);
  s:=(reg.dx div 256);
  t:=(reg.dx mod 256);
  timer:=h*3600+m*60+s+t/100;
end;

function nsl;
begin
  if timer<timeon then
    timeon:=timeon-24.0*3600.0;
  nsl:=timeleft-(timer-timeon);
end;

function sysop1;
begin
  if (mem[0:1047] and 16)=0 then sysop1:=false else sysop1:=true;
end;

function sysop;
begin
  sysop:=sysop1;
end;

procedure sl1;
begin
  writeln(sysopf,i);
end;

procedure sysoplog;
begin
  if (not so) or incom then
    sl1('   '+i);
end;

function tch;
begin
  if length(i)>2 then i:=copy(i,length(i)-1,2) else
    if length(i)=1 then i:='0'+i;
  tch:=i;
end;

function time;
var reg:registers;
    h,m,s:string[4];
begin
  reg.ax:=$2c00; intr($21,dos.registers(reg));
  str(reg.cx shr 8,h); str(reg.cx mod 256,m); str(reg.dx shr 8,s);
  time:=tch(h)+':'+tch(m)+':'+tch(s);
end;

function date;
var reg:registers;
    m,d,y:string[4];
begin
  reg.ax:=$2a00; msdos(Dos.Registers(reg)); str(reg.cx,y); str(reg.dx mod 256,d);
  str(reg.dx shr 8,m);
  date:=tch(m)+'/'+tch(d)+'/'+tch(y);
end;

function value;
var n,n1:integer;
begin
  val(i,n,n1);
  if n1<>0 then begin
    i:=copy(i,1,n1-1);
    val(i,n,n1)
  end;
  value:=n;
  if i='' then value:=0;
end;

function cstr;
var c:strr;
begin
  str(i,c); cstr:=c;
end;

function nam;
var s:strr; i:integer; tf:boolean;
begin
  s:=thisuser.name;
  tf:=true;
  for i:=1 to length(s) do
    if s[i]<'A' then
      tf:=true
    else begin
      if (s[i]<='Z') and not tf then
        s[i]:=chr(ord(s[i])+32);
      tf:=false;
    end;
  nam:=s+' #'+cstr(usernum);
end;

function leapyear;
begin
  leapyear:=(yr mod 4=0) and ((yr mod 100<>0) or (yr mod 400=0));
end;

function days;
var d:integer;
begin
  d:=value(copy('312831303130313130313031',1+(mo-1)*2,2));
  if (mo=2) and leapyear(yr) then d:=d+1;
  days:=d;
end;

function daycount;
var m,t:integer;
begin
  t:=0;
  for m:=1 to (mo-1) do t:=t+days(m,yr);
  daycount:=t;
end;

function daynum;
var d,m,y,t,c:integer;
begin
  t:=0;
  m:=value(copy(dt,1,2));
  d:=value(copy(dt,4,2));
  y:=value(copy(dt,7,2))+1900;
  for c:=1985 to y-1 do
    if leapyear(c) then t:=t+366 else t:=t+365;
  t:=t+daycount(m,y)+(d-1);
  daynum:=t;
  if y<1985 then daynum:=0;
end;

function dat;
var ap,x,y:strr; i:integer;
begin
  case daynum(date) mod 7 of
    0:x:='Tue';
    1:x:='Wed';
    2:x:='Thu';
    3:x:='Fri';
    4:x:='Sat';
    5:x:='Sun';
    6:x:='Mon';
  end;
  case value(copy(date,1,2)) of
    1:y:='Jan';
    2:y:='Feb';
    3:y:='Mar';
    4:y:='Apr';
    5:y:='May';
    6:y:='Jun';
    7:y:='Jul';
    8:y:='Aug';
    9:y:='Sep';
    10:y:='Oct';
    11:y:='Nov';
    12:y:='Dec';
  end;
  x:=x+' '+y+' '+copy(date,4,2)+', '+cstr(1900+value(copy(date,7,2)));
  y:=time; i:=value(copy(y,1,2));
  if i>11 then ap:='pm' else ap:='am';
  if i>12 then i:=i-12;
  if i=0 then i:=12;
  dat:=cstr(i)+copy(y,3,3)+' '+ap+'  '+x;
end;

procedure checkhangup;
begin
 if hangup or (not(com_carrier)) then
  if not (local) then
   hangup := true;
end;

procedure ansic;
var f,b:byte;
    fs,bs:strr;
begin
 if c = 0 then
  c:=1;
 b := 40;
 case c of
  1: f := 36;
  2: f := 33;
  3: f := 35;
  4: begin
      f := 37;
      b := 44;
     end;
  5: f := 32;
  6: f := 31;
  7: f := 34;
  8: f := 34;
  9: f := 34;
 end;
 textbackground (b-40);
 textcolor (f-30);
 fs := cstr(f);
 bs := cstr(b);
 if okansi then begin
  pnt(#27); pnt('['); pnt(fs[1]); pnt(fs[2]);
  pnt(';'); pnt(bs[1]); pnt(bs[2]); pnt('m');
 end;
end;

procedure sdc;
begin
  ansic(0);
end;


procedure pausescr;
var i:integer; cc:char;
begin
  ansic(3); prompt('[PAUSE]'); ansic(0);
  getkey(cc);
  for i:=1 to 7 do
    prompt(#8+' '+#8);
end;

procedure prompt;
var c:integer; cc:char;
begin
 c := 0;
 checkhangup;
 if (not hangup) then
  repeat
   c := c+1;
   if (i[c]=#10) then
     ansic(0);
   if not(i[c]=#3) then begin
    write(i[c]);
    pnt(i[c]);
   end
   else begin
    if (i[c+1] in ['0'..'9']) then begin
     c := c + 1;
     ansic(value(i[c]));
     end
    else begin
     ansic(0);
     c := c + 1;
    end;
   end;
  until c = length(i);
end;

procedure print;
begin
  prompt(i+chr(13)+chr(10))
end;

procedure nl;
begin
  prompt(chr(13)+chr(10))
end;

procedure prt;
begin
  ansic(4); prompt(i); ansic(0);
end;

procedure ynq;
begin
  ansic(7); prompt(i);
end;

procedure mpl;
var n:integer; i:strr;
begin
  if okansi then begin
    ansic(6);
    i:='';
    for n:=1 to c do i:=i+' ';
    prompt(i);
    prompt(#27+'['+cstr(c)+'D');
  end;
end;

procedure tleft;
var x,y:integer;
begin
  if timer<timeon then timeon:=timeon-24.0*60*60;
  if (nsl<0) then begin
    nl;
    print('Time expired.');
    hangup:=true;
  end;
  checkhangup;
end;


function empty;
begin
 empty := true;
 if not (local) then
  empty := com_rx_empty;
end;

function inkey;
begin
 inkey := #0;
 if not (local) then
  inkey := com_rx
 else
  if keypressed then
   inkey := readkey;
end;


procedure getkey;
var
 r:real;
begin
 r := timer;
 c := #0;
 repeat
  checkhangup;
  if not (local) then
   if not(empty) then
    c:= com_rx;
  if keypressed and (not(c<>#0)) then
   c := readkey;
  if hangup or ((timer-r)>300.00) then
   hangup := true;
 until (c <> #0) or hangup;
end;

procedure cls;
begin
  clrscr;
  pnt (chr(12));
end;


function yn;
var c:char;
begin
  if not hangup then begin
    ansic(3);
    repeat
      getkey(c);
      c:=upcase(c);
    until (c='Y') or (c='N') or (c=chr(13)) or hangup;
    if c='Y' then begin print('Yes'); yn:=true; end else begin print('No'); yn:=false; end;
    if hangup then yn:=false;
  end;
end;

procedure input1;
var cp:integer;
    c:char;
    r:real;
begin
 checkhangup;
 if not hangup then begin
  r:=timer;
  cp:=1;
  repeat
    getkey(c);
    if c=#1 then r:=timer;
    if not tf then c:=upcase(c);
    if (c>=' ') and (c<chr(127)) then
      if cp<=ml then begin
       i[cp]:=c;
       cp:=cp+1;
       write(c);
       pnt(c);
    end else else case ord(c) of
      8:if cp>1 then begin
               c:=chr(8);
               write(#8#32#8);
               pnt(#8); pnt (#32); pnt(#8);
               cp:=cp-1;
             end;
      21,24:while cp<>1 do begin
               cp:=cp-1;
               write(#8#32#8);
               pnt(#8); pnt (#32); pnt(#8);
             end;
    end;
    if (timer-r)>300.0 then hangup:=true;
  until (c=#13) or (c=#14) or hangup;
  i[0]:=chr(cp-1);
  nl;
 end;
end;

procedure input;
begin
  input1(i,ml,false);
end;


procedure inputl;
begin
  input1(i,ml,true);
end;

procedure onek;
begin
  repeat
    getkey(c);
    c:=upcase(c);
  until (pos(c,ch)>0) or hangup;
  if hangup then c:=ch[1];
  print(''+c);
end;


 procedure wkey;
 var cc:char;
 begin
    while not (empty or hangup or abort) do begin
      getkey(cc);
      if (cc=' ') or (cc=chr(3)) or (cc=chr(24)) or (cc=chr(11)) then
        abort:=true;
      if (cc=chr(14)) then begin abort:=true; next:=true; end;
      if (cc=chr(19)) or (cc='P') or (cc='p') then begin
        getkey(cc);
      end;
    end;
 end;

function ctim;
var h,m,s:strr;
begin
  s:=tch(cstr(trunc(rl-int(rl/60.0)*60.0)));
  m:=tch(cstr(trunc(int(rl/60.0)-int(rl/3600.0)*60.0)));
  h:=cstr(trunc(rl/3600.0));
  if length(h)=1 then h:='0'+h;
  ctim:=h+':'+m+':'+s;
end;

function tlef;
begin
  tlef:=ctim(nsl);
end;

function cstrr;
var c1,c2,c3:integer; i:strr; r1,r2:real;
begin
 if rl<=0.0 then cstrr:='0' else begin
  r1:=ln(rl)/ln(1.0*base);
  r2:=exp(ln(1.0*base)*(trunc(r1)));
  i:='';
  while (r2>0.999) do begin
    c1:=trunc(rl/r2);
    i:=i+copy('0123456789ABCDEF',c1+1,1);
    rl:=rl-c1*r2;
    r2:=r2/(1.0*base);
  end;
  cstrr:=i;
 end;
end;


procedure printa1;
var c:integer;
begin
 checkhangup;
 if not hangup then begin
  abort:=false; next:=false; c:=1;
  if not empty then wkey(abort,next);
  while (not abort) and (c-1<length(i)) and (not hangup) do begin
    checkhangup;
    if i[c]=#3 then
      if i[c+1] in ['0'..'9'] then
        if okansi then
          ansic(ord(i[c+1]));
    if not empty then wkey(abort,next);
    if i[c]=#3 then
      c:=c+1
    else
      write(i[c]);
      pnt(i[c]);
    c:=c+1;
  end;
 end else abort:=true;
end;

procedure printa;
var s:strr; p,op,rp,rop,nca:integer; crend:boolean;
begin
  abort:=false;
  crend:=(i[length(i)]=#1) and (i[length(i)-1]<>#3);
  if crend then i:=copy(i,1,length(i)-1);
  wkey(abort,next);
  if i='' then nl;
  while (i<>'') and (not abort) and (not hangup) do begin
    rp:=0; nca:=thisuser.linelen-wherex-1; p:=0;
    while (rp<nca) and (p<length(i)) do begin
      if i[p+1]=#8 then rp:=rp-1 else
        if i[p+1]=#3 then
          p:=p+1
        else
          if (i[p+1]<>#10) then rp:=rp+1;
      p:=p+1;
    end;
    op:=p; rop:=rp;
    if (rp>=nca) and (p<length(i)) then begin
      while ((not (i[p] in [' ',#8,#10])) or (i[p-1]=#3)) and (p>1) do begin
        rp:=rp-1; p:=p-1;
      end;
      if p=1 then
        if not (i[1] in [' ',#8,#10]) then begin rp:=rp-1; p:=p-1; end;
    end;
    if abs(rop-rp)>=(thisuser.linelen div 2) then p:=op;
    s:=copy(i,1,p); delete(i,1,p);
    if (s[length(s)]=' ') then s[0]:=pred(s[0]);
    printa1(s,abort,next);
    if ((i='') and crend) or (i<>'') or abort then
      nl
    else
      printa1(' ',abort,next);
  end;
end;

procedure printacr;
begin
 if not abort then
  if i[length(i)]=#1 then
    printa(i,abort,next)
  else
    printa(i+#1,abort,next);
end;

procedure pfl;
var fil:text;
    i:strr;
    next:boolean;
    n:integer;
begin
    n := 0;
    if not hangup then begin
      assign(fil,fn);
      {$I-} reset(fil); {$I+}
      if ioresult<>0 then print('File not found.') else begin
        abort:=false;
        while not eof(fil) and (not abort) and (not hangup) do begin
          readln(fil,i);
          n := n + 1;
          if cr then
            printacr(i,abort,next)
          else
            printa(i,abort,next);
          if n = (thisuser.pagelen - 1) then begin
           pausescr;
           n := 0;
          end;
        end;
        close(fil);
      end;
      nl;nl;
    end;
end;

procedure printfile;
var abort:boolean;
begin
  pfl(fn,abort,true);
end;

procedure iport;
var f:text;
    i:strr;
    n:integer;
begin
 if paramstr(1) = '-4' then begin
  assign(f,paramstr(2));
  {$I-} reset(f); {$I+}
  if (ioresult=0) then begin
    readln(f,usernum);
    readln(f,thisuser.name);
    readln(f,thisuser.realname);
    readln(f,thisuser.callsign);
    readln(f,thisuser.age);
    readln(f,thisuser.sex);
    readln(f,thisuser.gold);
    readln(f,thisuser.laston);
    readln(f,thisuser.linelen);
    readln(f,thisuser.pagelen);
    readln(f,thisuser.sl);
    readln(f,n);
    cs:=(n=1);
    readln(f,n);
    so:=(n=1);
    readln(f,n);
    okansi:=(n=1);
    readln(f,n);
    incom:=(n=1);
    readln(f,timeleft);
    readln(f,gfilespath);
    readln(f,datapath);
    readln(f,i);
    close(f);
    sysopffn:=gfilespath+i;
  end else begin
    writeln('Parameter file not found.');
    halt;
  end;
  hangup:=false;
  timeon:=timer;
 end;
 if paramstr(1) = '-w' then begin
  assign(f,paramstr(2));
  {$I-} reset(f); {$I+}
  if (ioresult=0) then begin
    readln(f,thisuser.name);
    readln (f,i);
    readln (f,i);
    readln (f,thisuser.sl);
    readln (f,i);
    readln (f,i);
    if i = 'COLOR' then
     okansi := true
    else
     okansi := false;
    readln(f,i);
    readln(f,usernum);
    readln(f,i);
    readln(f,i);
    readln(f,i);
    readln(f,i);
    readln(f,i);
    readln(f,i);
    readln(f,i);
    readln(f,i);
    readln(f,i);
    readln(f,i);
    readln(f,i);
    readln(f,i);
    readln(f,i);
    readln(f,i);
    readln(f,thisuser.pagelen);
    thisuser.linelen := 80;
    close (f);
  end else begin
    writeln('Parameter file not found.');
    halt;
  end;
  hangup:=false;
  timeon:=timer;
 end;
 if paramstr(1) = '-d' then begin
  assign(f,paramstr(2));
  {$I-} reset(f); {$I+}
  if (ioresult=0) then begin
    readln(f,i);
    readln(f,i);
    readln(f,i);
    readln(f,i);
    readln(f,i);
    readln(f,i);
    readln(f,i);
    readln(f,i);
    readln(f,i);
    readln(f,thisuser.name);
    readln(f,i);
    readln(f,i);
    readln(f,i);
    readln(f,i);
    readln(f,thisuser.sl);
    readln(f,i);
    if i = '1' then
     okansi := true
    else
     okansi := false;
    readln(f,i);
    readln(f,i);
    readln(f,i);
    readln(f,i);
    readln(f,thisuser.pagelen);
    readln(f,i);
    readln(f,i);
    readln(f,i);
    readln(f,i);
    readln(f,usernum);
    thisuser.linelen := 80;
    close (f);
  end else begin
    writeln('Parameter file not found.');
    halt;
  end;
  hangup:=false;
  timeon:=timer;
 end;
 if paramstr(1) = '-s' then begin
  assign(f,paramstr(2));
  {$I-} reset(f); {$I+}
  if (ioresult=0) then begin
    readln(f,usernum);
    readln(f,thisuser.name);
    readln(f,i);
    readln(f,i);
    readln(f,i);
    readln(f,i);
    readln(f,i);
    readln(f,i);
    readln(f,i);
    if i = 'COLOR' then
     okansi := true
    else
     okansi := false;
    readln(f,thisuser.sl);
    thisuser.pagelen := 25;
    thisuser.linelen := 80;
    close (f);
  end else begin
    writeln('Parameter file not found.');
    halt;
  end;
  hangup:=false;
  timeon:=timer;
 end;
 if not ((paramstr(1) = '-4') or (paramstr(1) = '-w') or (paramstr(1) = '-d') or
  (paramstr(1) = '-s')) then begin
  print ('6Error!!');
  halt;
 end;
end;

procedure return;
begin
  halt;
end;

procedure setup;
var
 error:word;
begin
 hangup := false;
 com_install(value(paramstr(3)),error);
 if error <> 0 then
  local := true;
 local := not(com_carrier);
 checkhangup;
 if (error = 1) or (error = 2) then
  hangup := true;
end;

procedure sline;
var
 ox,oy:byte;
 i :integer;

begin
 ox := wherex;
 oy := wherey;
 window (1,1,80,25);
 gotoxy (1,25);
 textbackground (5);
 textcolor (14);
 write ('ANSI: ');
 if okansi then
  write ('TRUE   ')
 else
  write ('FALSE  ');
 write ('LOCAL: ');
 if local then
  write ('TRUE   ')
 else
  write ('FALSE  ');
 write ('USER: ');
 if thisuser.name = '' then
  write ('UNKNOWN':20)
 else
  write (thisuser.name:20);
 write ('  ',date);
 write (' ',time);
 write ('       ');
 textcolor (7);
 textbackground (0);
 window (1,1,80,24);
 gotoxy (ox,oy);
end;
end.