ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/UTILITY/SYSTEM/GETTIME.ZIP/COMUNIT.PAS

Pascal/Delphi Source File | 1990-12-10 | 8.9 KB | 409 lines

unit comunit;
interface
type baud=(B300,B1200,B2400);
     bits=5..8;
     stopbits=1..2;
     parity=(no_par, odd_par, even_par);
     comport = 1..2;
     Qlength = 100..32000;

var
  echo_on: boolean;
  display_error: boolean;
  status_change_proc: procedure;
  break_proc: procedure;
  getln_timeout: real;

procedure initcom (cport: comport; Qlen: Qlength;
   baudx: baud; bitsx: bits; stopx: stopbits; parx: parity);
procedure resetcom(baudx: baud; bitsx: bits; stopx: stopbits; parx: parity);
procedure end_com;
function dcd: boolean;
function ri: boolean;
function dsr: boolean;
function cts: boolean;
function ch_in_ready: boolean;
function com_error: byte;
function line_status: byte;
procedure hangup;
function get_com : char;
procedure put_com (c: char);
procedure send(s: string);
procedure sendln(s: string);
procedure show_status;
function getln: string;
procedure send_break;
procedure do_nothing;

implementation
uses queues, stopwatch, crt, dos, hexdump;

var
  in_q, out_q: queue;
  dcdstat, ristat, dsrstat, ctsstat: boolean;
  com_ctl_byte: byte;
  com_error_byte: byte;
  x,y: byte;
  regs: registers;
  portbase, baud_port, tran_reg, rcv_reg,
  baud_div, int_enable_reg, int_id_reg,
  line_ctl_reg, modem_ctl_reg,
  line_stat_reg, modem_stat_reg: word;
  sysintnr: 0..4;
  ExitSave: pointer;
  old_int_vec: pointer;
  break_occurred, status_changed: boolean;
  old_int_ctl_reg: byte;

procedure DisInt; inline($FA);

procedure EnaInt; inline($FB);

function line_status: byte;
begin
  line_status := port[line_stat_reg];
end;

procedure set_status_bits;
var b: byte;
begin
   b := port[modem_stat_reg];
   dcdstat := (b and $80) <> 0;
   ristat := (b and $40) <> 0;
   dsrstat := (b and $20) <> 0;
   ctsstat := (b and $10) <> 0;
end;

procedure add_str_to_in_Q (s: string);
var i: byte;
    ch: char;
begin
  for i := 1 to length(s) do insertQ(s[i], in_Q);
  insertQ(#13, in_Q);
  insertq(#10, in_Q);
end;

procedure int_hand(ES, BP: word);
interrupt;

var
  int_id, int_type, b: byte ;
  ch: char;
begin
  int_id := port[int_id_reg];
  while (int_id and $01) = $00 do begin
    case int_id and $06 of
      $06: {break_cond} begin
        b := port[line_stat_reg];
        if display_error then begin
          if (b and $80)<>0 then
             add_str_to_in_Q('Timeout error occurred.');
          if (b and $10)<>0 then
             add_str_to_in_Q('Break received');
          if (b and $08)<>0 then
             add_str_to_in_Q('Framing error occurred.');
          if (b and $04)<>0 then
             add_str_to_in_Q('Parity error occurred.');
          if (b and $02)<>0 then
             add_str_to_in_Q('Overrun error occurred.');
        end
        else begin
          if (b and $10)<>0 then
             break_occurred := true
          else
             com_error_byte := b;
        end;
      end;
      $04: begin {receive ready}
        ch := char (port[rcv_reg] );
        insertQ (ch, in_q);
        end;
      $02: begin {send ready}
        remove (ch, out_q);
        port[tran_reg] := byte(ch);
        if empty (out_q) then begin
           port[int_enable_reg]:=port[int_enable_reg] and $0D;
           end;
        end;
      $00: begin {status change}
        set_status_bits;
        status_changed := true;
        end;
    end;
    int_id := port[int_id_reg];
  end;
  port[$20] := $20;
end;


procedure initcom (cport: comport; Qlen: Qlength;
   baudx: baud; bitsx: bits; stopx: stopbits; parx: parity);
   var ch: char;
begin

  if sysintnr <> 0 then
     end_com;

  if cport = 1 then
     portbase := memw[$40:$00]
  else
     portbase := memw[$40:$02];
  if portbase = $03f8 then
    sysintnr := 4
  else if portbase = $02f8 then
    sysintnr := 3
  else begin
    writeln ('ERROR: invalid port base');
    halt;
  end;
  baud_port := portbase;
  tran_reg := portbase;
  rcv_reg := portbase;
  baud_div := portbase;
  int_enable_reg := portbase + 1;
  int_id_reg := portbase + 2;
  line_ctl_reg := portbase + 3;
  modem_ctl_reg := portbase + 4;
  line_stat_reg := portbase + 5;
  modem_stat_reg := portbase + 6;

  resetcom(baudx, bitsx, stopx, parx);

  initQ(in_Q, Qlen);
  initQ(out_Q, Qlen);
  DisInt;
  {clear out any pending read or write}
  if (port[line_stat_reg] and 1) <> 0 then begin
     ch := char(port[rcv_reg]);
  end;
  if (port[line_stat_reg] and $20) <> 0 then
     port[tran_reg] := 0;
  old_int_ctl_reg := port[$21];
  if sysintnr = 3 then begin
     GetIntVec ($0B, old_int_vec);
     SetIntVec ($0B, @int_hand);
     port[$21] := port[$21] and $F7;
  end
  else begin
     GetIntVec ($0C, old_int_vec);
     SetIntVec ($0c, @int_hand);
     port[$21] := port[$21] and $EF;
  end;
  port[modem_ctl_reg] := $0B;
  port[int_enable_reg] := $0D;
  set_status_bits;
  EnaInt;
  status_change_proc;
end;

procedure resetcom(baudx: baud; bitsx: bits; stopx: stopbits; parx: parity);
const bauddiv: array[baud] of word = ($0180, $0060, $0030);
      bitsA: array[bits] of byte = (0,1,2,3);
      stopA: array[stopbits] of byte = (0,4);
      parA: array[parity] of byte = (0,$08,$18);
var bdiv: word;
begin
  DisInt;
  port[line_ctl_reg]:=$80; { set baud rate };
  bdiv := bauddiv[baudx];
  port[baud_port] := lo(bdiv);
  port[baud_port + 1] := hi(bdiv);
  com_ctl_byte := bitsA[bitsx] or stopA[stopx] or parA[parx];
  port[line_ctl_reg]:=com_ctl_byte;
  EnaInt;
end;

procedure end_com;
begin
  if sysintnr <> 0 then begin
     DisInt;
     port[int_enable_reg] := 0;
     port[line_ctl_reg] := 3;
     port[$21] := old_int_ctl_reg;
     if sysintnr = 3 then begin
        SetIntVec ($0B, old_int_vec);
     end
     else begin
       SetIntVec ($0C, old_int_vec);
     end;
     sysintnr := 0;
     EnaInt;
     doneQ(in_Q);
     doneQ (out_Q);
     sysintnr := 0;
  end;
end;

{$F+}
procedure my_exit_proc;
begin
  ExitProc := ExitSave;
  end_com;
end;

procedure do_nothing;
begin
end;
{$F-}

function dcd: boolean;
begin
  dcd := dcdstat;
end;

function ri: boolean;
begin
  ri := ristat;
end;

function dsr: boolean;
begin
  dsr := dsrstat;
end;

function cts: boolean;
begin
  cts := ctsstat;
end;

function ch_in_ready: boolean;
begin
   if break_occurred then begin
      break_occurred := false;
      break_proc;
   end;
   if status_changed then begin
      status_changed := false;
      status_change_proc;
   end;
   ch_in_ready := not empty(in_q);
end;

function com_error: byte;
begin
  com_error := com_error_byte;
  com_error_byte := 0;
end;

procedure hangup;
var c: clock;
begin
  if dcd then begin
     startclock(c);
     port[modem_ctl_reg]:=$0A;
     repeat
     until (not dcd) or (stopclock(c)>15);
     if dcd then writeln ('ERROR: timeout on hangup')
     else port[modem_ctl_reg] := $0B;
  end;
end;

function get_com: char;
  var c: char;
begin
  DisInt;
  remove (c, in_q);
  EnaInt;
  get_com := c;
end;

procedure put_com (c: char);
var was_empty: boolean;
begin
  if echo_on then write (c);
  DisInt;
  was_empty := empty (out_Q);
  insertQ (c, out_Q);
  if was_empty then
     port[int_enable_reg] := port[int_enable_reg] or $02;
  EnaInt;
end;

procedure special_key;
var c1: char;
{procedure to handle special keys.  Currently it just bypasses any.}
begin
  c1 := readkey;
end;

procedure send(s: string);
var i: byte;
begin
  for i:=1 to length(s) do
     put_com(s[i]);
end;

procedure sendln(s: string);
begin
  send(s);
  put_com(#13);
  put_com(#10);
end;

function getln: string;
var s: string[80];
    b: byte;
    c: char;
    cl: clock;
begin
  s[0]:=#0;
  b:=0;
  startclock(cl);
  repeat
    if ch_in_ready then begin
      c := get_com;
      write(c);
      if c<>#13 then begin
        inc(b);
        s[b]:=c;
      end;
    end;
  until (c=#13) or (b=80) or (stopclock(cl)>getln_timeout);
  if c=#13 then begin
     repeat
     until ch_in_ready or (stopclock(cl)>getln_timeout);
     if ch_in_ready then begin
        c:= get_com;
        write(c)
     end;
  end;
  s[0]:=char(b);
  getln := s;
end;

procedure show_status;
  var x,y, oldattr: byte;
begin
  x := wherex; y := wherey;
  window(1,25,80,25);
  oldattr := textattr;
  textattr := ((textattr and $07) * 16) + (textattr and $70) div 16;
  ClrEol;
  write ('DCD: ', DCD:5, '   RI: ', ri:5, '   DSR: ', dsr:5,
     '   CTS: ', cts:5);
  window (1,1,80,24);
  gotoxy(x,y);
  textattr := oldattr;
end;

procedure send_break;
begin
  port[line_ctl_reg] := com_ctl_byte or $40;
  milliwait(100);
  port[line_ctl_reg] := com_ctl_byte;
end;



begin
  echo_on := false;
  display_error := false;
  com_error_byte := 0;
  sysintnr := 0;
  getln_timeout := 15;
  ExitSave := ExitProc;
  ExitProc := @my_exit_proc;
  status_change_proc := show_status;
  break_proc := do_nothing;
end.