use strict;
use warnings;
use Win32::SerialPort qw(:STAT);    # Windows-Variante

$| = 1;

my $port = Win32::SerialPort->new('COM1')
    or die "Oops!\n";

# Mit DTR, RTS und TXD klappern
for my $pin('DTR', 'RTS', 'TXD')
  {
  SetPin($port, $pin, 1);
  sleep 1;
  SetPin($port, $pin, 0);
  sleep 1;
  }

# Status einlesen
while (1)
  {
  linestatus();
  sleep 1;
  }

# Port schliessen (hier sorgt Strg-C dafuer)
undef $port;


sub SetPin # ($port, $pin, 0|1)
  {
  my $result;
  my $port = shift;
  my $pin = uc(shift);
  my $value = shift;
  if ($pin eq 'DTR')
    { $result = $port->dtr_active($value); }
  elsif ($pin eq 'RTS')
    { $result = $port->rts_active($value); }
  elsif ($pin eq 'TXD')
    { $result = $port->break_active($value); }
  else
    { return undef; }
  return $result;
  }

sub GetPin # ($port, $pin)
  {
  my $port = shift;
  my $pin = uc(shift);
  my $status = $port->is_modemlines();
  if ($pin eq 'CTS')
    { return ($status & MS_CTS_ON) ? 1 : 0; }
  elsif ($pin eq 'DSR')
    { return ($status & MS_DSR_ON) ? 1 : 0; }
  elsif ($pin eq 'DCD')
    { return ($status & MS_RLSD_ON) ? 1 : 0; }
  elsif ($pin eq 'RI')
    { return ($status & MS_RING_ON) ? 1 : 0; }
  else
    { return undef; }
  }

sub linestatus
  {
  my $status = $port->is_modemlines();
  printf("Modem status=0x%04X (CTS=%s DSR=%s RNG=%s CD=%s)\n",
         $status,
        ($status & MS_CTS_ON) ? "ON " : "off",
        ($status & MS_DSR_ON) ? "ON " : "off",
        ($status & MS_RING_ON) ? "ON " : "off",
        ($status & MS_RLSD_ON) ? "ON " : "off",
    );
  }