{*******************************************************}
{                                                       }
{       SerCOM  1.2 (3) Windows                         }
{                                                       }
{       Copyright (c) 1990,2005 DYNAMO Software         }
{                                                       }
{*******************************************************}

{
  Pascal Routinen für die Verwendung der seriellen
  Schnittstelle. Diese Unit existiert in 3 Versionen
  für folgende Plattformen:

  (1) MS-DOS     (Turbo Pascal)
  (2) Macintosh  (CodeWarrior)
  (3) Windows    (Delphi)

  Dieser Quellcode ist Freeware und darf NICHT verkauft
  werden. Download der aktuellen Version unter:

  www.dynamo-software.de/serial/code.htm

  Viel Spaß am Gerät!
  Jens-Erich Lange
  info@dynamo-software.de
}

unit SerCom;

interface

uses
  Windows;

const
  SER_OK = 0;      // Kein Fehler
  SER_NIL = -1;    // SerialPtr nicht initialisiert / Zuwenig RAM für Puffer
  SER_ERR = -2;    // Unzulässige Parameter oder Schnittstelle geschlossen
  SER_SYS = -3;    // Fehlermeldung vom Betriebssystem. Nummer in "SerialCode"


type
  SerialRec = record
    SysErr: longint;
    ComName: array [0..5] of char;
    hFile: tHandle;
    sBaud: longint;
    sData: integer;
    sStop: integer;
    sParity: char;
    Output: longint;
    SizeIn: longint;
    SizeOut: longint;
    TimeOut: tCommTimeOuts;
  end;

  SerialPtr = ^SerialRec;
  SerialErr = longint;


{-------------------------------------------------------}
{  Initialisierung / Deinitialisierung                  }
{-------------------------------------------------------}
function SerialInit(PortNr, InBuffer, OutBuffer: integer): SerialPtr;
function SerialCode(SP: SerialPtr): SerialErr;
function SerialExit(SP: SerialPtr): SerialErr;

{-------------------------------------------------------}
{  Öffnen / Schließen / Parametrieren                   }
{-------------------------------------------------------}
function SerialPara(SP: SerialPtr; Baud: longint; Data, Stop: integer; Parity: char): SerialErr;
function SerialOpen(SP: SerialPtr): SerialErr;
function SerialStop(SP: SerialPtr): SerialErr;

{-------------------------------------------------------}
{  Senden / Empfangen                                   }
{-------------------------------------------------------}
function SerialXmit(SP: SerialPtr; data: char): SerialErr;
function SerialRecv(SP: SerialPtr; var data: char): SerialErr;
function SerialDone(SP: SerialPtr): SerialErr;

function SerialRSet(SP: SerialPtr; Value: byte): SerialErr;
function SerialRGet(SP: SerialPtr): SerialErr;


implementation

function SetParameter(SP: SerialPtr): SerialErr;
var dcb: tdcb;
begin
  result := SER_OK;
  if (SP <> nil) then with SP^ do
    begin
      if hFile <> INVALID_HANDLE_VALUE then
      begin
        if GetCommState(hfile, dcb) then with dcb do
          begin
            BaudRate := sBaud;
            ByteSize := sData;
            case sStop of
              1, 10: StopBits := 0;
              3, 15: StopBits := 1;
              2, 20: StopBits := 2;
            end;
            case sParity of
              'N', 'n': Parity := 0;
              'O', 'o': Parity := 1;
              'E', 'e': Parity := 2;
              'M', 'm': Parity := 3;
              'S', 's': Parity := 4;
            end;
            if not SetCommState(hfile, dcb) then
            begin
              SysErr := getLastError;
              result := SER_SYS;
            end;
          end
        else begin
          SysErr := getLastError;
          result := SER_SYS;
        end;
      end;
    end
  else result := SER_NIL;
end;


{ private }
{----------------------------------------------------------------------}
{ public }


{----------------------------------------------------------------------}
{  Funktion "SerialInit"                                               }
{  initialisiert die Verwendung der seriellen Schnittstelle. Diese     }
{  Funktion wird ¸blicherweise einmal zu Beginn des Programms aufge-   }
{  rufen.                                                              }
{  Der Parameter PortNr bezeichnet die zu verwendende Schnittstelle.   }
{  Die Parameter InBuffer und OutBuffer geben die Größe der Zwischen-  }
{  puffer für das asynchrone Senden und Empfangen an.                  }
{  Eine typische Größe von InBuffer und OutBuffer ist 1024.            }
{  Das Ergebnis der Funktion ist ein Handle für die zu verwendende     }
{  Schnittstelle. In allen weiteren Routinen muß dieses Handle         }
{  angegeben werden. Durch die Identifizierung über ein Handle ist es  }
{  möglich mehrere Schnittstellen gleichzeitig zu öffnen. Das Gegen-   }
{  stück zu "SerialInit" ist die Funktion "SerialExit".                }
{----------------------------------------------------------------------}

function SerialInit(PortNr, InBuffer, OutBuffer: integer): SerialPtr;
var SP: SerialPtr;
begin
  New(SP);
  if (SP <> nil) then with SP^ do
    begin
      ComName[0] := 'C';
      ComName[1] := 'O';
      ComName[2] := 'M';
      ComName[3] := char(PortNr + 48);
      ComName[4] := ':';
      ComName[5] := #0;
      hFile := INVALID_HANDLE_VALUE;
      sBaud := 9600;
      sData := 8;
      sStop := 10;
      sParity := 'N';
      Fillchar(TimeOut, sizeof(TimeOut), 0);
      with TimeOut do
      begin
        ReadIntervalTimeout := MAXDWORD;
        ReadTotalTimeoutConstant := 0;
        ReadTotalTimeoutMultiplier := 0;
      end;
      SizeIn := InBuffer;
      SizeOut := OutBuffer;
    end;
  SerialInit := SP;
end;


{----------------------------------------------------------------------}
{  Funktion "SerialCode"                                               }
{  gibt eine erweiterte Fehlermeldung zurück wenn eine andere Routine  }
{  zuvor das Ergebnis "SER_SYS" (-3) geliefert hat. Die Fehlernummer   }
{  ist die Io-Meldung des Betriebssystems.                             }
{----------------------------------------------------------------------}

function SerialCode(SP: SerialPtr): SerialErr;
begin
  if (SP <> nil) then with SP^ do
    begin
      result := SysErr;
      SysErr := 0;
    end
  else result := SER_NIL;
end;


{----------------------------------------------------------------------}
{  Funktion "SerialExit"                                               }
{  ist das Gegenstück zu "SerialInit". Diese Funktion gibt den beleg-  }
{  ten Speicher für das Handle zu einer Schnittstelle wieder frei.     }
{  Ist die Schnittstelle zum Zeitpunkt des Aufrufes noch geöffnet, so  }
{  wird sie zunächst geschlossen.                                      }
{----------------------------------------------------------------------}

function SerialExit(SP: SerialPtr): SerialErr;
begin
  if (SP <> nil) then
  begin
    result := SerialStop(SP);
    Dispose(SP);
  end
  else result := SER_NIL;
end;


{----------------------------------------------------------------------}
{  Funktion "SerialPara"                                               }
{  parametriert die serielle Schnittstelle. Es ist dabei unerheblich,  }
{  ob die Schnittstelle bereits geöffnet ist oder nicht.               }
{  Für eine ordentliche Kommunikation ist es erforderlich, daß alle    }
{  Parameter mit denen der Gegenstelle übereinstimmen. Viele Modems    }
{  können die verwendeten Parameter selbständig erkennen und können    }
{  daher mit verschiedenen Parametern angesprochen werden.             }
{  Die Standardeinstellung für Daten- und Stopbits sowie Parität sind  }
{  8 - 1 - Keine (None).                                               }
{----------------------------------------------------------------------}

function SerialPara(SP: SerialPtr; Baud: longint; Data, Stop: integer; Parity: char): SerialErr;
begin
  if (SP <> nil) then with SP^ do
    begin
      sBaud := Baud;
      sData := Data;
      sStop := Stop;
      sParity := Parity;
      result := SetParameter(SP);
    end
  else result := SER_NIL;
end;


{----------------------------------------------------------------------}
{  Funktion "SerialOpen"                                               }
{  Öffnet die serielle Schnittstelle und ermöglicht somit den Daten-   }
{  verkehr. Nachdem die Schnittstelle geöffnet ist, werden alle ein-   }
{  gehenden Zeichen im Zwischenpuffer gespeichert bis diese mit der    }
{  Funktion "SerialRecv" aus dem Puffer entnommen werden.              }
{  Das Gegenstück zu "SerialOpen" ist die Funktion "SerialStop".       }
{  Die Zwischenpuffer werden beim öffnen und schließen einer Schnitt-  }
{  stelle gelöscht.                                                    }
{----------------------------------------------------------------------}

function SerialOpen(SP: SerialPtr): SerialErr;
var commprop: tCommProp;
begin
  result := SER_OK;
  if (SP <> nil) then with SP^ do
    begin
      if hFile = INVALID_HANDLE_VALUE then
      begin
        hFile := CreateFile(ComName, GENERIC_READ + GENERIC_WRITE, 0, nil, OPEN_EXISTING, 0, 0);
        if (hFile <> INVALID_HANDLE_VALUE) then
        begin
          if GetCommProperties(hfile, commprop) then
          begin
            SetupComm(hfile, SizeIn, SizeOut);
            SetParameter(SP);
            SetCommTimeouts(hfile, TimeOut);
            SetCommMask(hfile, 0);
            Output := commprop.dwCurrentTxQueue;
          end
          else begin
            SysErr := GetLastError;
            result := SER_SYS;
          end;
        end
        else begin
          SysErr := GetLastError;
          result := SER_SYS;
        end;
      end;
    end
  else result := SER_NIL;
end;


{----------------------------------------------------------------------}
{  Funktion "SerialStop"                                               }
{  schließt die serielle Schnittstelle. Die Datenkommunikation wird    }
{  unterbunden und der Gegenstelle wird auf den Handshakeleitungen     }
{  signalisiert, daß die Schnittstelle geschlossen ist. Ein ordent-    }
{  lich konfiguriertes Modem sollte dadurch eine bestehende Telefon-   }
{  verbindung trennen.                                                 }
{----------------------------------------------------------------------}

function SerialStop(SP: SerialPtr): SerialErr;
begin
  if (SP <> nil) then with SP^ do
    begin
      if hFile <> INVALID_HANDLE_VALUE then
      begin
        EscapeCommFunction(hFile, CLRRTS);
        SetCommMask(hfile, 0);
        CloseHandle(hFile);
        hFile := INVALID_HANDLE_VALUE;
      end;
      result := SER_OK;
    end
  else result := SER_NIL;
end;


{----------------------------------------------------------------------}
{  Funktion "SerialXmit"                                               }
{  Übergibt ein Zeichen an den Sendepuffer. Falls die Schnittstelle    }
{  zu diesem Zeitpunkt geöffnet ist, werden die Zeichen im Hinter-     }
{  grund asynchron übertragen. Die Funktion kehrt nach ihrem Aufruf    }
{  schnell zurück und wartet nicht auf das Ende der Ðbertragung.       }
{  Zeichenketten und binäre Arrays werden vom Aufrufer in einer        }
{  Schleife an diese Funktion übergeben.                               }
{  Mit der Funktion "SerialDone" kann geprüft werden, ob schon alle    }
{  Zeichen übertragen wurden.                                          }
{----------------------------------------------------------------------}

function SerialXmit(SP: SerialPtr; data: char): SerialErr;
var
  count: DWORD;
  comstat: tComstat;
begin
  if (SP <> nil) then with SP^ do
    begin
      if hFile <> INVALID_HANDLE_VALUE then
      begin
        ClearCommError(hfile, count, @comstat);
        if (((Output - SerialErr(comstat.cbOutQue)) - 1) <= 0) then
        begin
          if WriteFile(hfile, data, 1, count, nil) then result := count
          else begin
            SysErr := GetLastError;
            result := SER_SYS;
          end;
        end
        else result := SER_NIL;
      end
      else result := SER_ERR;
    end
  else result := SER_NIL;
end;


{----------------------------------------------------------------------}
{  Funktion "SerialRecv"                                               }
{  holt das nächste Zeichen aus dem Empfangspuffer. Voraussetzung ist  }
{  eine geöffnete Schnittstelle. Ist das Ergebnis dieser Funktion "1"  }
{  so wurde die Funktion erfolgreich ausgeführt. Alle anderen Werte    }
{  bedeuten, daß kein Zeichen empfangen wurde.                         }
{----------------------------------------------------------------------}

function SerialRecv(SP: SerialPtr; var data: char): SerialErr;
var count: DWORD;
begin
  if (SP <> nil) then with SP^ do
    begin
      if hFile <> INVALID_HANDLE_VALUE then
      begin
        if windows.ReadFile(hfile, data, 1, count, nil) then result := count
        else begin
          SysErr := GetLastError;
          result := SER_SYS;
        end;
      end
      else result := SER_ERR;
    end
  else result := SER_NIL;
end;


{----------------------------------------------------------------------}
{  Funktion "SerialDone"                                               }
{  ermittelt wieviele Zeichen sich momentan im Sendepuffer befinden.   }
{  Ist das Ergebnis "0", sind keine Zeichen mehr im Sendepuffer.       }
{----------------------------------------------------------------------}

function SerialDone(SP: SerialPtr): SerialErr;
begin
  if (SP <> nil)
    then result := SP^.Output
  else result := SER_NIL;
end;


{----------------------------------------------------------------------}
{  Funktion "SerialRSet"                                               }
{  setzt einzelne Handshakeleitungen der seriellen Schnittstelle.      }
{  Diese Funktion ist nur in dieser Wondows Version vorhanden.         }
{----------------------------------------------------------------------}

function SerialRSet(SP: SerialPtr; Value: byte): SerialErr;
begin
  if (SP <> nil) then with SP^ do
    begin
      if hFile <> INVALID_HANDLE_VALUE then
      begin
        EscapeCommFunction(hFile, Value);
        result := SER_OK;
      end
      else result := SER_ERR;
    end
  else result := SER_NIL;
end;


{----------------------------------------------------------------------}
{  Funktion "SerialRGet"                                               }
{  liest den Status der Handshakeleitungen.                            }
{  Diese Funktion ist nur in dieser Wondows Version vorhanden.         }
{----------------------------------------------------------------------}

function SerialRGet(SP: SerialPtr): SerialErr;
var Reg: Cardinal;
begin
  if (SP <> nil) then with SP^ do
    begin
      if (hFile <> INVALID_HANDLE_VALUE) then
      begin
        if GetCommModemStatus(hFile, Reg)
          then Result := Reg
        else Result := SER_ERR;
      end
      else result := SER_ERR;
    end
  else result := SER_NIL;
end;


end.