Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/EMSI.ZIP/EMSI.PAS

Pascal/Delphi Source File | 1991-09-30 | 11.2 KB | 477 lines

(*
  Hope ya don't mind me responding via NetMail instead of
the Pascal echo but as you may have noticed the code takes 6 messages!  The
following code is "fairly" EMSI compatible (not sure if it's IEMSI compatinle
but it should be).
*)
{********* Part 1 of 6 ****************************************}

Uses
  DOS,CRT;

Type
  HexString = String[4];

Const
  FingerPrint          = '{EMSI}';
  System_Address       = '3:690/626.6';     { Your address }
  Password             = 'ABCD1234';        { Session password }
  Link_Codes           = '{8N1}';           { Modem setup }
  Compatibility_Codes  = '{ZMO}';           { Z-Modem }
  Mailer_Product_Code  = '{00}';
  Mailer_Name          = 'PM';
  Mailer_Version       = '1.00';
  Mailer_Serial_Number = '{Beta}';

  EMSI_INQ : String = '**EMSI_INQC816';
  EMSI_REQ : String = '**EMSI_REQA77E';
  EMSI_ACK : String = '**EMSI_ACKA490';
  EMSI_NAK : String = '**EMSI_NAKEEC3';

Var
  EMSI_DAT : String;            { NOTE : EMSI_DAT has no maximum length }
  Length_EMSI_DAT : HexString;  { Expressed in Hexidecimal }

  Packet : String;
  Rec_EMSI_DAT : String;        { EMSI_DAT sent by the answering system }
  Len_Rec_EMSI_DAT : Word;

  Len,
  CRC : HexString;

  R : Registers;
  C : Char;
  Loop,ComPort,TimeOut,Tries : Byte;
  Temp : String;

{****  String functions ****}

Function Up_Case(St : String) : String;
Begin
  For Loop := 1 to Length(St) do
    St[Loop] := Upcase(St[Loop]);

  Up_Case := St;
End;

{****  Mathematical Functions ****}

function Hex(i : Word) : HexString;
const
  hc : array[0..15] of Char = '0123456789ABCDEF';
var
  l, h : Byte;
begin
  l := Lo(i);
  h := Hi(i);
  Hex[0] := #4;          { Length of String = 4 }
  Hex[1] := hc[h shr 4];
  Hex[2] := hc[h and $F];
  Hex[3] := hc[l shr 4];
  Hex[4] := hc[l and $F];
end {Hex} ;

Function Power(Base,E : Byte) : Longint;
Begin
  Power := Round(Exp(E * Ln(Base) ));
End;

Function Hex2Dec(HexStr : String) : Longint;

{ Maximum hexidecimal number that can be handled is about 'FFFFFF' }
{ Do not start the hexidecimal number with a dollar sign '$'       }

Var
  I,HexBit : Byte;
  Temp : Longint;
  Code : integer;

Begin
  Temp := 0;
  For I := Length(HexStr) downto 1 do
  Begin
    If HexStr[I] in ['A','a','B','b','C','c','D','d','E','e','F','f'] then
      Val('$' + HexStr[I],HexBit,Code)
        else
          Val(HexStr[I],HexBit,Code);
    Temp := Temp + HexBit * Power(16,Length(HexStr) - I);
  End;
  Hex2Dec := Temp;
End;

{********************* End of part 1 *****************}

{***************** Part 2 of 6 *******************}

Function Bin2Dec(BinStr : String) : Longint;

{ Maximum is 16 bits, though a requirement for more would be   }
{ easy to accomodate.  Leading zeroes are not required. There  }
{ is no error handling - any non-'1's are taken as being zero. }

Var
  I : Byte;
  Temp : Longint;
  BinArray : Array[0..15] of char;

Begin
  For I := 0 to 15 do
    BinArray[I] := '0';

  For I := 0 to Pred(Length(BinStr)) do
    BinArray[I] := BinStr[Length(BinStr) - I];

  Temp := 0;

  For I := 0 to 15 do
    If BinArray[I] = '1' then inc(Temp,Round(Exp(I * Ln(2))));

  Bin2Dec := Temp;
End;

function CRC16(s:string):word;  { By Kevin Cooney }
var
  crc : longint;
  t,r : byte;
begin
  crc:=0;
  for t:=1 to length(s) do
  begin
    crc:=(crc xor (ord(s[t]) shl 8));
    for r:=1 to 8 do
      if (crc and $8000)>0 then
        crc:=((crc shl 1) xor $1021)
          else
            crc:=(crc shl 1);
  end;
  CRC16:=(crc and $FFFF);
end;

{**** FOSSIL Routines ****}

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 Write2Port(Strg : String);
Begin
  For Loop := 1 to Length(Strg) do
  Begin
    R.AH := $01;
    R.AL := Ord(Strg[Loop]);
    R.DX := Pred(Comport);
    Intr($14,R);
  End;
End;

{******************* End of part 2 ***********************}

{***************** Part 3 of 6 *****************}

Function ReadKeyFromPort : Char;
Begin
  R.AH := $02;
  R.DX := Pred(Comport);
  Intr($14,R);
  If R.AH = $00 then ReadKeyFromPort := Char(R.AL);
End;

Function StatusReq : Byte;
Begin
  R.AH := $03;
  R.DX := Pred(Comport);
  Intr($14,R);
  StatusReq := R.AX;
End;

Function FossilPresent : Boolean;
Begin
  R.AH := $04;
  R.DX := Pred(COMport);
  Intr($14,R);
  If R.AX = $1954 then FossilPresent := TRUE else FossilPresent := FALSE;
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;

{**************** End of Part 3 *********************}

{************* Part 4 of 6 ***************}

function FOSSIL_name : 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
  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 { looks as if FOSSIL was detected? }
    begin
      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 }

  FOSSIL_name := temp

end; { FOSSIL_name }

Procedure Hangup;
Begin
    Write2Port('+++'+#13);
End;
{**** EMSI Handshake Routines ****}

Procedure Create_EMSI_DAT;
Begin
  FillChar(EMSI_DAT,255,' ');

  EMSI_DAT := FingerPrint + '{' + System_Address + '}{'+ Password + '}' +
              Link_Codes + Compatibility_Codes + Mailer_Product_Code +
              '{' + Mailer_Name + '}{' + Mailer_Version + '}' +
              Mailer_Serial_Number;

  Length_EMSI_DAT := Hex(Length(EMSI_DAT));
End;

Function Carrier_Detected : Boolean;
Begin
  TimeOut := 20;   { Wait approximately 20 seconds }
  Repeat
    Delay(1000);
    Dec(TimeOut);
  Until (TimeOut = 0) or (Lo(StatusReq) and $80 = $80);

  If Timeout = 0 then
    Carrier_Detected := FALSE
      else
        Carrier_Detected := TRUE;
End;

{************* End of part 4 *****************}

{************* Part 5 of 6 ****************}

Function Get_EMSI_REQ : Boolean;
Begin
  Temp := '';
  Purge_Input;

  Repeat
    C := ReadKeyfromPort;
    If (C <> #10) and (C <> #13) then Temp := Temp + C;
  Until Length(Temp) = Length(EMSI_REQ);

  If Up_Case(Temp) = EMSI_REQ then
    get_EMSI_REQ := TRUE
      else
        get_EMSI_REQ := FALSE;
End;

Procedure Send_EMSI_DAT;
Begin
  CRC := Hex(CRC16('EMSI_DAT' + Length_EMSI_DAT + EMSI_DAT));
  Write2Port('**EMSI_DAT' + Length_EMSI_DAT + EMSI_DAT + CRC);
End;

Function Get_EMSI_ACK : Boolean;
Begin
  Temp := '';

  Repeat
    C := ReadKeyfromPort;
    If (C <> #10) and (C <> #13) then Temp := Temp + C;
  Until Length(Temp) = Length(EMSI_ACK);

  If Up_Case(Temp) = EMSI_ACK then
    get_EMSI_ACK := TRUE
      else
        get_EMSI_ACK := FALSE;
End;

Procedure Get_EMSI_DAT;
Begin
  Temp := '';
  For Loop := 1 to 10 do                  { Read in '**EMSI_DAT' }
    Temp := Temp + ReadKeyfromPort;

  Delete(Temp,1,2);                       { Remove the '**'      }

  Len := '';
  For Loop := 1 to 4 do                   { Read in the length   }
    Len := Len + ReadKeyFromPort;

  Temp := Temp + Len;

  Len_Rec_EMSI_DAT := Hex2Dec(Len);

  Packet := '';
  For Loop := 1 to Len_Rec_EMSI_DAT do    { Read in the packet   }
    Packet := Packet + ReadKeyfromPort;

  Temp := Temp + Packet;

  CRC := '';
  For Loop := 1 to 4 do                   { Read in the CRC      }
    CRC := CRC + ReadKeyFromPort;

  Rec_EMSI_DAT := Packet;

  Writeln('Rec_EMSI_DAT = ',Rec_EMSI_DAT);

  If Hex(CRC16(Temp)) <> CRC then
    Writeln('The recieved EMSI_DAT is corrupt!!!!');
End;

{*********** End of part 5 *************}

{********* Part 6 of 6 ****************}

Begin
  { Assumes connection has been made at this point }

  Tries := 0;
  Repeat
    Write2Port(EMSI_INQ);
    Delay(1000);
    Inc(Tries);
  Until (Get_EMSI_REQ = TRUE) or (Tries = 5);

  If Tries = 5 then
  Begin
    Writeln('Host system failed to acknowledge the inquiry sequence.');
    Hangup;
    Halt;
  End;

  { Used for debugging }
  Writeln('Boss has acknowledged receipt of EMSI_INQ');

  Send_EMSI_DAT;

  Tries := 0;
  Repeat
    Inc(Tries);
  Until (Get_EMSI_ACK = True) or (Tries = 5);

  If Tries = 5 then
  Begin
    Writeln('Host system failed to acknowledge the EMSI_DAT packet.');
    Hangup;
    halt;
  End;

  Writeln('Boss has acknowledged receipt of EMSI_DAT');

  Get_EMSI_DAT;
  Write2Port(EMSI_ACK);

  { Normally the file transfers would start at this point }
  Hangup;
End.

{********** End of part 6 (and program) **********}
(*
Ok.. If ya need some help feel free to ask.  The FOSSIL interfacing code has
been included. You'll need a FOSSIL for it to work.  The code probably won't
work as is.  The areas that will need work on is the actual port
initialization (procedure is included though) and connecting to the host
system.
Let me know how it goes.

Seeya,
  Chris.
*)