#!/usr/local/bin/perl
#
# ----------------------------------------------------------------------
#  xpccard --- FreeBSD PC-card utility for X11
#  Copyright (C) 1996-1997 by Tatsumi Hosokawa <hosokawa@jp.FreeBSD.org>
# ----------------------------------------------------------------------
#
# This utility requires
#
#	o perl-5.003 or later
#	o p5-Tk-400-2.00 or later
#
# You can install them from FreeBSD ports/packages collections.
# ex.: lang/perl-5.003.tgz and p5-Tk400-2.00.tgz
#
# This utility eats large amount of memory because it is implemented
# in Perl.  I don't recommend you to use this utility if you have only
# insufficient memory.  If you're dissatisfied at this problem, please
# re-implement it on C (or buy more memory) instead of complaining to 
# me :-). I think that Perl is the most excellent language to implement 
# such programs though it requires memory too much.  I must waste much 
# more time if I must write this program in C.
#

# ----------------------------------------------------------------------
require 5.002;
use Getopt::Long;
use Socket;
use Tk;
use Text::ParseWords;
# -----------------------------------------------------------------

# -----------------------------------------------------------------
my $configfile = '/usr/local/lib/xpccard/config';
my $maxmsglen = 512;
my $socket_name = '/var/tmp/.pccardd';
my $csocket_name = '/tmp/xpccard' . $$;
# -----------------------------------------------------------------

# -----------------------------------------------------------------
my $activecolor = 'lightyellow';
my $hibernatecolor = 'gold3';
my $emptycolor = 'gray40';
my $powercolor = 'green';
# -----------------------------------------------------------------

# -----------------------------------------------------------------
sub parse_cardname($);
sub communicate($);
sub statchanged();
sub readconfig($);
sub createalias(@);
sub pwrbutton($);
sub devbutton($);
sub wincolor($);
sub usage();
# -----------------------------------------------------------------

# -----------------------------------------------------------------
my $i;
my @aliases;
&readconfig($configfile);
my $sun = sockaddr_un($socket_name);
my $csun = sockaddr_un($csocket_name);

$SIG{'TERM'} = \&xpccard_exit;

socket(SOCKET, PF_UNIX, SOCK_DGRAM, 0) || die "socket failed: $!";
bind(SOCKET, $csun) || die "bind failed: $!";

my $maxcardnum = &communicate('S');
if ($maxcardnum == 0) {
	die "No card slots found";
}

my %slotstat;

foreach $i (0 .. ($maxcardnum - 1)) {
	$slotstat{$i} = &communicate('N'.$i)."\n";
}

my $main = new MainWindow;

my %frames;
my %names;
my %cbuts;
my %cbutvs;
my %drvs;
my %pwact;

$main->Photo('pwrgif', -file => '/usr/local/lib/xpccard/power.gif');
$main->bind('<q>', \&xpccard_exit);

foreach $i (0 .. ($maxcardnum - 1)) {
	my ($slot, $name, $drv, $stat) = &parse_cardname($slotstat{$i});
	my $frame = $main -> Frame -> pack(-side => 'top');
	$cbutvs{$i} = ($stat == 1);
	$drvs{$i} = $frame
		-> Button(	-text	=>	$drv,
				-width	=>	3,
				-command	=>	sub{&devbutton($i)})
		-> pack(	-side	=>	'right');
	$cbuts{$i} = $frame
		-> Checkbutton( -image	=>	'pwrgif',
				-selectcolor	=>	$powercolor,
				-variable	=>	\$cbutvs{$i},
				-command	=>	sub{&pwrbutton($i)})
		-> pack(	-side	=>	'right');
	$names{$i} = $frame 
		-> Label(	-text	=>	$name,
				-width	=>	24,
				-anchor	=>	'w',
				-background	=>	&wincolor($stat),
				-relief	=>	'sunken')
		-> pack(	-side	=>	'right');
	$label = sprintf("%d", $i);
	$frame -> Label(	-text	=>	$label, 
				-width	=>	2)
		->pack(		-side	=>	'right');
	$frames{$i} = $frame;
	$pwact{$i} = 1;
	if ($stat == 0 || $stat == 2) {
		$drvs{$i} -> configure( -state => 'disabled');
	}
	if ($stat == 0) {
		$pwact{$i} = 0;
		$cbuts{$i} -> configure( -state => 'disabled');
	}
}

#foreach $i (0 .. ($maxcardnum - 1)) {
#	$frames{$i}->configure(	-expand	=>	1);
#}

$main->fileevent(SOCKET, 'readable', \&statchanged);
MainLoop;

close SOCKET;
unlink($csocket_name);
# -----------------------------------------------------------------

# -----------------------------------------------------------------
sub parse_cardname($) {
	my $slotstat = shift;
	my ($slot, $manuf, $vers, $drv, $stat);
	$manuf = $vers = $drv = "N/A";
	$stat = 0;
	($slot, $manuf, $vers, $drv, $stat) = split('~', $slotstat);
	$manuf =~ s/^\s*//;
	$manuf =~ s/\s*$//;
	$vers =~ s/^\s*//;
	$vers =~ s/\s*$//;
	$manuf = 'N/A' if (length($manuf) == 0);
	$vers = 'N/A' if (length($vers) == 0);
	$drv = 'N/A' if (length($drv) == 0);
	my $name;
	if ($stat == 0) {
		$name = "Empty";
	}
	elsif ($stat == 2) {
		$name = "Hibernating Card";
	}
	else {
		$name = sprintf("%s (%s)", $manuf, $vers);
		my $i;
		alias: foreach $i (@aliases) {
			my $amanuf = $i->{manuf};
			my $avers = $i->{vers};
			if ($manuf =~ /$amanuf/ && $vers =~ /$avers/) {
				$name = $i->{alias};
				last alias;
			}
		}
	}
	($slot, $name, $drv, $stat);
}
# -----------------------------------------------------------------

# -----------------------------------------------------------------
sub communicate($) {
	my $line = shift;
	my($rin, $rout, $count);
	if (send(SOCKET, $line, 0, $sun) != length($line)) {
		die "send failed: $!";
	}
	$rin = '';
	vec($rin, fileno(SOCKET), 1)  = 1;
	$count = select($rout = $rin, undef, undef, 1.0);
	die "select failed" if ($count < 0);
	if ($count) {
		recv(SOCKET, $line, $maxmsglen, 0);
	}
	else {
		$line = 0;
	}
	$line;
}
# -----------------------------------------------------------------

# -----------------------------------------------------------------
sub statchanged() {
	my $line = 0;
	recv(SOCKET, $line, $maxmsglen, 0);
	my ($slot, $name, $drv, $stat) = &parse_cardname($line);
	$drvs{$slot}
		-> configure(	-text	=>	$drv);
	$names{$slot}
		-> configure(	-text	=>	$name,
				-background	=>	&wincolor($stat));
	$cbutvs{$slot} = ($stat == 1);
	if ($stat == 0) {
		$drvs{$slot} -> configure( -state => 'disabled');
		$cbuts{$slot} -> configure( -state => 'disabled');
		$pwact{$slot} = 0;
	}
	else {
		if ($stat == 1) {
			$drvs{$slot} -> configure( -state => 'active');
		}
		else {
			$drvs{$slot} -> configure( -state => 'disabled');
		}
		$pwact{$slot} = 1;
		foreach $i (0 .. ($maxcardnum - 1)) {
			if ($pwact{$i}) {
				$cbuts{$i} -> configure( -state => 'active');
			}
		}
	}
}
# -----------------------------------------------------------------

# -----------------------------------------------------------------
sub readconfig($) {
	my $filename = shift;

	open(CONFIG, $filename) || die "Can't open config file";
	getconfig: while (<CONFIG>) {
		chop;
		s/#.*$//;
		next getconfig if (/^\s*$/);
		my @words = shellwords($_);
		my $words = @words;
		my $function = shift @words;
		if ($function =~ /^alias$/) {
			push (@aliases, &createalias(@words));
		}
		else {
			die "Unknown keyword at $configfile ($.)\n";
		}
	}
	close CONFIG;
}
# -----------------------------------------------------------------

# -----------------------------------------------------------------
sub createalias(@) {
	my @decl = @_;
	my $num = @decl;
	my $alias = shift @decl;
	
	if ($num != 3) {
		die "Invalid arguments for alias at $configfile ($.)\n";
	}
	$manuf = shift @decl;
	$vers = shift @decl;
	$alias =~ s/\\\\/\\/g;
	$manuf =~ s/\\\\/\\/g;
	$vers =~ s/\\\\/\\/g;
	{'alias' => $alias, 'manuf' => $manuf, 'vers' => $vers};
}
# -----------------------------------------------------------------

# -----------------------------------------------------------------
sub pwrbutton($) {
	my $i;
	my $slot = shift;
	my $message;
	my $newstate = $cbutvs{$slot};

	if ($newstate) {
		$message = sprintf("P%d", $slot);
	}
	else {
		$message = sprintf("Q%d", $slot);
	}
	&communicate($message);
	foreach $i (0 .. ($maxcardnum - 1)) {
		$cbuts{$i} -> configure( -state => 'disabled');
	}
}
# -----------------------------------------------------------------

# -----------------------------------------------------------------
sub devbutton($) {
	my $slot = shift;

# currently not implemented...
}
# -----------------------------------------------------------------

# -----------------------------------------------------------------
sub wincolor($) {
	my $state = shift;
	my $color = $emptycolor;

	if ($state == 1) {
		$color = $activecolor;
	}
	elsif ($state == 2) {
		$color = $hibernatecolor;
	}
	$color;
}
# -----------------------------------------------------------------

# -----------------------------------------------------------------
sub usage() {
	print <<MESGEND;
xpccard (PAO/FreeBSD PC-card Controller for X11)
Usage: perl [-help] [-geometry geometry]
MESGEND
	exit 1;
}
# -----------------------------------------------------------------
sub xpccard_exit
{
	close SOCKET;
	unlink($csocket_name);
	exit 0;
}