Windows Perl/Tk Sirius App

[Stefan]

About 6 months ago I posted code to this group concerning a Sirius
Radio application that I wrote which had a locking up problem. I have
since discovered how to resolve the issue and made many other
enhancements as well. The program is specific to my needs, but it
least it gives some great starter code for any one else wanting to do
the same. It also provides as an example on how to create a Tk
program.

#! /usr/bin/perl

use Tk;
use Tk::DialogBox;
use Tk::NoteBook;
use Tk::LabEntry;
use Tk::Font;
use Tk::StayOnTop;
use Audio::Radio::Sirius;
use Win32::SerialPort;
use Win32::Registry;
use strict;
$^W++;
$|=1;

# TO DO:
# Button to launch web page channel list

our $DEBUG = 1;
our $serial;
our $tuner;
our $timeout = 10;
my $padx = 4;
my $pady = 4;
#$Audio::Radio::Sirius::DEFAULTS{debug} = 1;
our $reg;
$::HKEY_LOCAL_MACHINE->Open("SOFTWARE\\SiriusTK", $reg);
my %tuner = (
minimize => 0,
serial => 0,
power => 0,
channel => 0,
mute => 0,
presets => {
row1 => {
1 => "Top 40",
8 => "80\'s",
9 => "90\'s",
# 12 => "SIRIUS\nSuper Mix",
21 => "Alternative\nRock",
60 => "Today\'s\nCountry",
103 => "Blue Collar\nComedy",
104 => "Comedy\nUncensored",
105 => "Family\nComedy",
},
row2 => {
# 119 => "DSC",
129 => "CNBC",
130 => "Bloomberg\nRadio",
132 => "CNN",
134 => "NPR Now",
135 => "NPR Talk",
141 => "BBC",
146 => "Sirius Left",
151 => "StL\nT&W",
},
},
);

my $mw = MainWindow->new();
$mw->optionAdd('*font', 'Helvetica 16');
$mw->title('Powered Off');
$mw->geometry('+1+1');
$mw->resizable(0,0);

my @frame;
$frame[0] = $mw->Frame->pack(-side=>'top',-fill=>'x');
my $minimize = $frame[0]->Button(-text=>$tuner{minimize} ? 'Restore' :
'Minimize', -height=>2, -width=>8,
-command => sub { minimize($tuner{minimize}?0:1); },
)->pack(-side=>'left', -padx=>$padx, -pady=>$pady);
my $exit = $frame[0]->Button(-text=>'Exit', -height=>2, -width=>8,
-command => sub { power(0); exit; },
)->pack(-side=>'left', -padx=>$padx, -pady=>$pady);
my $power = $frame[0]->Button(-text=>$tuner{power} ? 'Off' : 'On', -
height=>2, -width=>8,
-command => sub { power($tuner{power}?0:1); },
)->pack(-side=>'left', -padx=>$padx, -pady=>$pady);
my $mute = $frame[0]->Button(-text=>$tuner{mute} ? 'Unmute' : 'Mute', -
height=>2, -width=>8,
-command => sub { mute($tuner{mute}?0:1); },
)->pack(-side=>'left', -padx=>$padx, -pady=>$pady);
my $clock = $frame[0]->Label(-text=>'',-width=>20,-font=>$mw->Font(-
family=>'Helvetica',-size=>18))->pack(-side=>'left', -padx=>$padx, -
pady=>$pady);
$frame[1] = $mw->Frame->pack(-side=>'top',-fill=>'x');
my $cdn = $frame[1]->Button(-text=>'Down',-height=>2, -width=>8,
-command => sub { channel($tuner{channel}, -1); },
)->pack(-side=>'left', -padx=>$padx, -pady=>$pady);
my $cup = $frame[1]->Button(-text=>'Up',-height=>2, -width=>8,
-command => sub { channel($tuner{channel}, 1); },
)->pack(-side=>'left', -padx=>$padx, -pady=>$pady);
my $channel = $frame[1]->Entry(-textvariable => \$tuner{channel}, -
width=>4,)->pack(-side=>'left', -padx=>$padx, -pady=>$pady);
my $set = $frame[1]->Button(-text=>'Set',-height=>2, -width=>8,
-command => sub { channel($tuner{channel}); },
)->pack(-side=>'left', -padx=>$padx, -pady=>$pady);
if ( $DEBUG > 1 ) {
my $stdout = $frame[1]->Text(-width=>25, -height=>3, -font=>$mw-
>Font(-family=>'Helvetica',-size=>10))->pack(-side=>'left', -padx=>
$padx, -pady=>$pady);
#tie *STDOUT, 'Tk::Text', $stdout;
print "STDOUT\n";
my $stderr = $frame[1]->Text(-width=>25, -height=>3, -font=>$mw-
>Font(-family=>'Helvetica',-size=>10))->pack(-side=>'left', -padx=>
$padx, -pady=>$pady);
#tie *STDERR, 'Tk::Text', $stderr;
print STDERR "STDERR\n";
}
my $c = 2;
foreach my $cat ( keys %{$tuner{presets}} ) {
$frame[$c] = $mw->Frame->pack(-side=>'top',-fill=>'x');
foreach my $chan ( sort {$a<=>$b} keys %{$tuner{presets}{$cat}} ) {
$_ = $tuner{presets}{$cat}{$chan};
$frame[$c]->Button(-text=>$_, -height=>2, -width=>9, -font=>$mw-
>Font(-family=>'Helvetica',-size=>12),
-command => sub { channel($chan); },
)->pack(-side=>'left', -padx=>$padx, -pady=>$pady);
}
$c++;
}

check_serial();
refresh_title();
refresh_clock();
eval MainLoop() while 1;

# E N D M A I N R O U T I N E

sub debug { print STDERR @_ if $DEBUG };

sub check_serial {
my (@argv) = @_;
my @status = ();
debug("Called check_serial()\n");
$serial = new Win32::SerialPort('com9') unless $serial;
if ( $serial ) {
debug("\$serial OK\n");
if ( (@status) = $serial->status ) {
debug("Received Serial status\n");
if ( not defined $status[0] ) {
debug("Serial status FAIL: not defined\n");
$tuner{serial} = 0;
} elsif ( $status[0] == 1 ) {
debug("Serial status FAIL: blocking\n");
$tuner{serial} = 0;
} else {
debug("Serial status OK\n");
$tuner = new Audio::Radio::Sirius unless $tuner;
if ( $tuner ) {
debug("\$tuner OK\n");
if ( $tuner->connect($serial) ) {
debug("serial<->tuner OK\n");
$tuner{serial} = 1;
} else {
debug("serial<->tuner FAIL\n");
$tuner{serial} = 0;
}
} else {
debug("\$tuner FAIL\n");
$tuner{serial} = 0;
}
}
} else {
debug("Did NOT receive Serial status\n");
$tuner{serial} = 0;
}
} else {
debug("\$serial FAIL\n");
$tuner{serial} = 0;
}

unless ( $tuner{serial} ) {
debug("Resetting SiriusTK\n");
$tuner{power} = 0;
$tuner{channel} = 0;
$tuner{mute} = 0;
$power->configure(-text => 'On');
$mute->configure(-text => 'Mute');
$mw->title('Powered Off');
undef $tuner;
$serial->close if $serial;
undef $serial;
}
$mw->after(100, \&check_serial);
}

sub minimize {
my (@argv) = @_;
if ( $argv[0] ) {
$mw->stayOnTop;
$frame[3]->packForget();
$frame[2]->packForget();
$frame[1]->packForget();
$tuner{minimize} = 1;
} else {
$mw->dontStayOnTop;
$mw->raise();
$mw->geometry('+1+1');
$frame[1]->pack(-side=>'top',-fill=>'x');
$frame[2]->pack(-side=>'top',-fill=>'x');
$frame[3]->pack(-side=>'top',-fill=>'x');
$tuner{minimize} = 0;
}
$minimize->configure(-text => $argv[0] ? 'Restore' : 'Minimize');
}

sub power {
my (@argv) = (@_);
#debug("Called power($argv[0])\n");
#debug("Running power\n");
return unless $tuner{serial};
my $ok = 0;
eval {
local $SIG{ALRM} = sub { die "alarm: power($argv[0])\n" }; # NB: \n
required
alarm $timeout;
$ok = $tuner->power($argv[0]);
#debug("No ok: $ok\n") unless $ok;
alarm 0;
};
if ( $ok && !$@ ) {
$tuner{power} = $argv[0];
$power->configure(-text => $tuner{power} ? 'Off' : 'On');
$mw->title($tuner{power} ? 'Powered On' : 'Powered Off');
channel();
} else {
debug("Err(power): $@\n");
}
}

sub mute {
my (@argv) = (@_);
#debug("Called mute($argv[0])\n");
return unless $tuner{serial};
return unless $tuner{power};
#debug("Running mute\n");
my $ok = 0;
eval {
local $SIG{ALRM} = sub { die "alarm: mute($argv[0])\n" }; # NB: \n
required
alarm $timeout;
$ok = $tuner->mute($argv[0]);
#debug("No ok: $ok\n") unless $ok;
alarm 0;
};
if ( $ok && !$@ ) {
$tuner{mute} = $argv[0];
$mute->configure(-text => $tuner{mute} ? 'Unmute' : 'Mute');
} else {
debug("Err(mute): $@\n");
}
}

sub channel {
my (@argv) = (@_);
unless ( $argv[0] ) {
$reg->QueryValueEx('Channel', undef, $argv[0]) unless $argv[0];
if ( $argv[0] ) {
debug("Read channel $argv[0] from Registry\n");
} else {
$argv[0] = 1;
debug("Did not read channel from Registry; default to $argv[0]\n");
}
}
$reg->SetValueEx('Channel', undef, &REG_DWORD, $argv[0]);
debug("Called channel($argv[0] + ".($argv[1] || 0)."): $tuner{channel}
\n");
#return if $tuner{channel} == $argv[0] + ($argv[1] || 0);
return unless $tuner{serial};
return unless $tuner{power};
#debug("Running channel($argv[0] + ".($argv[1] || 0)."):
$tuner{channel}\n");
my $ok = 0;
eval {
local $SIG{ALRM} = sub { die "alarm: channel($argv[0] + ".($argv[1]
|| 0).")\n" }; # NB: \n required
alarm $timeout;
#debug("Setting channel\n");
$ok = $tuner->channel(@argv);
#debug("Set channel\n");
#debug("No ok: $ok\n") unless $ok;
alarm 0;
};
if ( $ok && !$@ ) {
$tuner{channel} = $argv[0] + ($argv[1] || 0);
debug("New channel: $tuner{channel}\n");
} else {
debug("Err(channel): $@\n");
}
}

sub refresh_title {
#debug("Called refresh_title()\n");
if ( $tuner{serial} && $tuner{power} ) {
#debug("Running refresh_title\n");
eval {
#debug("Calling monitor\n");
local $SIG{ALRM} = sub { die "alarm: refresh_title_1\n" }; # NB:
\n required
alarm $timeout;
$tuner->monitor(1);
alarm 0;
#debug("Leaving monitor\n");
};
debug("Err(refresh_title_1): $@\n") unless !$@;
eval {
#debug("Calling callback\n");
local $SIG{ALRM} = sub { die "alarm: refresh_title_2\n" }; # NB:
\n required
alarm $timeout;
$tuner->set_callback('channel_update', \&channelupdate);
alarm 0;
#debug("Leaving callback\n");
};
debug("Err(refresh_title_2): $@\n") unless !$@;
$frame[0]->after(100, \&refresh_title);
} else {
$frame[0]->after(1000, \&refresh_title);
}
}

sub refresh_clock {
my $tpiece = localtime();
$tpiece =~ s/(\S+):(\S+):(\S+)//;
my ($hpiece,$mpiece,$spiece) = ($1,$2,$3);
$hpiece -= 12 if $hpiece > 12;
$tpiece =~ s/\s+/ /g;
$clock->configure(-text => "$tpiece / $hpiece:$mpiece:$spiece");
$frame[1]->after(100, \&refresh_clock);
}

sub channelupdate {
my ($channel, $pid, $artist, $title, $composer) = @_;
debug("Called channelupdate()\n");
if ( $tuner{serial} && $tuner{power} ) {
no warnings;
$tuner{channel} = $channel;
if ( $artist || $title ) {
debug("$channel: ".(join(' - ', $artist || '', $title ||
''))."\n");
$mw->title("$channel: ".(join(' - ', $artist || '', $title ||
'')));
} else {
debug("$channel: Reading information from sattelite...\n");
$mw->title("$channel: Reading information from sattelite...");
}
} else {
debug("Powered Off\n");
$mw->title('Powered Off');
}
}