Power-Programmierung/CD1.mdf/pascal/library/dos/boi/units/iolib.pas

Pascal/Delphi Source File | 1990-12-12 | 15.7 KB | 548 lines

{$D-}
{$S-}
{$V-}

Unit IOLib;
{ Part of BBS Onliner Interface }
{ Copyright (C) 1990 Andrew J. Mead
  All Rights Reserved. }

{ BBS Onliner Interface contains
  Async     - low-level serial port communications interrupt handler
  BOIDecl   - BOI standard declarations
  IOLib     - standard console and port communications routines
  IOSupp    - extended character code processing for IOLib-ReadPortKey
  GetCmBBS  - command line parser
  Support   - common library functions and procedures }

{ Original version 7/1/90
  Original release version 1.0 beta 9/5/90
  Version  1.01  9/19/90 /Q quiet local mode switch added
  Version  1.01b 9/20/90 realname usage added, /A Remote Access defined
  Version  1.02  9/22/90 RA access removed, /Q switch fixed
  Version  1.03  9/23/90 /A play it Again switch added
  Version  1.10  9/24/90 /2, /F, /M, /H, /5, /6 switches added
  Version  1.11  9/29/90 beta version of /B locked baud rate
  Version  1.12 10/ 1/90 /P switch added
  Version  1.13 10/10/90 /N switch added
  Version  1.14 10/22/90 /B switch fixed, carrier dectect routines added
  Version  1.15 10/25/90 internal reorginizations, /K added
  Version  1.16 11/ 9/90 /K fixed, F-9 abort added.
  Version  1.17 12/ 1/90 internal reorginizations.
  Version  1.17b12/ 5/90 /P fixed, /O implemented
  Version  1.18 12/ 9/90 /O,/P verified /1,/3 implemented.
  Version  1.20 12/10/90 Initial Public Release.

}

INTERFACE

Uses
  Dos;

{ Standard Functions }

  Function MIN(a,b : word) : word;
  Function MAX(a,b : word) : word;

  {* Internal timing *}
  Procedure TIMERSET(var basetime : longint); { initialize timer value }
  Function GETTIMER(  {boolean}             { true if val seconds has passed }
      var basetime : longint;               { starting time }
      val          : word)                  { number of seconds }
      : boolean;

  {* file validation *}
  Function EXIST(thisfile : pathstr) : boolean;
  Function VALID(thisfile : pathstr) : boolean;

{ Memory Function }
  Function KEYPRESSED : Boolean;   { RAM - check keyboard buffer }

{ BIOS Functions }
  Function READKEY : char;         { BIOS - get key from keyboard buffer }
  Function WHEREX : byte;          { BIOS - get current cursor x position }
  Function WHEREY : byte;          { BIOS - get current cursor y position }
  Procedure DELAY(ms : Word);      { BIOS - CPU delay, 993 = 1 second }

{ ANSI Functions }
  { Input/Output string procedures }
  Procedure SENDSTRING(            { send string to output }
      outstr : string;             { string to output }
      docr : boolean);             { send CR/LF indicator }
  Function INTSTR( { returns a string of the input integer }
      val : longint;               { value to convert }
      isize : byte) : string;      { padded size of the string }
  Function REALSTR({ returns a string of the input real value }
      rval  : real;                { value to convert }
      rsize,                       { padded size of the string }
      rdec  : byte) : string;      { number of decimal places in string }
  Function PADSTR( { returns a right justified string }
      pstr : string;               { string to right justify }
      psize : byte) : string;      { size of string }
  Procedure GETSTRING(var gstr : string);  { all input chars upto next CR }

  { Housecleaning procedures }
  Procedure SETPORT;               { Initialize Async Communications }
  Procedure ENDPORT;               { Terminate Async Communications }

  { Positional/Attribute Functions }
  Procedure GOTOPORTXY(x,y : byte);  { Position cursor at given coordinates }
  Procedure PORTCOLOR(  { if docolor then set acolor else set bcolor }
      acolor,                      { color text attributes }
      bcolor : byte);              { monochrome text attributes }
  Procedure TEXTPORTCOLOR(color : byte);  { set text attributes }
  Procedure PORTBACKGROUND(color: byte);  { set background attributes }
  Procedure CLRPORTSCR;            { clear current window }
  Procedure CLRPORTEOL;            { clear current line to End Of Line }
  Procedure PORTWINDOW(x1,y1,x2,y2 : byte);  { Set display Window }
  Procedure PORTCOLUMNONE;         { put cursor in column one on current line }

  { Basic Input function }
  Function READPORTKEY : char;     { get input character }
  Function PORTKEYPRESSED : boolean; { character ready for processing }

  { reset function }
  Procedure CLEARBUFFERS;          { clear keyboard and port input buffers }

  { Advanced positional group }
  Procedure SETPORTXY;             { save current cursor position }
  Procedure RESETPORTXY;           { restore saved cursor position }

  { Timeout procedure }
  Function LEFTTIME : integer;     { remaing player time in minutes }
  Procedure DOTIMEOUT(ringbell : boolean); { exit program due to inactivity }

IMPLEMENTATION

Uses
  boidecl,
  iosupp,
  Async;

Const
  null  = #0;
  bell  = #7;
  esc   = #27;
  f10   = #$44; {scan code}
  basex : byte = 1;
  basey : byte = 1;
  tempx : byte = 1;
  tempy : byte = 1;
  endx  : byte = 24;
  endy  : byte = 80;

Var
  regs        : registers;
  textattr    : word;
  workstr     : string;

Function MIN(a,b : word) : word;
  begin {* fMin *}
    if a < b then Min := a else Min := b
  end;  {* fMin *}

Function MAX(a,b : word) : word;
  begin {* fMax *}
    if a > b then Max := a else Max := b
  end;  {* fMax *}

Procedure TIMERSET(var basetime : longint);
  begin {* TimerSet *}
    move(memw[$40:$6C],basetime,4)
  end;  {* TimerSet *}

Function GETTIMER(var basetime : longint; val : word) : boolean;
  var thistime : longint;

  begin {* GetTimer *}
    move(memw[$40:$6C],thistime,4);
    GetTimer := trunc((thistime - basetime) / 18.2) > val;
  end;  {* GetTimer *}

Function EXIST(thisfile : pathstr) : boolean;
  var
    afile : file;
    iocode : word;

  begin {* fExist *}
    assign(afile,thisfile);
    {$I-}
    reset(afile);
    {$I+}
    iocode := ioresult;
    Exist := (iocode = 0);
    if iocode = 0 then close(afile);
  end;  {* fExist *}

Function VALID(thisfile : pathstr) : boolean;
  Var
    afile : file;
    check : boolean;
    iocode : word;

  begin {* fValid *}
    if not Exist(thisfile) then
      begin
        assign(afile,thisfile);
        {$I-}
        rewrite(afile);
        close(afile);
        erase(afile);
        {$I+}
        iocode := ioresult;
        Valid := (iocode = 0)
      end
    else Valid := true
  end;  {* fValid *}


Procedure DELAY(MS: Word);
  begin {* Delay *}
    with regs do
      begin
        ah := $86;
        move(ms,cx,2);
        Intr($15,regs)
      end
  end;  {* Delay *}

Function KEYPRESSED : Boolean;
  begin {* KeyPressed *}
    Keypressed := MemW[$0040:$001C] <> MemW[$0040:$001A]
  end;  {* KeyPressed *}


Function READKEY : char;
  var key : char;

  begin {* fReadKey *}
    setfunction := false;
    with regs do
      begin
        repeat                   { wait until keypressed }
          begin
            ah := $01;           { check to see if keyboard buffer is empty }
            Intr($16,regs)
          end
        until flags and fzero = 0;
        ah := $00;               { get next keycode from keyboard buffer }
        Intr($16,regs);
        move(al,key,1);
        if key = null then       { if local keyboard has pressed a function }
          begin                  { key, replace the #0 value with the scan  }
            setfunction := true; { code of the key pressed. }
            move(ah,key,1)
          end;
        ReadKey := key
      end
  end;  {* fReadKey *}

Function WHEREX : byte;
  begin {* fWhereX *}
    with regs do
      begin
        ah := $03;
        bh := $00;
        Intr($10,regs);
        WhereX := dl + 2 - baseX
      end
  end;  {* fWhereX *}

Function WHEREY : byte;
  begin {* fWhereY *}
    with regs do
      begin
        ah := $03;
        bh := $00;
        Intr($10,regs);
        WhereY := dh + 2 - baseY
      end
  end;  {* fWhereY *}


Procedure SENDSTRING(outstr : string;docr : boolean);
  var
    sloop : byte;

  begin {* SendString *}
    if not dolocal then
      begin
        for sloop := 1 to length(outstr) do SendChar(outstr[sloop]);
        if docr then
          begin
            SendChar(char($0D));       { send CR }
            SendChar(char($0A))        { send LF }
          end
      end;
    if dolocal or doecho then
      begin
        if doquiet then for sloop := length(outstr) downto 1 do if outstr[sloop] = bell then delete(outstr,sloop,1);
        write(outstr);
        if docr then writeln
      end
  end;  {* SendString *}

Function INTSTR(val : longint;isize : byte) : string;
  var
    ist : string;

  begin {* fIntStr *}
    Str(val:isize,ist);
    IntStr := ist
  end;  {* fIntStr *}

Function REALSTR(rval : real; rsize,rdec : byte) : string;
  var
    ist : string;

  begin {* fRealStr *}
    Str(rval:rsize:rdec,ist);
    RealStr := ist
  end;  {* fRealStr *}

Function PADSTR(pstr : string; psize : byte) : string;
  var
    tstr : string;

  begin {* fPadStr *}
    if length(pstr) > psize then PadStr := pstr
    else
      begin
        fillchar(tstr[1],psize,32);
        tstr[0] := chr(psize);
        move(pstr[1],tstr[psize - length(pstr) + 1],length(pstr));
        PadStr := tstr
      end
  end;  {* fPadStr *}

Function READPORTKEY : char;
  var
    rkey     : char;
    timebase : longint;

  begin {* fReadPortKey *}
    if dolocal then
      begin
        rkey := ReadKey;
        if setfunction then CheckSecondKey(rkey)
      end
    else
      begin
        TimerSet(timebase);
        repeat until CharReady or KeyPressed or GetTimer(timebase,60) or not Carrier;
        if not (KeyPressed or CharReady) and Carrier and GetTimer(timebase,60) then
          begin
            SendString(bell,false);
            repeat until charready or keypressed or GetTimer(timebase,120) or not Carrier
          end;
        if not Carrier then DoTimeOut(false)
        else if not (KeyPressed or CharReady) and GetTimer(timebase,120) then DoTimeOut(true)
        else if CharReady then rkey := ReadBuffer
        else if KeyPressed then
          begin
            rkey := ReadKey;
            if setfunction then CheckSecondKey(rkey)
          end
      end;
    ReadPortKey := rkey
  end;  {* fReadPortKey *}

Function PORTKEYPRESSED : boolean;
  begin {* fPortKeyPressed *}
    if dolocal then PortKeyPressed := KeyPressed
    else PortKeyPressed := KeyPressed or CharReady
  end;  {* fPortKeyPressed *}

Procedure CLEARBUFFERS;
  var cbchar : char;

  begin {* ClearBuffers *}
    while keypressed do cbchar := ReadKey;
    if not dolocal then ClearInBuffer
  end;  {* ClearBuffers *}

Procedure GETSTRING(var gstr : string);
  var
    gchar : char;

  begin {* GetString *}
    if dolocal then readln(gstr)
    else
      begin
        gstr := '';
        repeat
          begin
            gchar := ReadPortKey;
            if gchar in [#32..#126] then
              begin
                gstr := gstr + gchar;
                SendString(gchar,false)
              end
            else if (gchar = #8) and (length(gstr) > 0) then
              begin
                delete(gstr,length(gstr),1);
                SendString(gchar,false)
              end
          end
        until gchar = #13;
        SendString('',true)
      end
  end;  {* GetString *}

Procedure SETPORT;
  begin {* SetPort *}
    if not dolocal then IntInit
  end;  {* SetPort *}

Procedure ENDPORT;
  begin {* EndPort *}
    if not dolocal then IntEnd
  end;  {* EndPort *}

Procedure GOTOPORTXY(x,y : byte);
  begin {* GotoPortXY *}
    x := x + basex - 1;
    y := y + basey - 1;
    SendString(esc+'['+IntStr(y,0)+';'+IntStr(x,0)+'H',false)
  end;  {* GotoPortXY *}

Procedure SETCOLOR(color : byte);
  begin {* SetColor *}
    if color > 150 then {* Blink + High Intensity *}
      begin
        SendString(esc+'[01;05;'+IntStr(color-150,0)+'m',false);
        textattr := 0
      end
    else if color > 100 then {* Blink + Low Intensity *}
      begin
        SendString(esc+'[00;05;'+IntStr(color-100,0)+'m',false);
        textattr := 0
      end
    else if color > 50 then {* High Intesity *}
      begin
        SendString(esc+'[00;01;'+IntStr(color-50,0)+'m',false);
        textattr := 0
      end
    else {* Low Intesity *}
      begin
        SendString(esc+'[00;'+IntStr(color,0)+'m',false);
        textattr := 0
      end
  end;  {* SetColor *}

Procedure PORTCOLOR(acolor, bcolor : byte);
  begin {* PortColor *}
    if docolor then SetColor(acolor) else SetColor(bcolor)
  end;  {* PortColor *}

Procedure TEXTPORTCOLOR(color : byte);
  begin {* TextPortColor *}
    SetColor(color)
  end;  {* TextPortColor *}

Procedure PORTBACKGROUND(color: byte);
  begin {* PortBackground *}
    if color in [30..37] then SendString(esc+'[00;'+IntStr(color+10,0)+'m',false)
  end;  {* PortBackground *}

Procedure CLRPORTSCR;
  var
    cloop : byte;

  Procedure GOTOSTATUSLINE;
    begin {* ClrPortScr,GotoStatusLine *}
      with regs do
        begin
          ah := $02;       { use BIOS gotoxy function }
          bh := $00;       { use current video screen }
          dh := 24;        { goto line 24 (0-24) }
          dl := 0;         { goto column 0 (0-79) }
          Intr($10,regs)
        end
    end;  {* ClrPortScr,GotoStatusLine *}

  begin {* ClrPortScr *}
    if basey = 1 then
      begin
        SendString(esc+'[2J',false);
        if usename and not dolocal then
          begin
            SetPortXY;
            GotoStatusLine;
            workstr := 'Current Player : ' + username;
            if usereal then workstr := workstr + ', ' + realname;
            if length(workstr) > 79 then workstr[0] := chr(79);
            write(workstr);
            ResetPortXY
          end
      end
    else for cloop := endy - basey + 1 downto 1 do
      begin
        GotoPortXY(1,cloop);
        if cloop < 24 then SendString(esc+'[K',false)
        else SendString('                                                                             ',false)
      end
  end;  {* ClrPortScr *}

Procedure CLRPORTEOL;
  begin {* ClrPortEOL *}
    SendString(esc+'[K',false)
  end;  {* ClrPortEOL *}

Procedure PORTWINDOW(x1,y1,x2,y2 : byte);
  begin {* PortWindow *}
    basex := x1;
    basey := y1;
    endx := Min(80,x2);
    endy := Min(24,y2);
    GotoPortXY(1,1);
  end;  {* PortWindow *}

Procedure PORTCOLUMNONE;
  begin {* PortColumnOne *}
    SendString(esc+'[79D',false)
  end;  {* PortColumnOne *}

Procedure SETPORTXY;
  begin {* SetPortXY *}
    SendString(esc+'[s',false);
    if doecho then
      begin
        TempX := WhereX;
        TempY := WhereY
      end
  end;  {* SetPortXY *}

Procedure RESETPORTXY;
  Procedure GOTOXY(x,y : byte);
    begin {* GotoXY *}
      x := x + basex - 1;
      y := y + basey - 1;
      write(esc,'[',y:0,';',x:0,'H')
    end;  {* GotoXY *}

  begin {* ResetPortXY *}
    SendString(esc+'[u',false);
    if doecho then gotoxy(TempX,TempY)
  end;  {* ResetPortXY *}

Procedure DOTIMEOUT(ringbell : boolean);
  begin {* DoTimeOut *}
    if ringbell then SendString(bell,true);
    write(esc,'[2J');
    write('Program timeout.  ');
    if Carrier then writeln('No input for 2 minutes.') else writeln('Carrier Dropped.');
    writeln('Returning control to BBS.');
    EndPort;
    halt
  end;  {* DoTimeOut *}

Function LEFTTIME : integer;
  begin {* fLeftTime *}
    GetTime(thishour,thismin,second,hunsec);
    if (hour = 23) and (thishour = 0) then thishour := 24;
    LeftTime := timeleft + minute-thismin - 60*(thishour-hour)
  end;  {* fLeftTime *}

end. Unit