Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/TPDOOR.ZIP/DOORIO.INC

Text File | 1986-10-15 | 15.0 KB | 418 lines

{----------------------------------------------------------------------}
{                                                                      }
{ Library:    DOORIO.INC                                               }
{ Purpose:    RBBS-PC DOORS Application Program I/O Support Library    }
{ Language:   Borland Turbo Pascal Version 3.00                        }
{                                                                      }
{ Author:     Richard L. Tremmel, GTE/Florida                          }
{             Genzral Service - Electronic Operations Support          }
{             610 Zack St. MC-20, Tampa, FL 33601  Voice: 813-224-7127 }
{             GTE Telenet: GTFL.EOS or contact me on the following:    }
{             SUNSHINE RBBS 813-887-3984 or TAMIAMI RBBS 813-793-2392  }
{                                                                      }
{ Notice:     This library is placed in the public domain and may be   }
{             freely used by anyone for any purpose.  When using this  }
{             code, please give credit to the original author and to   }
{             anyone who has subsequently improved or modified it.     }
{                                                                      }
{ History:    Version 1.00, 07/20/85 - Original by Richard L. Tremmel  }
{                                                                      }
{             Version 1.01, 07/23/85 - Modified by Richard L. Tremmel  }
{                           Added "SNOOP" flag to allow monitoring of  }
{                           user application.                          }
{                                                                      }
{ Narrative:  This Turbo Pascal include library provides I/O support   }
{             routines for use with the Remote Bulletin Board System   }
{             for the IBM Personal Computer (RBBS-PC) "Doors" function.}
{             Using these I/O routines and a program written in Turbo, }
{             the "Doors" function of RBBS-PC can be implemented with  }
{             complete system security.  The "CTTY CON" command is not }
{             required and no unsolicited input ever gets to the oper- }
{             ating system.                                            }
{                                                                      }
{             The I/O routines support carrier monitoring, user input  }
{             time-out, and integer and real number input with range   }
{             checking.  The I/O routines also support task switching  }
{             during input/output waits to free up the system when run-}
{             ning under MultiLink multitasking system by The Software }
{             Link.                                                    }
{                                                                      }
{             The following is an example "Door" batch file for a Turbo}
{             Pascal program called "TESTIO.COM" written using these   }
{             I/O routines.  The system console is not redirected to an}
{             async port which would make the system vulnerable.       }
{                                                                      }
{                 ECHO OFF                                             }
{                 TESTIO                                               }
{                 ECHO RETURNING TO RBBS-PC, WAIT... >COM1:            }
{                 RBBS                                                 }
{                                                                      }
{---------------------------- (continued) -----------------------------}
{.PA}
{----------------------------------------------------------------------}
{                                                                      }
{ Required:   The DOORIO.INC library requires the following type       }
{             definition:                                              }
{                                                                      }
{                 LINETYPE : string[nnn] where 'nnn' is the max length }
{                                        of any string input or output }
{                                                                      }
{             The DOORIO.INC library requires the following variables  }
{             or constants to be defined:                              }
{                                                                      }
{                 DEBUG     true  = local console program testing      }
{                           false = use async communications ports     }
{                                                                      }
{                 SNOOP     true  = copy async output to console       }
{                           false = all output to async port only      }
{                                                                      }
{                 MLINK     true  = program is running under MultiLink }
{                                   and should task switch during input}
{                                   and output waits.                  }
{                           false = program is NOT running under the   }
{                                   MultiLink multi-tasking system     }
{                                                                      }
{                 CARRIER   true  = abort program on loss of carrier   }
{                           false = ignore carrier condition           }
{                                                                      }
{                 ABORTABLE true  = allow ^C input to abort program    }
{                           false = disable special ^C processing      }
{                                                                      }
{                 PORTN     : integer (async port number to use)       }
{                                                                      }
{                 TIMELIMIT : integer (input time-out in seconds)      }
{                                                                      }
{----------------------------------------------------------------------}

const
      COM_CD_MASK                       = $80;           {carrier pres }
      COM_DA_MASK                       = $01;           {data avail.  }
      COM_TE_MASK                       = $20;           {xmit empty   }
      COM_RESET_MASK                    = $04;           {reset modem  }
      COM_ENABLE_MASK                   = $01;           {enable modem }
      COM_DBR : array [1..2] of integer = ($03F8,$02F8); {data buffer  }
      COM_MCR : array [1..2] of integer = ($03FC,$02FC); {modem control}
      COM_LSR : array [1..2] of integer = ($03FD,$02FD); {line status  }
      COM_MSR : array [1..2] of integer = ($03FE,$02FE); {modem status }

{$R+}         {Enable range checking                                   }
{$V+}         {Enable var-parameter type checking                      }
{.PA}
{This procedure calls MultiLink and requests a task switch to free up  }
{the system during input/output waits if MLINK is set to true.         }

procedure TASKSWITCH;

begin {TASKSWITCH}
  if MLINK and not DEBUG
    then
      inline($B4/$02/ {MOV AH,2 ;request a task switch}
             $CD/$7F) {INT 7FH  ;call MultiLink       }
end; {TASKSWITCH}





{This function returns the system timer value as a real number.  The   }
{system timer counts at a rate of 18.2065 counts per second.           }

function SYSTTIME : real;

const
    WORD_FACTOR = 65536.00;

var
    LOW, HIGH   : real;                           {temporary variable  }
    TIMER_LOW   : integer absolute $0000 : $046C; {timer low  word     }
    TIMER_HIGH  : integer absolute $0000 : $046E; {timer high word     }

begin {SYSTTIME}
  if TIMER_LOW < 0
    then
      LOW := TIMER_LOW + WORD_FACTOR
    else
      LOW := TIMER_LOW;
  if TIMER_HIGH < 0
    then
      HIGH := TIMER_HIGH + WORD_FACTOR
    else
      HIGH := TIMER_HIGH;
  SYSTTIME := HIGH * WORD_FACTOR + LOW
end; {SYSTTIME}
{.PA}
{This procedure checks async port number PORTN for the presence of     }
{carrier if CARRIER checking is set to true.  If carrier is not present}
{and is not restored within approximately one second, the program is   }
{aborted.                                                              }

procedure CC;

begin {CC}
  if CARRIER
    then
      if (port[COM_MSR[PORTN]] and COM_CD_MASK) = 0
        then
          begin
            delay(1000);
            if (port[COM_MSR[PORTN]] and COM_CD_MASK) = 0
              then
                halt; {lost carrier}
          end
end; {CC}





{This function returns the character waiting status of async port      }
{number PORTN.  True indicates that a character is waiting to be input.}

function CIS : boolean;

begin {CIS}
  if DEBUG
    then
      CIS := keypressed
    else
      begin
        CC;
        CIS := (port[COM_LSR[PORTN]] and COM_DA_MASK) > 0
      end
end; {CIS}
{.PA}
{This procedure outputs character CH to async port number PORTN.  If   }
{CARRIER is true it will verify that carrier is still present first.   }

procedure CO(CH:char);

begin {CO}
  if DEBUG or SNOOP
    then
      write(trm,CH);
  if not DEBUG
    then
      begin
        CC;
        while (port[COM_LSR[PORTN]] and COM_TE_MASK) = 0 do
          TASKSWITCH;
        port[COM_DBR[PORTN]] := byte(ord(CH))
      end
end; {CO}





{This procedure outputs a LINETYPE string LN to async port number PORTN}

procedure COL(LN:LINETYPE);

var
    I : integer;

begin {COL}
  for I := 1 to length(LN) do
    CO(LN[I])
end; {COL}





{This procedure outputs a LINETYPE string LN to async port number PORTN }
{followed by a carriage return, line feed.                              }

procedure COLN(LN:LINETYPE);

begin {COLN}
  COL (LN+^M+^J)
end; {COLN}
{.PA}
{This procedure inputs character CH from async port number PORTN with  }
{optional input time-out.  TIMELIMIT is expressed in seconds and if it }
{is zero no time-out will occur.  It will also verify that carrier is  }
{still present if CARRIER is set to true.  If ABORTABLE is set to true }
{and a control-C is input, this procedure will abort the program.      }

procedure CI(var CH:char);

const
      TICS_PER_SECOND                   = 18.2065;       {system clock }
      COM_DA_MASK                       = $01;           {receiver data}
      COM_DBR : array [1..2] of integer = ($03F8,$02F8); {data buffer  }
      COM_LSR : array [1..2] of integer = ($03FD,$02FD); {line status  }

var
    STOP : boolean;
    STOPTIME : real;

begin {CI}
  STOP := false;
  STOPTIME := SYSTTIME + TIMELIMIT * TICS_PER_SECOND;
  while not STOP do
    begin
      if (SYSTTIME>STOPTIME) and (TIMELIMIT<>0)
        then
          begin
            COLN(^G+' INPUT TIMEOUT!');
            halt
          end;
      if CIS
        then
          begin
            if DEBUG
              then
                read(kbd,CH)
              else
                CH := chr(port[COM_DBR[PORTN]]);
            STOP := true
          end
        else
          TASKSWITCH
    end; {while}
if ABORTABLE and (chr(ord(CH) and $7F) = ^C)
    then
      begin
        COLN(^G+'^C ABORTED BY USER');
        halt
      end
end; {CI}
{.PA}
{This procedure inputs a LINETYPE string LN from async port number     }
{PORTN with echo and optional time-out.  The TIMELIMIT is in seconds   }
{and if it is zero no time-out will occur.  It will also verify that   }
{carrier is still present if CARRIER is set to true.  If ABORTABLE is  }
{set to true and a control-C is input, this procedure will abort the   }
{program.  This procedure processes a control-H as a destructive back- }
{space and a control-X as cancel and reenter.                          }

procedure CILN(var LN:LINETYPE);

var
    I : integer;
    CH : char;

begin {CILN}
  LN := '';
  repeat
    CI(CH);
    case CH of
      ^H : begin
             if length(LN) > 0
               then
                 COL (^H+' '+^H);
             LN := copy(LN,1,length(LN)-1)
           end;
      ^M : CO(CH);
      ^J : ;
      ^X : begin
             COLN('^X');
             COL ('INPUT CANCELLED, REENTER: ');
             LN := ''
           end;
    else
      begin
        CO(CH);
        LN := LN+CH
      end
    end {case}
  until CH = ^M;
  CO(^J)
end; {CILN}
{.PA}
{This procedure will output the LINETYPE string PROMPT as an input     }
{prompt and input the real number NUMBER with optional range checking. }
{if LOW=0 and HIGH=0 then no range checking will be performed.  Input  }
{processing is the same as for procedure CILN.                         }

procedure CIREAL(PROMPT:LINETYPE; LOW,HIGH:real; var NUMBER:real);

  function LEFTJ(N:real) : LINETYPE; {real to left-justified string}

  var
      TEMP : LINETYPE;

  begin {LEFTJ}
    str(N,TEMP);
    LEFTJ := TEMP
  end; {LEFTJ}

var
    LN : LINETYPE;
    TEST : integer;

begin {CIREAL}
  COL (PROMPT);
  CILN(LN);
  val(LN,NUMBER,TEST);
  if (length(LN)=0) or (TEST<>0)
    then
      begin
        COLN(^G+'Error: Non-numeric value entered, try again.');
        COLN('');
        CIREAL(PROMPT,LOW,HIGH,NUMBER)
      end;
  if (LOW=0) and (HIGH=0)
    then
    else
      if (NUMBER<LOW) or ((NUMBER>HIGH) and (HIGH<>0))
        then
          begin
            COL (^G+'Error: Expected a number ');
            if NUMBER<LOW
              then
                COLN('greater than or equal to '+LEFTJ(LOW))
              else
                COLN('from '+LEFTJ(LOW)+' to '+LEFTJ(HIGH));
            COLN('');
            CIREAL(PROMPT,LOW,HIGH,NUMBER)
          end
end; {CIREAL}
{.PA}
{This procedure will output the LINETYPE string PROMPT as an input     }
{prompt and input the integer NUMBER with optional range checking.     }
{if HIGH=0 then no high range checking will be performed.  Input       }
{processing is the same as for procedure CILN.                         }

procedure CIINT(PROMPT:LINETYPE; LOW,HIGH:integer; var NUMBER:integer);

  function LEFTJ(N:integer) : LINETYPE; {int to left-justified string  }

  var
      TEMP : LINETYPE;

  begin {LEFTJ}
    str(N,TEMP);
    LEFTJ := TEMP
  end; {LEFTJ}

var
    R : real;

begin {CIINT}
  CIREAL(PROMPT,0,0,R);
  if R > maxint
    then
      begin
        COLN(^G+'Error: Expected an integer less than 32768');
        COLN('');
        CIINT(PROMPT,LOW,HIGH,NUMBER);
        R := LOW
      end;
  if (trunc(R)<>R) or (R<LOW) or ((R>HIGH) and (HIGH<>0))
    then
      begin
        COL (^G+'Error: Expected an integer ');
        if (trunc(R)<>R) or (R<LOW)
          then
            COLN('greater than or equal to '+LEFTJ(LOW))
          else
            COLN('from '+LEFTJ(LOW)+' to '+LEFTJ(HIGH));
        COLN('');
        CIINT(PROMPT,LOW,HIGH,NUMBER);
        R := LOW
      end;
  NUMBER := trunc(R)
end; {CIINT}