{+----------------------------------------------------------------------------+
 / Created:     3.1.2002
 / Author:      Antti Krats & Kai Lahti
 / Company:     Gestapo
 / Copyright    ©Gestapo-project 2002
 / Description: Component is used to handle comport. There is an event
                OnComPortStatusChange which occurs when the following pinstates
        	      are changed: CTS,DSR,Ring and RLSD. It does not matter which
        	      direction status is changed.
        	      ComPortInterval tells in milliseconds how often the pinstates
        	      are checked. Property ComPort has to be assigned to COM1 or
                COM2 before StartSnooping(), otherwise component always handles
        	      ComPort 1. RTS pin can be set on and off by using property
        	      RTSPower.
 / Version:     1.0
 / Open Issues:
 +----------------------------------------------------------------------------+}

unit ComPort;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, ExtCtrls, IdGlobal;

type
  TComportChangeEvent = procedure(Sender: TObject; Pin: string) of object;
                                            //Event that contains information
                                            //about which pin was connected
  TComPort = class(TComponent)
  private
    TimerComPort : TTimer;                  //checks pinstates
    dwPortHandle : DWORD;                   //handle to comport

    CTSStatus, OldCTSStatus : bool;         //pinstates
    DSRStatus, OldDSRStatus : bool;
    RingStatus, OldRingStatus : bool;
    RLSDStatus, OldRLSDStatus : bool;

    FComPort : String;
    FComPortInterval : integer;

    FDTRPower : bool;
    FRTSPower : bool;

    FOnComPortStartSnooping : TNotifyEvent;
    FOnComPortStopSnooping : TNotifyEvent;
    FOnComPortStatusChange : TComportChangeEvent;

    procedure Snoop(Sender: TObject);          //checks pinstates
    procedure ChangeComPort(port : string);    //changes comport
    procedure SetDTRPower(Power : bool);       //sets pin DTRPower to on/off
    procedure SetRTSPower(Power : bool);       //sets pin RTSPower to on/off
  protected
    { Protected declarations }
  public
    function CTSEnabled() : bool;              //returns pins status
    function DSREnabled() : bool;
    function RingEnabled() : bool;
    function RLSDEnabled() : bool;
    constructor Create(AOwner : Tcomponent); override;
    destructor Destroy(); override;
    procedure StartSnooping();        //starts TimerComPort and sets DTRPower on
    procedure StopSnooping();         //stops TimerComPort and sets DTRPower off
  published
    property OnComPortStartSnooping : TNotifyEvent
      read FOnComPortStartSnooping
      write FOnComPortStartSnooping;
    property OnComPortStopSnooping : TNotifyEvent
      read FOnComPortStopSnooping
      write FOnComPortStopSnooping;
    property OnComPortStatusChange : TComportChangeEvent
      read FOnComPortStatusChange
      write FOnComPortStatusChange;
    property ComPort : String
      read FComPort
      write ChangeComPort;
    property ComPortInterval : integer
      read FComPortInterval
      write FComPortInterval;
    property DTRPower : bool
      read FDTRPower
      write SetDTRPower;
    property RTSPower : bool
      read FRTSPower
      write SetRTSPower;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Gestapo', [TComPort]);
end;

{ TComPort }

constructor TComPort.Create(AOwner: Tcomponent);
begin
  inherited;
  OnComPortStartSnooping := nil;
  OnComPortStopSnooping := nil;
  OnComPortStatusChange := nil;

  TimerComPort := TTimer.Create(self);
  TimerComPort.Enabled := False;  //timer is off by default
  TimerComPort.OnTimer := Snoop;

  ComPort := 'COM1';              //default comport
  ComPortInterval := 100;         //default interval

  DTRPower := false;              //turns pin power off
  RTSPower := false;              //turns pin power off

  OldCTSStatus := false;
  OldDSRStatus := false;
  OldRingStatus := false;
  OldRLSDStatus := false;
end;

destructor TComPort.Destroy;
begin
  CloseHandle(dwPortHandle);      //closes comport
  inherited;
end;

//Starts the ComPortTimer and sets DTRPower on.
//Causes event OnStartSnooping.
procedure TComPort.StartSnooping;
begin
  TimerComPort.Interval := ComPortInterval;
  DTRPower := true;
  TimerComPort.Enabled := True;
  if Assigned(OnComPortStartSnooping) Then
    OnComPortStartSnooping(self);
end;

//Stops the ComPortTimer and sets DTRPower off.
//Causes event OnStopSnooping.
procedure TComPort.StopSnooping;
begin
  DTRPower := false;
  TimerComPort.Enabled := False;
  if Assigned(OnComPortStopSnooping) Then
    OnComPortStopSnooping(self);
end;

//Checks comports pins status.
//If even one pinstatus is changed
//event OnComPortStatusChange is caused.
procedure TComPort.Snoop(Sender: TObject);
var dwStatus : DWORD;
var bits : string;
begin

  GetCommModemStatus(dwPortHandle,dwStatus);  //gets current comport status
  bits := IntToBin(dwStatus shr 4);           //chops needless zeros away

  CTSStatus := bits[length(bits)-0] = '1';    //different bits means different pinstatus
  DSRStatus := bits[length(bits)-1] = '1';
  RingStatus := bits[length(bits)-2] = '1';
  RLSDStatus := bits[length(bits)-3] = '1';

  if (OldCTSStatus <> CTSStatus) Then         //if old status is different
    if Assigned(OnComPortStatusChange) Then   //than new status event is occured
      OnComPortStatusChange(self,'CTS');
  OldCTSStatus := bits[length(bits)-0] = '1';

  if (OldDSRStatus <> DSRStatus) Then
    if Assigned(OnComPortStatusChange) Then
      OnComPortStatusChange(self,'DSR');
  OldDSRStatus := bits[length(bits)-1] = '1';

  if (OldRingStatus <> RingStatus) Then
    if Assigned(OnComPortStatusChange) Then
      OnComPortStatusChange(self,'RING');
  OldRingStatus := bits[length(bits)-2] = '1';

  if (OldRLSDStatus <> RLSDStatus) Then
    if Assigned(OnComPortStatusChange) Then
      OnComPortStatusChange(self,'RLSD');
  OldRLSDStatus := bits[length(bits)-3] = '1';
end;

//returns pin CTSs status
function TComPort.CTSEnabled : bool;
begin
  result := CTSStatus;
end;

//returns pin DSRs status
function TComPort.DSREnabled: bool;
begin
  result := DSRStatus;
end;

//returns pin Rings status
function TComPort.RingEnabled: bool;
begin
  result := RingStatus;
end;

//returns pin RLSDs status
function TComPort.RLSDEnabled: bool;
begin
  result := RLSDStatus;
end;

//changes the target comport
procedure TComPort.ChangeComPort(port: string);
begin
  FComPort := port;
  CloseHandle(dwPortHandle);
  dwPortHandle := CreateFile(PChar(FComPort), GENERIC_READ or GENERIC_WRITE,
                             0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL,
                             LongInt(0));
end;

//sets DTR power on to or off
procedure TComPort.SetDTRPower(Power: bool);
begin
  if Power then
  begin
    EscapeCommFunction(dwPortHandle,SETDTR);
    FDTRPower := true;
  end
  else
  begin
    EscapeCommFunction(dwPortHandle,CLRDTR);
    FDTRPower := false;
  end;
end;

//sets RTS power to on or off
procedure TComPort.SetRTSPower(Power: bool);
begin
  if Power then
  begin
    EscapeCommFunction(dwPortHandle,SETRTS);
    FRTSPower := true;
  end
  else
  begin
    EscapeCommFunction(dwPortHandle,CLRRTS);
    FRTSPower := false;
  end;
end;

end.