Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/ECO30603.ZIP/ECO30603.LZH/ECOLIBBS/ECO_FOSL.PAS

Pascal/Delphi Source File | 1992-08-03 | 13.7 KB | 535 lines

{
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓·──                                              ──·▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓│                                                  │░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   ptd_fosl was conceived and written by            ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   floor naaijkens for                              ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   persistent thought dynamics, inc.                ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓                                                    ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   (c) 1991 by euro-online data communications      ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   all rights reserved.                             ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓                                                    ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   ptd_fosl wil interface between a fido opus       ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   seadog standard interface layer, and tp user.    ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓│                                                  │░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓·──                                              ──·░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
}
unit eco_fosl;
interface uses dos, crt;
var regs: registers;


  procedure fos_ansi_       (character : char);
  function  fos_atcmd_      (comport_  : byte;  command_: string): boolean;
  function  fos_avail_      (comport_  : byte): boolean;
  procedure fos_bios_       (character : char);
  function  fos_cd_         (comport_  : byte): boolean;
  function  fos_checkmodem_ (comport_  : byte): boolean;
  procedure fos_clear_regs_;
  procedure fos_close_      (comport_  : byte);
  procedure fos_dtr_        (comport_  : byte;  state: boolean);
  function  fos_empty_      (comport_  : byte): boolean;
  procedure fos_flow_       (comport_  : byte;  state: boolean);
  procedure fos_flush_      (comport_  : byte);
  function  fos_hangup_     (comport_  : byte): boolean;
  function  fos_init_       (comport_  : byte): boolean;
  procedure fos_kill_out_   (comport_  : byte);
  procedure fos_kill_in_    (comport_  : byte);
  function  fos_oktosend_   (comport_  : byte): boolean;
  procedure fos_parms_      (comport_  : byte;  baud: integer; databits: byte;
                                                parity: char;   stopbit: byte);
  function  fos_present_    (comport_  : byte): boolean;
  procedure fos_reboot_;
  function  fos_receive_    (comport_  : byte): char;
  procedure fos_string_     (comport_  : byte;  outstring: string);
  procedure fos_stringcrlf_ (comport_  : byte;  outstring: string);
  procedure fos_watchdog_   (comport_  : byte;  state: boolean);
  procedure fos_write_      (comport_  : byte;  character: char);
  function  fos_name_(comport: byte) : string;





implementation





  procedure fos_clear_regs_;
  begin
    fillchar(regs, sizeof(regs), 0);
  end;


  function fos_init_(comport_: byte): boolean;
  begin
    fos_clear_regs_;
    with regs do begin
      ah := 4; dx :=(comport_-1); intr($14, regs);
      if ax <> $1954 then begin
        writeln; writeln(' Fossil driver is not loaded.');
        fos_init_ := false;
      end else fos_init_ := true
    end;
  end;



  function fos_present_(comport_: byte): boolean;
  begin
    fos_clear_regs_;
    with regs do begin
      ah := 4; dx := (comport_-1); intr($14, regs);
      fos_present_ := (ax = $1954);
    end;
  end;




  procedure fos_close_(comport_: byte);
  begin
    fos_clear_regs_; fos_dtr_(comport_,false);
    with regs do begin
      ah := 5; dx := comport_ - 1; intr($14, regs);
    end;
  end;


  procedure fos_parms_(
    comport_: byte; baud: integer; databits: byte; parity: char;
    stopbit: byte
  );
  var
    code: integer;

  begin
    code := 0; fos_clear_regs_;
    case baud of
      0   : exit;
      100 : code := code + 000 + 00 + 00;
      150 : code := code + 000 + 00 + 32;
      300 : code := code + 000 + 64 + 00;
      600 : code := code + 000 + 64 + 32;
      1200: code := code + 128 + 00 + 00;
      2400: code := code + 128 + 00 + 32;
      4800: code := code + 128 + 64 + 00;
      9600: code := code + 128 + 64 + 32;
      19200: code := code + 000 + 00 + 00;
    end;

    case databits of
      5: code := code + 0 + 0;
      6: code := code + 0 + 1;
      7: code := code + 2 + 0;
      8: code := code + 2 + 1;
    end;

    case parity of
      'N','n': code := code + 00 + 0;
      'O','o': code := code + 00 + 8;
      'E','e': code := code + 16 + 8;
    end;

    case stopbit of
      1: code := code + 0;
      2: code := code + 4;
    end;

    with regs do begin
      ah := 0; al := code;
      dx :=(comport_-1);
      intr($14, regs);
    end;
  end;


  procedure fos_dtr_(comport_: byte; state: boolean);
  begin
    fos_clear_regs_;
    with regs do begin
      ah := 6; dx :=(comport_-1);
      case state of
        true  : al := 1;
        false : al := 0;
      end;
      intr($14, regs);
    end;
  end;


  function  fos_cd_(comport_: byte) : boolean;
  begin
    fos_clear_regs_;
    with regs do begin
      ah := 3; dx :=(comport_-1);
      intr($14, regs);
      fos_cd_ :=((al and 128) = 128);
    end;
  end;


  procedure fos_flow_(comport_: byte; state: boolean);
  begin
    fos_clear_regs_;
    with regs do begin
      ah := 15; dx := comport_-1;
      case state of
        true  : al := 255;
        false : al := 0;
      end;
      intr($14, regs);
    end;
  end;



  procedure fos_kill_out_(comport_: byte);
  begin
    fos_clear_regs_;
    with regs do begin
      ah := 9; dx := comport_-1;
      intr($14, regs);
    end;
  end;



  procedure fos_kill_in_(comport_: byte);
  begin
    fos_clear_regs_;
    with regs do begin
      ah := 10; dx := comport_-1;
      intr($14, regs);
    end;
  end;



  procedure fos_flush_(comport_: byte);
  begin
    fos_clear_regs_;
    with regs do begin
      ah := 8; dx := comport_-1;
      intr($14, regs);
    end;
  end;



  function  fos_avail_(comport_: byte): boolean;
  begin
    fos_clear_regs_;
    with regs do begin
      ah := 3; dx := comport_-1;
      intr($14, regs);
      fos_avail_ := ((ah and 1) = 1);
    end;
  end;



  function  fos_oktosend_(comport_: byte) : boolean;
  begin
    fos_clear_regs_;
    with regs do begin
      ah := 3; dx := comport_-1;
      intr($14, regs);
      fos_oktosend_ :=((ah and 32) = 32);
    end;
  end;




  function  fos_empty_(comport_: byte) : boolean;
  begin
    fos_clear_regs_;
    with regs do begin
      ah := 3; dx := comport_-1;
      intr($14, regs);
      fos_empty_ :=((ah and 64) = 64);
    end;
  end;



  procedure fos_write_(comport_: byte; character: char);
  begin
    fos_clear_regs_;
    with regs do begin
      ah := 1; dx := comport_-1;
      al := ord(character);
      intr($14, regs);
    end;
  end;



  procedure fos_string_(comport_: byte; outstring: string);
  var pos: byte;

  begin
    for pos := 1 to length(outstring) do fos_write_(comport_,outstring[pos]);
    outstring := '';
  end;



  procedure fos_stringcrlf_(comport_: byte; outstring: string);
  var pos: byte;
  begin
    for pos := 1 to length(outstring) do fos_write_(comport_,outstring[pos]);
    fos_write_(comport_,char(13)); fos_write_(comport_,char(10));
    outstring := '';
  end;



  procedure fos_bios_(character: char);
  begin
    fos_clear_regs_;
    with regs do begin
      ah := 21; al := ord(character); intr($14, regs)
    end;
  end;




  procedure fos_ansi_(character: char);
  begin
    fos_clear_regs_;
    with regs do begin
      ah := 2; dl := ord(character); intr($21, regs)
    end;
  end;


  procedure fos_watchdog_(comport_: byte; state: boolean);
  begin
    fos_clear_regs_;
    with regs do begin
      ah := 20; dx := comport_-1;
      case state of
        true  : al := 1;
        false : al := 0;
      end;
      intr($14, regs);
    end;
  end;



  function fos_receive_(comport_: byte) : char;
  begin
    fos_clear_regs_;
    with regs do
    begin
      ah := 2; dx := comport_-1;
      intr($14, regs);
      fos_receive_ := chr(al);
    end;
  end;


  function fos_hangup_(comport_: byte) : boolean;
  var
    tcount : integer;

  begin
    fos_dtr_(comport_,false); delay(600); fos_dtr_(comport_,true);
    if fos_cd_(comport_)=true then begin
      tcount := 1;
      repeat
        fos_string_(comport_,'+++'); delay(3000);
        fos_stringcrlf_(comport_,'ATH0'); delay(3000);
        if fos_cd_(comport_)=false then tcount := 3;
        inc(tcount);
      until tcount=4;
    end;
    if fos_cd_(comport_)=true then fos_hangup_ := false else fos_hangup_ := true;
  end;



  procedure fos_reboot_;
  begin
    fos_clear_regs_;
    with regs do begin
      ah := 23; al := 1;
      intr($14, regs);
    end;
  end;




  function fos_checkmodem_(comport_: byte) : boolean;
  var
    ch     :   char;
    result :   string[10];
    i,z    :   integer;

  begin
    fos_checkmodem_ := false;
    result := '';
    for z := 1 to 3 do begin
      delay(500); fos_write_(comport_,char(13));
      delay(1000); fos_stringcrlf_(comport_,'AT'); delay(1000);
      repeat
        if fos_avail_(comport_) then begin
          ch := fos_receive_(comport_); result := result+ch;
        end;
      until fos_avail_(1)=false;
      for i := 1 to length(result) do begin
        if copy(result,i,2)='OK' then begin
          fos_checkmodem_ := true; exit;
        end;
      end;
    end;
  end;



  function fos_atcmd_(comport_: byte; command_: string) : boolean;
  var
    ch     :   char;
    result :   string;
    i,z    :   integer;

  begin
    fos_atcmd_ := false; result := '';
    for z := 1 to 3 do begin
      delay(500); fos_write_(comport_,char(13));
      delay(1000); fos_stringcrlf_(comport_, command_); delay(1000);
      repeat
        if fos_avail_(comport_) then begin
          ch := fos_receive_(comport_); result := result + ch;
        end;
      until not fos_avail_(comport_);
      for i := 1 to length(result)-1 do begin
        if copy(result,i,2) = 'OK' then begin
          fos_atcmd_ := true; exit;
        end;
      end;
    end;
  end;




  function fos_name_(comport: byte) : string;
  { returns ascii description of fossil driver in use. }
  { returns empty string if no fossil was detected.    }
  type
    ary128 = array[1..128] of char;
    aryptr = ^ary128;
    fossil_info_record_type = record
      size      : word;    { size of the structure in bytes      }
      majver    : byte;    { major fossil driver spec            }
      minver    : byte;    { minor fossil driver spec            }
      ident     : aryptr;  { far pointer to ascii id string      }
      inbuffer  : word;    { size of the input buffer in bytes   }
      infree    : word;    { number of bytes left in buffer      }
      outbuffer : word;    { size of the output buffer in bytes  }
      outfree   : word;    { number of bytes left in the buffer  }
      width     : byte;    { width of screen on this adapter     }
      height    : byte;    { height of screen on this adapter    }
      baud      : byte     { actual baud rate, computer to modem }
    end;

  var
    r : registers;
    i, j : byte;
    f    : fossil_info_record_type;
    temp : string;

  begin
    j := pred(comport);
    repeat
      fillchar(f, sizeof(f), #0); fillchar(r, sizeof(r), #0);
      temp := ''; r.ah := $1b; r.cx :=  19; { size of fossil_info_record_type }
      r.dx := j; { com port } r.es := seg(f); r.di := ofs(f); intr($14,r);
      if r.ax = 19 then begin { looks as if fossil was detected? }
        i := 1;
        repeat
          if f.ident^[i] <> #0 then temp := temp + f.ident^[i]; inc(i)
        until (f.ident^[i] = #0) or (i = 128)
      end else inc(j)
    until (temp <> '') or (j > 4); { only check com1-com4 }
    fos_name_ := temp
  end; { fossil_name }



end.



(*

  procedure initport(baud : integer; parity : char; charlength,stopbits: byte);
  begin
    temp := '';
    case baud of
      19200 : temp := '000';
       9600 : temp := '111';
       4800 : temp := '110';
       2400 : temp := '101';
       1200 : temp := '100';
        300 : temp := '010';
    end;
    case upcase(parity) of
      'N' : temp := temp + '00';
      'E' : temp := temp + '11';
      'O' : temp := temp + '01';
    end;
    if stopbits = 1 then temp := temp + '0' else temp := temp + '1';
    case charlength of
      8 : temp := temp + '11';
    end;
    r.ah := $00; r.al := bin2dec(temp); r.dx := pred(comport); intr($14,r);
  end;



  procedure raisedtr;
  begin
    r.ah := $06; r.al := $01; r.dx := pred(comport); intr($14,r);
  end;



  procedure lowerdtr;
  begin
    r.ah := $06; r.al := $00; r.dx := pred(comport); intr($14,r);
  end;



  procedure purge_input;
  begin
    r.ah := $0a; r.dx := pred(comport); intr($14,r);
  end;



  function charinbuffer : boolean;
  begin
    r.ah := $0c; r.dx := pred(comport); intr($14,r);
    if r.ax = $ffff then charinbuffer := false else charinbuffer := true;
  end;

*)