{*******************************************************}
{                                                       }
{       SerCOM  1.2 (2) Macintosh                       }
{                                                       }
{       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
  types, devices;

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" }

  MaxBuff = 32000;

type
  BuffArr = packed array [1..MaxBuff] of char;
  BuffPtr = ^BuffArr;

  SerialRec = record
    SysErr: OsErr;
    NameIn: string[4];
    NameOut: string[5];
    RefIn: integer;
    RefOut: integer;
    Param: integer;
    LimitIn: integer;
    InputBuffer: Ptr;
    LimitOut: integer;
    OutputBuffer: BuffPtr;
    OutputPBlock: ParamBlockRec;
  end;

  SerialPtr = ^SerialRec;

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

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

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


implementation

uses
  files, serial;

function SetParameter(SP: SerialPtr; Baud: longint; Data, Stop: integer; Parity: char): OSErr;
var Err: OSErr;
begin
  Err := SER_OK;
  with SP^ do
  begin
    case Baud of
      300: Param := 380;
      600: Param := 189;
      1200: Param := 94;
      1800: Param := 62;
      2400: Param := 46;
      3600: Param := 30;
      4800: Param := 22;
      7200: Param := 14;
      9600: Param := 10;
      14400: Param := 6;
      19200: Param := 4;
      28800: Param := 2;
      38400: Param := 1;
      57600: Param := 0;
      otherwise Err := SER_ERR;
    end;
    case Data of
      5: Param := Param + data5;
      6: Param := Param + data6;
      7: Param := Param + data7;
      8: Param := Param + data8;
      otherwise Err := SER_ERR;
    end;
    case Stop of
      1, 10: Param := Param + stop10;
      15: Param := Param + stop15;
      2, 20: Param := Param + stop20;
      otherwise Err := SER_ERR;
    end;
    case Parity of
      'n', 'N': Param := Param + noParity;
      'o', 'O': Param := Param + oddParity;
      'e', 'E': Param := Param + evenParity;
      otherwise Err := SER_ERR;
    end;
  end;
  SetParameter := Err;
end;


procedure ResetSerial(SP: SerialPtr);
var Err: OSErr;
begin
  with SP^ do
  begin
    with OutputPBlock do
    begin
      ioCompletion := nil;
      ioResult := 0;
      ioRefNum := RefOut;
      ioBuffer := @OutputBuffer^;
      ioReqCount := 0;
      ioActCount := 0;
      ioPosMode := 0;
      ioPosOffset := 0;
    end;
    Err := SerReset(RefOut, Param);
    Err := SerReset(RefIn, Param);
    Err := SerSetBuf(RefIn, InputBuffer, LimitIn);
  end;
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.   }
{  1 = Port A (Modem Port). 2 = Port B (Printer Port).                 }
{  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 muss 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;
  Err: OSErr;
begin
  New(SP);
  if (SP <> nil) then with SP^ do
    begin
      Err := SER_OK;
      SysErr := noErr;
      case PortNr of
        1: begin { ModemPort }
            NameIn := '.AIn';
            NameOut := '.AOut';
          end;
        2: begin { PrinterPort }
            NameIn := '.BIn';
            NameOut := '.BOut';
          end;
        otherwise Err := SER_ERR;
      end;
      if (Err = SER_OK) and (MaxBlock > (InBuffer + OutBuffer)) then
      begin
        RefIn := 0;
        RefOut := 0;
        Err := SetParameter(SP, 9600, 8, 10, 'N');
        LimitIn := InBuffer;
        LimitOut := OutBuffer;
        InputBuffer := NewPtr(InBuffer);
        OutputBuffer := BuffPtr(NewPtr(OutBuffer));
        SerialInit := SP;
      end
      else begin
        Dispose(SP);
        SerialInit := nil;
      end;
    end
  else SerialInit := nil;
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): OSErr;
begin
  if (SP <> nil) then with SP^ do
    begin
      SerialCode := SysErr;
      SysErr := noErr;
    end
  else SerialCode := 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): OSErr;
var Err: OsErr;
begin
  if (SP <> nil) then
  begin
    Err := SerialStop(SP);
    DisposePtr(SP^.InputBuffer);
    DisposePtr(Ptr(SP^.OutputBuffer));
    Dispose(SP);
    SerialExit := SER_OK;
  end
  else SerialExit := 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, dass 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): OSErr;
var Err: OSErr;
begin
  Err := SER_OK;
  if (SP <> nil) then with SP^ do
    begin
      Err := SetParameter(SP, Baud, Data, Stop, Parity);
      if (Err = SER_OK) and (RefIn <> 0) and (RefOut <> 0) then ResetSerial(SP);
    end
  else Err := SER_NIL;

  SerialPara := Err;
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): OSErr;
var Err: OsErr;
begin
  Err := SER_OK;
  if (SP <> nil) then with SP^ do
    begin
      if (RefIn = 0) and (RefOut = 0) then
      begin
        Err := OpenDriver(NameOut, RefOut);
        if (Err = noErr) then Err := OpenDriver(NameIn, RefIn);
        if (Err = noErr) then ResetSerial(SP);
        if (Err <> noErr) then
        begin
          SysErr := Err;
          Err := SER_SYS;
        end;
      end;
    end
  else Err := SER_NIL;
  SerialOpen := Err;
end;


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

function SerialStop(SP: SerialPtr): OSErr;
var Err: OsErr;
begin
  Err := SER_OK;
  if (SP <> nil) then with SP^ do
    begin
      if (RefIn <> 0) and (RefOut <> 0) then
      begin
        Err := SerSetBuf(RefIn, nil, 0);
        Err := KillIo(RefOut);
        Err := KillIo(RefIn);
        Err := CloseDriver(RefOut);
        Err := CloseDriver(RefIn);
        with OutputPBlock do
        begin
          ioCompletion := nil;
          ioResult := 0;
          ioRefNum := 0;
          ioBuffer := nil;
          ioReqCount := 0;
          ioActCount := 0;
          ioPosMode := 0;
          ioPosOffset := 0;
        end;
        RefIn := 0;
        RefOut := 0;
        if (Err <> SER_OK) then
        begin
          SysErr := Err;
          Err := SER_SYS;
        end;
      end;
    end;
  SerialStop := Err;
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.                               }
{  ANMERKUNG Macintosh-Version: Das asynchrone Senden funktionierte    }
{  eine Zeit lang hervorragend. Seit einiger Zeit habe ich jedoch      }
{  Probleme damit. Deshalb ist diese Routine momentan NICHT asynchron  }
{  sondern arbeitet mit einem ganz normalen "FsWrite" Befehl...        }
{----------------------------------------------------------------------}

function SerialXmit(SP: SerialPtr; data: char): OSErr;
var
  C: packed array [1..2] of char;
  L: longint;
  Err: OsErr;
begin
  Err := SER_OK;
  if (SP <> nil) then with SP^ do
    begin
      L := 1;
      C[1] := data;
      Err := FSWrite(RefOut, L, @C);
      if (Err = 0) then Err := L;
    end
  else Err := SER_NIL;
  SerialXmit := Err;
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, dass kein Zeichen empfangen wurde.                        }
{----------------------------------------------------------------------}

function SerialRecv(SP: SerialPtr; var data: char): OSErr;
var
  C: packed array [1..2] of char;
  L: longint;
  Err: OsErr;
begin
  Err := SER_OK;
  if (SP <> nil) then with SP^ do
    begin
      Err := SerGetBuf(RefIn, L);
      if Err = noErr then
      begin
        if (L > 0) then
        begin
          L := 1;
          Err := FsRead(RefIn, L, @C);
          if (Err = noErr) then
          begin
            Err := 1;
            data := C[1];
          end
          else begin
            SysErr := Err;
            Err := SER_SYS;
          end;
        end;
      end
      else begin
        SysErr := Err;
        Err := SER_SYS;
      end;
    end
  else Err := SER_NIL;
  SerialRecv := Err;
end;


end.