#!/usr/bin/perl -w
#
#  "In Search of a Better Mousetrap"
#
#  071207 -- John C. Norton -- "liverpole"
#
#

# Strict
use strict;
use warnings;

####################
### User-defined ###
####################
# Common
my $version       = "1.00  (071230)";
my $fwinkprog     = "C:/Program Files/Fwink/fwink.exe";
my $srvrport      = "8128";
my $wtopdir       = "C:/mousecam";
my $ltopdir       = "/home/jnorton/mousecam";
my $topdir        = ($^O =~ /linux/i)? $ltopdir: $wtopdir;
my $example       = "$topdir/example.txt";

# Server
my $sdbg_mloop    = 0;
my $sdbg_iloop    = 0;
my $sdbg_fwink    = 0;
my $b_stop_fwink  = 0;			# Kill fwink when last client exits
my $imgfile       = "pic.jpg";
my $imgpath       = "$topdir/$imgfile"; 
my $imgcopy       = "$topdir/copy.jpg";
my $startimg      = "mousecam.xpm";
my $interval      = 1;
my $ftp_temp      = "tmp.jpg";

# Client / Playback
my $b_hidden      = 1;				# Options initially hidden
my $df_b_fetch    = 1;				# Initially fetch images
my $df_b_save     = 1;				# Initially save images
my $df_b_show     = 1;				# Initially show images
my $df_b_ftp      = 1;				# Initially do NOT FTP images
my $df_savetime   = 5;				# Initially save every 5 seconds
my $df_showtime   = 5;				# Initially show every 5 seconds
my $df_maxsave    = 600;			# 10 minutes worth of images
my $ftp_min       = 30;				# Mininum ftp interval is 30 seconds
my $df_ftptime    = $ftp_min;		# Set ftp to to minimum allowable
my $iwidth        = 640;			# Width of a single image
my $iheight       = 480;			# Height of a single image
my $max_servers   = 4;				# Maximum supported servers (cameras)
my $max_delay     = 0.5;			# Delay at minimum playback speed


#################
### Libraries ###
#################
use Data::Dumper;
use File::Copy;
use FileHandle;
use File::Basename;
use Getopt::Long;
use IO::Socket;
use IO::Select;
use MIME::Base64;
use Net::FTP;
use Sys::Hostname;
use Time::HiRes qw/ gettimeofday tv_interval /;
use Tk;
use Tk::Dialog;
use Tk::DialogBox;
use Tk::JPEG;
use Tk::ROText;


###############
### Globals ###
###############
$| = 1;
my $iam = basename $0;
my $dflt_disp   = 1;
my $b_playback  = 0;
my $b_beginpb   = 0;
my $pb_start    = 0;
my $ps = { };	# Server global variables
my $pc = { };	# Client global variables
my $syntax = "
    syntax:  $iam  [switches]  'server'
        or:  $iam  [switches]  <address|profile>  [address|profile]

    When the string 'server' is given, the program starts in server mode.

    When one or more IP addresses are given, the program starts in client
    mode, and connects to the server at each address.   In place of an IP
    address  a  'profile' name may be given, which  is  the  base name of
    a  file ending  in '.txt' that contains parameter/value pairs for use
    with the corresponding server.  When the client  first starts, a file
    'example.txt' is created documenting each of these parameters.

    When the switch -p is given in conjunction with a directory name, the
    program runs in 'playback' mode,  where images save to that directory
    are replayed, either one at a time (single-step), or as a time-sliced
    movie (at varying speeds).

    Playback Mode Switches:
        -p ........... begin playback immediately
        -b ........... begin playback immediately
        -i <X>[,Y] ... start playing image <X>, or from <X> to <Y>

";


####################
### Command-line ###
####################
Getopt::Long::Configure("bundling");
my $go = GetOptions(
 	"p"   => \$b_playback,
 	"b"   => \$b_beginpb,
	"i=s" => \$pb_start,
);
$go or die $syntax;


####################
### Main program ###
####################

if (!-e $topdir) {
	(mkdir $topdir) or die "$iam:  failed to create '$topdir' ($!)\n";
}
(chdir $topdir) or die "$iam:  failed to change to '$topdir' ($!)\n";

create_example_file();
my $arg = $ARGV[0] or die $syntax;
if ($ARGV[0] eq 'server') {
	# Server mode
	start_server();
} else {
	# Client/Playback mode
	if ($b_playback) {
		playback_gui($arg);
	} else {
		start_client(@ARGV);
	}
}


###################
### Subroutines ###
###################

sub start_server {
	my $sock = server_socket($srvrport, 4);
	my $sel  = new IO::Select($sock);

	$ps->{'socket'}    = $sock;
	$ps->{'select'}    = $sel;
	$ps->{'clients'}   = { };
	$ps->{'lastsize'}  = 0;

	server_main_loop();
}


sub server_main_loop {
	while (1) {
		my $nclients = service_clients();
		if ($nclients) {
			$sdbg_mloop and print "Serviced $nclients client(s)\n";
		}

		my $pproc = $ps->{'fwink_process'} || 0;
		if ($pproc) {
			$sdbg_mloop and print "Entering image-servicing loop\n";
			server_imaging_loop();
		}

		select(undef, undef, undef, 0.1);
	}
}


sub service_clients {
	my $sock     = $ps->{'socket'};
	my $sel      = $ps->{'select'};
	my $pclients = $ps->{'clients'};

	my @ready  = $sel->can_read(0);
	my $nserviced = 0;

	foreach my $fh (@ready) {
		if ($fh == $sock) {
			# Create a new socket
			handshake_with_client($pclients, $fh, $sel);
		} else {
			# Process client command
			service_client($pclients, $fh, $sel);
			++$nserviced;
		}
	}

	return $nserviced;
}


sub service_client {
	my ($pclients, $sock, $sel) = @_;
	my $pinfo = $pclients->{$sock};
	my $nclients = (keys %$pclients);

	my $input = <$sock> || "";
	if (!$input) {
		server_put_socket($sock, "Finished all requests", 1);
		return close_this_socket($pclients, $sock, $sel);
	}

	chomp $input;

	($input eq 'image')   and return server_put_image($sock);
	($input eq 'start')   and return server_start_fwink($sock);
	($input eq 'stop')    and return server_stop_fwink($sock);
	($input eq 'restart') and return server_restart_fwink($sock);

	server_put_socket($sock, "Unknown client request '$input'");
}


sub server_imaging_loop {
# States:
#
#     0 = initial state -- waiting for image modification time to change
#     1 = modification time changed -- waiting for image to be copied
#     2 = image copied -- waiting to service client request
#     3 = no client requests waiting
#     4 = client imaging request serviced
#
	my $state  = 0;

	copy($imgpath, $imgcopy);
	my $lastmod  = (stat $imgcopy)[9];
	my $lasttime = time;

	my $mtime  = 0;
	my $nticks = 1;

	$sdbg_iloop and print "START imaging loop\n";
	while (1) {
		my $newtime = time;

		my $pclients = $ps->{'clients'};
		my $nclients = scalar keys %$pclients;
		$sdbg_iloop and print "$nclients client(s) connected\n";

		if ($b_stop_fwink) {
			if (0 == $nclients) {
				server_stop_fwink();
				$sdbg_iloop and print "END imaging loop (no clients)\n\n";
				return;
			}
		}

		my $pproc = $ps->{'fwink_process'} || 0;
		if (!$pproc) {
			$sdbg_iloop and print "END imaging loop (fwink stopped)\n\n";
			return;
		}

		if ($newtime - $lasttime >= $interval) {
			$lasttime = $newtime;
			$nticks = 1;
			$sdbg_iloop and print "\nNEW imaging loop\n";
		}

		$sdbg_iloop and printf " %3d - ", $nticks;
		if (0 == $state or $state > 2) {
			$state = 0;
			$mtime = (stat $imgpath)[9] || 0;
			if (!$mtime or $lastmod == $mtime) {
				# Image not yet written, or no modification
				$sdbg_iloop and print "[$state] no new image\n";
			} else {
				$state = 1;
				$sdbg_iloop and print "[$state] modified ($lastmod/$mtime)\n";
			}
		} elsif (1 == $state) {
			$state = 2;
			copy($imgpath, $imgcopy);
			$sdbg_iloop and print "[$state] image copied\n";
			$lastmod = $mtime;
		} elsif (2 == $state) {
			my $nclients = service_clients();
			if (!$nclients) {
				$state = 3;
				$sdbg_iloop and print "[$state] no client requests\n";
			} else {
				$state = 4;
				$sdbg_iloop and print "[$state] clients serviced\n";
			}
		}

		++$nticks;

		select(undef, undef, undef, 0.05);
	}
}


sub server_socket {
	my ($port, $max) = @_;

	my $host = hostname();

	my %params = (
		'LocalHost' => $host,
		'LocalPort' => $port,
		'Proto'     => 'tcp',
		'Listen'    => $max,
		'ReuseAddr' => 0,
	);

	my $sock;
	my $ntry = 0;

	$sock = new IO::Socket::INET(%params);
	$sock or die "$iam:  ERROR -- port $port is already in use\n";

	warn "\n[Server connected on localhost '$host', port $port]\n";
	return $sock;
}


sub handshake_with_client {
	my ($pclients, $fh, $sel) = @_;
	my $new = $fh->accept();
	$sel->add($new);
	my $peer = getpeername($new);
	$peer or die "$iam:  unable to get peer name for $new\n";

	my ($port, $iaddr) = unpack_sockaddr_in($peer);
	my $remote = inet_ntoa($iaddr);

	print STDERR "\n[Connection from $remote on port $port]\n";
	my $pinfo = { 'remote' => $remote };

	# Get the header
	while (1) {
		my $text = <$new>;
		if ($text) {
			chomp $text;
			last if ($text eq '#');
			if ($text !~ /^#(.+)=(.+)/) {
				# Bad header
				die "$iam:  ERROR -- bad header\n";
			}
			my ($key, $val) = ($1, $2);
			$pinfo->{$key}  = $val;
		}
	}

	my $name = $pinfo->{'name'} = ($pinfo->{'host'} || "IP-$remote");
	(my $ts = localtime(time)) =~ s/(\S+\s+){3}(\S+).*/$2/;
	print STDERR "\n[$ts - Welcome '$name' ($remote) at port $port]\n";

	$pclients->{$new} = $pinfo;
	server_put_socket($new, "Welcome from Server!", 1);
}


sub server_put_socket {
	my ($sock, $plines, $b_done) = @_;
	(ref $plines eq 'ARRAY') or $plines = [ $plines ];
	(my $ts = localtime(time)) =~ s/(\S+\s+){3}(\S+).*/$2/;
	foreach my $msg (@$plines) {
		my $text = "[$ts] ";
		$text .= "$msg\n";
		print $sock $text;
	}
	($b_done || 0) and print $sock "#\n";	# Done talking
}


sub server_put_image {
	my ($sock) = @_;

	my $fh = new FileHandle;
	my $data = "";

	if (open($fh, "<", $imgcopy)) {
		binmode $fh;
		while (read($fh, $data, 60 * 57)) {
			print $sock encode_base64($data), "\n";
		}
	}

	print $sock "#\n";
	close $fh;
	return 0;
}


sub server_start_fwink {
	my ($sock) = @_;
	$sdbg_fwink and print "\nStarting FWINK\n";

    use Win32::Process;
    use Win32;
	
	my $flags = 0;
	my $pproc = $ps->{'fwink_process'} || 0;

	if ($pproc) {
		print "Fwink is already running -- no need to start it\n";
	} else {
		my $dir   = ".";
		my $res   = Win32::Process::Create(
			$pproc, $fwinkprog, "", 0, $flags, $dir
		);
		if (!$res) {
			print "Attempt to start Fwink FAILED in Win32::Process::Create\n";
			($sock || 0) and print $sock "#\n";
			return;
		}

		$ps->{'fwink_process'} = $pproc;
	}

	($sock || 0) and print $sock "#\n";
	return 0;
}


sub server_stop_fwink {
	my ($sock) = @_;
	$sdbg_fwink and print "\nStopping FWINK\n";

	use Win32::Process;
	use Win32;

	my $pproc = $ps->{'fwink_process'} || 0;
	if (!$pproc) {
		print "Fwink is not running -- no need to stop it\n";
		($sock || 0) and print $sock "#\n";
	} else {
		$pproc->Kill(0);
		$ps->{'fwink_process'} = 0;
	}
	($sock || 0) and print $sock "#\n";
}


sub server_restart_fwink {
	my ($sock) = @_;
	$sdbg_fwink and print "\nRestarting FWINK\n";

    use Win32::Process;
    use Win32;

	server_stop_fwink($sock);
	server_start_fwink($sock);
	($sock || 0) and print $sock "#\n";
}


sub close_this_socket {
	my ($pclients, $fh, $sel) = @_;
	my $pinfo = $pclients->{$fh};
	my $remote = $pinfo->{'remote'};
	my $name   = $pinfo->{'name'};
	$sel->remove($fh);
	$fh->close;
	delete $pclients->{$fh};
	(my $ts = localtime(time)) =~ s/(\S+\s+){3}(\S+).*/$2/;
	warn "[$ts - Remote host '$name' [$remote] disconnected]\n";
}


sub start_client {
	my (@addrs) = @_;

	if (@addrs > $max_servers) {
		die "$iam:  only $max_servers server(s) are supported\n";
	}

	# Debugging info
	$pc->{'fetchsum'} = 0;
	$pc->{'nfetch'}   = 0;

	# Assign client information
	$pc->{'servers'} = [ ];
	$pc->{'server'}  = { };
	map { client_parameters($_) } @addrs;

	my $pservers = $pc->{'servers'};	# Entire server list
	my $pserver  = $pc->{'server'};		# This server address
	foreach my $label (@$pservers) {
		my $pthis = $pserver->{$label};
		my $idx   = $pthis->{'index'};
	}

	# Global parameters
	(my $name = ucfirst $iam) =~ s/\.pl$//;
	$pc->{'name'} = $name;			# Assign program name

	my $title = "$name v$version  --  December 2007 by John C. Norton";
	$pc->{'title'} = $title;
	$pc->{'mw'} = my $mw = new MainWindow(-title => $title);

	# Top-level frames
	my $top    = frame($mw,  '1bt');	# Top-most frame
	my $imgfr  = frame($top, '0blg4');	# Image frame
	my $otherf = frame($top, '0blg4');	# User-settings frame

	# Create image frames and labels
	my $nservers = $pc->{'nservers'};

	my $width    = (1 == $nservers)? $iwidth:  $iwidth  / 2;
	my $height   = (1 == $nservers)? $iheight: $iheight / 2;
	my $imgleft  = frame($imgfr, '0bl');
	my $imgright = frame($imgfr, '0bl');
	my $ppics    = [ ];

	# Assign picture labels for each server (camera)
	if (1 == $nservers) {
		$ppics->[0] = label($imgleft,  "", 0, 0, '0nt');
	} elsif (2 == $nservers) {
		$ppics->[0] = label($imgleft,  0);
		$ppics->[1] = label($imgleft,  0);
		$imgright->packForget();
	} else {
		$ppics->[0] = label($imgleft,  0);
		$ppics->[2] = label($imgleft,  0);
		$ppics->[1] = label($imgright, 0);
		$ppics->[3] = label($imgright, 0);
	}

	# Display the starting graphic
	$pc->{'pic'} = $ppics->[0];
	starting_image($pc);

	# Setup frames
	my $showfr = frame($otherf, '0xt');		# Hide/unhide button
	my $usrfr  = frame($otherf, '0bt');		# All other options
	my $commfr = frame($usrfr,  '0xtg2');	# Common option frame
	my $srvrfr = frame($usrfr,  '0xtg2');	# Server list frame
	my $optfr  = frame($usrfr,  '0xtS');	# Options frame
	my $opt0   = frame($optfr,  '0xtg2');	#  - Server list
	my $opt1   = frame($optfr,  '0xtg2');	#  - Fetch options
	my $opt2   = frame($optfr,  '0xtg2');	#  - Save options
	my $opt3   = frame($optfr,  '0xtg2');	#  - Show options
	my $opt4   = frame($optfr,  '0xtg2');	#  - Upload options

	# Common options
	my $btnfr = frame($commfr, '0nt');
	my $pexit = $pc->{'exit'} = exit_button($btnfr, 8);

	# Hide options
	$b_hidden and $usrfr->packForget();
	$b_hidden  or $showfr->packForget();
	my $phide = sub { $usrfr->packForget;  $showfr->pack; $mw->update };
	my $pshow = sub { $showfr->packForget; $usrfr->pack;  $mw->update };
	my $hidebtn = button($btnfr, '<<< Hide', 8, 0);
	$hidebtn->configure(-bg => 'yellow');
	my $showbtn = $showfr->Button(-text => ">>", -bg => 'yellow');
	$showbtn->pack(-side => 'top', -expand => 1, -fill => 'x');
	button($showfr, "^Exit", 0,  0, $pexit);
	$hidebtn->configure(-command => sub { $phide->() });
	$showbtn->configure(-command => sub { $pshow->() });

	# Server list
	if (1 == $nservers) {
		label($srvrfr, $pservers->[0], 0, 0, '0xt');
	} elsif (2 == $nservers) {
		label($srvrfr, "(1) " .$pservers->[0], 0, 0, '0xtg1');
		label($srvrfr, "(2) " .$pservers->[1], 0, 0, '0xtg1');
	} else {
		my $sleft  = frame($srvrfr, '1bl');
		my $sright = frame($srvrfr, '1bl');
		for (my $i = 0; $i < 4; $i++) {
			my $frm = (0 == $i % 2)? $sleft: $sright;
			my $srv = $pservers->[$i];
			my $txt = ($srv || 0)? (sprintf "(%d)  $srv", $i+1): "";
			label($frm, $txt, 0, 0, '0xtg1');
		}
	}

	# Configure labels for each parameter
	my $lblwidth = 8;
	my $optwidth = 6;
	my $lpack    = '0xl';
	my $f0  = frame($opt0, '0xt', $lblwidth, 0, "  Server", 0, $lpack);
	my $f1  = frame($opt1, '0xt', $lblwidth, 0, "   Fetch", 0, $lpack);
	my $f2  = frame($opt1, '0xt', $lblwidth, 0, "    Last", 0, $lpack);
	my $f3  = frame($opt2, '0xt', $lblwidth, 0, "    Save", 0, $lpack);
	my $f4  = frame($opt2, '0xt', $lblwidth, 0, "Interval", 0, $lpack);
	my $f5  = frame($opt2, '0xt', $lblwidth, 0, "  Number", 0, $lpack);
	my $f6  = frame($opt2, '0xt', $lblwidth, 0, " Maximum", 0, $lpack);
	my $f7  = frame($opt2, '0xt', $lblwidth, 0, "    Last", 0, $lpack);
	my $f8  = frame($opt2, '0xt', $lblwidth, 0, " Options", 0, $lpack);
	my $f9  = frame($opt3, '0xt', $lblwidth, 0, "    Show", 0, $lpack);
	my $f10 = frame($opt3, '0xt', $lblwidth, 0, "Interval", 0, $lpack);
	my $f11 = frame($opt3, '0xt', $lblwidth, 0, "    Last", 0, $lpack);
	my $f12 = frame($opt3, '0xt', $lblwidth, 0, " Options", 0, $lpack);
	my $f13 = frame($opt4, '0xt', $lblwidth, 0, "  Upload", 0, $lpack);
	my $f14 = frame($opt4, '0xt', $lblwidth, 0, "Interval", 0, $lpack);
	my $f15 = frame($opt4, '0xt', $lblwidth, 0, "    Last", 0, $lpack);
	my $f16 = frame($opt4, '0xt', $lblwidth, 0, " Options", 0, $lpack);

	# Configure a separate column for parameters for each server
	for (my $i = 0; $i < $nservers; $i++) {
		my $addr  = $pservers->[$i];
		my $pthis = $pserver->{$addr};
		my $ppic  = $ppics->[$i];
		$pthis->{'pic'}       = $ppic;
		$pthis->{'lastfetch'} = 'Never';
		$pthis->{'lastsave'}  = 'Never';
		$pthis->{'lastshow'}  = 'Never';
		$pthis->{'lastftp'}   = 'Never';

		get_saved_images($pthis);
		label($f0,  $i+1, $optwidth, 0, '0nlS');
		checkb($f1, 'On',  0, \$pthis->{'fetch'}, '1xl');
		frame($f1,  '0nl', $optwidth, 0);
		my $lb = label($f2,  \$pthis->{'lastfetch'}, $optwidth, 0, '1xl');
		checkb($f3, 'On',   0, \$pthis->{'save'},  '1xl');
		label($f4,  \$pthis->{'savetime'}, $optwidth, 0, '1xl');
		label($f5,  \$pthis->{'nsaved'},   $optwidth, 0, '1xl');
		label($f6,  \$pthis->{'maxsave'},  $optwidth, 0, '1xl');
		label($f7,  \$pthis->{'lastsave'}, $optwidth, 0, '1xl');
		button($f8, '<Change', $optwidth, 0, sub { save_options($pthis) });
		checkb($f9, 'On',   0, \$pthis->{'show'},  '1xl');
		label($f10, \$pthis->{'showtime'}, $optwidth, 0, '1xl');
		label($f11, \$pthis->{'lastshow'}, $optwidth, 0, '1xl');
		button($f12, '<Change', $optwidth, 0, sub { show_options($pthis) });
		checkb($f13, 'On',   0, \$pthis->{'ftp'},  '1xl');
		label($f14, \$pthis->{'ftptime'}, $optwidth, 0, '1xl');
		label($f15, \$pthis->{'lastftp'}, $optwidth, 0, '1xl');
		button($f16, '<Change', $optwidth, 0, sub { ftp_options($pthis) });
	}

	$pc->{'after'} = $mw->after(100 => sub { client_initialize() });
	MainLoop;
}


sub client_parameters {
	my ($arg) = @_;

	my $pthis = { };
	my $label;
	my $addr;

	if ($arg =~ /^(\d+\.\d+\.\d+\.\d+)$/) {
		$label = $addr = $arg;
		my $text = create_example_file();
		$pthis = parse_key_value_pairs($text);
		$pthis->{'pparams'} = [ keys %$pthis ];
		$pthis->{'cmdfile'} = 0;
	} else {
		$label = $arg;
		my $fname = $label;
		($fname =~ /\.txt$/i) or $fname .= ".txt";
		my $fh = new FileHandle;
		open($fh, "<", $fname) or die "$iam:  can't read '$fname' ($!)\n";
		undef local $/;
		my $text = <$fh>;
		close $fh;
		$pthis = parse_key_value_pairs($text);
		$pthis->{'pparams'} = [ keys %$pthis ];
		$pthis->{'cmdfile'} = $fname;
		$addr = $pthis->{'address'};
		if (!defined $addr) {
			die "$iam:  'ADDRESS' is undefined in file '$fname'\n";
		}
	}

	$pthis->{'address'} = $addr;
	$pthis->{'images'}  = $label;

	my $pservers = $pc->{'servers'};	# Entire server list
	my $pserver  = $pc->{'server'};		# This server address
	if (exists($pserver->{$label})) {
		die "$iam:  label '$label' multiply defined\n";
	}

	# Assign defaults
	defined($pthis->{'fetch'})    or $pthis->{'fetch'}    = $df_b_fetch;
	defined($pthis->{'save'} )    or $pthis->{'save'}     = $df_b_save;
	defined($pthis->{'show'})     or $pthis->{'show'}     = $df_b_show;
	defined($pthis->{'ftp'})      or $pthis->{'ftp'}      = $df_b_ftp;
	defined($pthis->{'savetime'}) or $pthis->{'savetime'} = $df_savetime;
	defined($pthis->{'showtime'}) or $pthis->{'showtime'} = $df_showtime;
	defined($pthis->{'maxsave'})  or $pthis->{'maxsave'}  = $df_maxsave;
	defined($pthis->{'ftptime'})  or $pthis->{'ftptime'}  = $df_ftptime;
	defined($pthis->{'target'})   or $pthis->{'target'}   = '.';
	defined($pthis->{'file'})     or $pthis->{'file'}     = $imgfile;

	push @$pservers, $label;
	$pthis->{'index'} = $pc->{'nservers'}++;
	$pserver->{$label} = $pthis;
}


sub parse_key_value_pairs {
	my ($text) = @_;
	my @text  = split("\n", $text);
	my $pparams = { };
	foreach my $line (@text) {
		next if ($line =~ /^\s*(#|$)/);
		next if ($line !~ /(\S+)\s+(\S+)/);
		my ($key, $val) = (lc $1, $2);
		$pparams->{$key} = $val;
	}

	return $pparams;
}


sub exit_button {
	my ($w, $width) = @_;
	my $mw = $pc->{'mw'};
	my $pexit = sub {
		my ($msg) = @_;
		$pc->{'b_stop_play'} = 1;
		($pc->{'b_playing'} || 0) and return;
		($msg || 0) and print STDERR "$iam:  $msg\n";
		$pc->{'done'} = 1;
	};

	button($w, '>Exit', $width, 'Esc', $pexit);
	return $pexit;
}


sub playback_gui {
	my $imgdir = shift;

	(my $name = ucfirst $iam) =~ s/\.pl$//;

	$pc->{'name'}      = $name;			# Assign program name
	$pc->{'showtime'}  = $df_showtime;	# How often do we save images?
	$pc->{'images'}    = $imgdir;		# Initialize playback image directory
	$pc->{'b_loop'}    = 0;				# Loop during playback?
	$pc->{'b_reverse'} = 0;				# Loop during playback?

	my $title = "$name v$version  --  December 2007 by John C. Norton";
	my $mw = new MainWindow(-title => $title);
	$pc->{'mw'} = $mw;

	$pc->{'top'} = my $top = frame($mw, '1bt');
	my $imgfr = frame($top, '0blg4');
	my $usrfr = frame($top, '0blg4');

	my $ppic = label($imgfr,  "", 0, 0, '0nt');
	$pc->{'pic'} = $ppic;
	starting_image($pc);

	my $btnfr = frame($usrfr, '0nt');
	$pc->{'exit'} = exit_button($btnfr, 8);

	get_saved_images($pc, 1);

	filler($usrfr, 0, 8, '0nt');
	my $f1 = frame($usrfr, '0xtS');
	my $psaved = $pc->{'psaved'};
	my $nsaved = $pc->{'nsaved'};

	$nsaved or die "$iam:  no saved images in '$imgdir'\n";
	my $stotal = $nsaved;
	my $first = $psaved->[0];
	my $last  = $psaved->[-1];
	$pc->{'stotal'}  = $stotal;
	my $sfirst = $pc->{'first'} = $first;
	my $slast  = $pc->{'last'}  = $last;

	if ($pb_start || 0) {
		if ($pb_start =~ s/(\d+)//) {
			$sfirst = $1;
			($pb_start =~ s/,(\d+)//) and $slast = $1;
			($sfirst < $first or $sfirst > $last) and $sfirst = $first;
			($slast  < $first or $slast  > $last) and $slast  = $last;
		}
	}

	$pc->{'sfirst'}  = $sfirst;
	$pc->{'slast'}   = $slast;
	$pc->{'current'} = $sfirst;

	label($f1,  "'$imgdir'",  0, 'gold', '0xt');
	labent($f1, "Total images",   12 , \$nsaved,          8, '1bt', 0, 1);
	labent($f1, "First image",    12 , \$pc->{'first'},   8, '1bt', 0, 1);
	labent($f1, "Last image",     12 , \$pc->{'last'},    8, '1bt', 0, 1);
	labent($f1, "Total selected", 12 , \$pc->{'stotal'},  8, '1bt', 0, 1);
	labent($f1, "Selected first", 12 , \$pc->{'sfirst'},  8, '1bt', 0, 1);
	labent($f1, "Selected last",  12 , \$pc->{'slast'},   8, '1bt', 0, 1);
	labent($f1, "Current image",  12 , \$pc->{'current'}, 8, '1bt', 0, 1);
	filler($usrfr, 0, 8, '0nt');

	my $f2 = frame($usrfr, '0xtS');
	my $f3 = frame($f2, '1nt');
	my $f4 = frame($f2, '1nt');

	checkb($f3, '  Loop   ', 12, \$pc->{'b_loop'},    '0nl');
	checkb($f4, '  Reverse', 12, \$pc->{'b_reverse'}, '0nl');

	my $f5 = frame($f2, '1nt');
	my $f6 = frame($f2, '1nt');
	my $f7 = frame($f2, '1xt');
	my $f8 = frame($f2, '1xt');

	begin_button($f5,  "0xl", sub { playback($pc->{'sfirst'}) });
	$pc->{'startxpm'} = start_playback_image();
	$pc->{'stopxpm'}  = stop_playback_image();
	my $b1 = $f5->Button()->pack(-side => 'left');
	$mw->bind("<Return>" => sub { $b1->invoke });
	my $pbsub = sub { playback_all($b1) };
	$b1->configure(-image => $pc->{'startxpm'}, -command => $pbsub);
	end_button($f5,  "0xl", sub { playback($pc->{'slast'}) });

	step_back_button($f6,  "0xl", sub { playback(0, -1) });
	pick_image_button($f6, "0xl", sub { pick_image($pc) });
	step_ahead_button($f6, "0xl", sub { playback(0, 1) });

	$pc->{'chosen'} = $pc->{'current'};
	my $prange = [ $sfirst, $slast ];
	my $sc = scale($f7, '-Current Image', \$pc->{'chosen'}, $prange, '1xb');
	$pc->{'iscale'} = $sc;

	$prange = [ 0, 100 ];
	$pc->{'speed'} = 100;
	$sc = scale($f8, '-Playback Speed', \$pc->{'speed'}, $prange, '1xb');
	$pc->{'sscale'} = $sc;

	# Start playing all, or playback first image
	if ($b_beginpb) {
		$pbsub->();
	} else {
		playback($pc->{'current'}, 0);
	}

	$mw->repeat(200 => sub { playback_main_loop() });
	MainLoop;
}


sub fatal_error {
	my ($msg) = @_;
	my $mw = $pc->{'mw'};
	$mw->destroy;
	die "$iam:  ERROR -- $msg\n";
}


sub get_saved_images {
	my ($pthis, $b_dir_must_exist) = @_;

	my $fh = new FileHandle;
	my $imgdir = $pthis->{'images'};
	if (!-d $imgdir) {
		if ($b_dir_must_exist || 0) {
			fatal_error("no such directory '$imgdir'");
		}
		mkdir $imgdir;
	}

	my @indices = ( );
	if (-d $imgdir and opendir($fh, $imgdir)) {
		my @files = readdir($fh);
		closedir($fh);

		foreach my $file (@files) {
			next if ($file eq '.' or $file eq '..');
			if ($file =~ /(\d+)/) {
				my $idx = $1;
				push @indices, $idx;
			}
		}
	}

	$pthis->{'psaved'}  = my $psaved = [ sort { $a <=> $b } @indices ];
	$pthis->{'nsaved'} = 0 + @$psaved;
}


sub clear_saved {
	my ($pthis) = @_;
	get_saved_images($pthis);
	my $psaved = $pthis->{'psaved'};
	my $nsaved = @$psaved;

	($nsaved > 0) or return;
	my ($verb, $noun, $pronoun) = ("are", "images", "them");
	(1 == $nsaved) and ($verb, $noun, $pronoun) = ("is", "image", "it");

	my $mw = $pc->{'mw'};
	my $dbtitle = "Confirm file deletion";
	my $pbtns   = [ "Okay", "Cancel" ];
	my $dbtext  = "There $verb $nsaved $noun.\n";
	$dbtext    .= "Do you REALLY want to delete $pronoun?";
	my @dbopts  = (-title => $dbtitle, -buttons => $pbtns, -text => $dbtext);
	my $db = $mw->Dialog(@dbopts);
	my $res = $db->Show();
	$mw->update();
	($res eq 'Okay') or return;

	my $imgdir = $pthis->{'images'};
	foreach my $idx (@$psaved) {
		my $path = "$imgdir/$idx.jpg";
		unlink $path;
	}
	$pthis->{'psaved'}  = [ ];
	$pthis->{'nsaved'} = 0;
}


sub save_options {
	my ($pthis) = @_;
	my $addr    = $pthis->{'address'};
	my $mw      = $pc->{'mw'};
	my $dbtitle = "Change SAVE options";
	my $pbtns   = [ "Okay", "Cancel" ];
	my @dbopts  = (-title => $dbtitle, -buttons => $pbtns);
	my $db = $mw->DialogBox(@dbopts);

	my $f0 = $db->add('Frame', -width => 80);
	packit($f0, '1bt');

    my $f1 = $db->add('Frame', -width => 80);
	packit($f1, '1bt');

	my $b_save   = $pthis->{'save'};
	my $savetime = $pthis->{'savetime'} || 1;
	my $maxsave  = $pthis->{'maxsave'};
	my $cmdfile  = $pthis->{'cmdfile'}  || 0;
	my $b_file   = 0;

	checkb($f0, 'Save images',    16, \$b_save,    '0xl');
	checkb($f0, "Update '$cmdfile'", 16, \$b_file, '0xl') if $cmdfile;

	labent($f1, 'Save interval', 16, \$savetime, 24, '0xt');
	labent($f1, 'Maximum save',  16, \$maxsave,  24, '0xt');

	my $res = $db->Show();
	$mw->update();
	($res eq 'Okay') or return;

	# Fix bad parameters
	($savetime =~ /^(\d+)$/) or $savetime = 1;
	($maxsave  =~ /^(\d+)$/) or $maxsave  = $df_maxsave;
	
	$pthis->{'save'}     = $b_save;
	$pthis->{'savetime'} = $savetime || 1;
	$pthis->{'maxsave'}  = $maxsave;

	$b_file and update_cmd_file($pthis);

	$mw->update();
}


sub show_options {
	my ($pthis) = @_;
	my $addr    = $pthis->{'address'};
	my $mw      = $pc->{'mw'};
	my $dbtitle = "Change SHOW options";
	my $pbtns   = [ "Okay", "Cancel" ];
	my @dbopts  = (-title => $dbtitle, -buttons => $pbtns);
	my $db = $mw->DialogBox(@dbopts);

	my $f0 = $db->add('Frame', -width => 80);
	packit($f0, '1bt');

    my $f1 = $db->add('Frame', -width => 80);
	packit($f1, '1bt');

	my $b_show   = $pthis->{'show'};
	my $showtime = $pthis->{'showtime'} || 1;
	my $cmdfile  = $pthis->{'cmdfile'}  || 0;
	my $b_file   = 0;

	checkb($f0, 'Show images',   16, \$b_show,     '0xl');
	checkb($f0, "Update '$cmdfile'", 16, \$b_file, '0xl') if $cmdfile;

	labent($f1, 'Show interval', 16, \$showtime, 24, '0xt');

	my $res = $db->Show();
	$mw->update();
	($res eq 'Okay') or return;

	# Fix bad parameters
	($showtime =~ /^(\d+)$/) or $showtime = 1;
	
	$pthis->{'show'}     = $b_show;
	$pthis->{'showtime'} = $showtime || 1;

	$b_file and update_cmd_file($pthis);

	$mw->update();
}


sub ftp_options {
	my ($pthis) = @_;
	my $addr    = $pthis->{'address'};
	my $mw      = $pc->{'mw'};
	my $dbtitle = "Change FTP options";
	my $pbtns   = [ "Okay", "Cancel" ];
	my @dbopts  = (-title => $dbtitle, -buttons => $pbtns);
	my $db = $mw->DialogBox(@dbopts);

	my $f0 = $db->add('Frame', -width => 80);
	packit($f0, '1bt');

    my $f1 = $db->add('Frame', -width => 80);
	packit($f1, '1bt');

	my $b_ftp    = $pthis->{'ftp'};
	my $ftptime  = $pthis->{'ftptime'} || $ftp_min;
	my $host     = $pthis->{'host'};
	my $user     = $pthis->{'user'};
	my $password = $pthis->{'password'};
	my $target   = $pthis->{'target'};
	my $file     = $pthis->{'file'};
	my $cmdfile  = $pthis->{'cmdfile'}  || 0;
	my $b_file   = 0;

	checkb($f0, 'FTP Upload images', 16,  \$b_ftp, '0xl');
	checkb($f0, "Update '$cmdfile'", 16, \$b_file, '0xl') if $cmdfile;

	labent($f1, 'Frequency',   16, \$ftptime,   24, '0xt');
	labent($f1, 'Remote host', 16, \$host,      24, '0xt');
	labent($f1, 'User name',   16, \$user,      24, '0xt');
	labent($f1, 'Password',    16, \$password,  24, '0xt', 'X');
	labent($f1, 'Target dir',  16, \$target,    24, '0xt');
	labent($f1, 'Target name', 16, \$file,      24, '0xt');

	my $res = $db->Show();
	$mw->update();
	($res eq 'Okay') or return;

	# Fix bad parameters
	($ftptime =~ /^(\d+)$/)  or $ftptime = $ftp_min;
	($ftptime < $ftp_min)   and $ftptime = $ftp_min;
	$file ||= "pic.jpg";
	
	$pthis->{'ftp'}      = $b_ftp;
	$pthis->{'ftptime'}  = $ftptime || $ftp_min;
	$pthis->{'host'}     = $host;
	$pthis->{'user'}     = $user;
	$pthis->{'password'} = $password;
	$pthis->{'target'}   = $target;
	$pthis->{'file'} = $file;

	$b_file and update_cmd_file($pthis);

	$mw->update();
}


sub update_cmd_file {
	my ($pthis) = @_;
	my $cmdfile = $pthis->{'cmdfile'};
	($cmdfile || 0) or return;

	my $pparams = $pthis->{'pparams'};
	my $fh = new FileHandle;
	open($fh, ">", $cmdfile) or die "$iam:  can't write '$cmdfile' ($!)\n";
	foreach my $key (sort @$pparams) {
		my $val = $pthis->{$key};
		printf $fh "%-16.16s %s\n", uc $key, $val;
	}
	close $fh;
}


sub playback_main_loop {
	my $mw = $pc->{'mw'};
	my $curr = $pc->{'current'};
	my $sel  = $pc->{'chosen'};
	if ($curr != $sel) {
		playback($sel, 0);
	}
	$mw->update;

	($pc->{'done'} || 0) and finish();
}


sub playback_all {
	my ($btn) = @_;

	$pc->{'b_playing'}   = 1;
	$pc->{'b_stop_play'} = 0;
	my $pstop = sub { $pc->{'b_stop_play'} = 1 };

	$btn->configure(-command => $pstop);
	$btn->configure(-image   => $pc->{'stopxpm'});

	my $psaved = $pc->{'psaved'};
	my $sfirst = $pc->{'sfirst'};
	my $slast  = $pc->{'slast'};

	my $mw = $pc->{'mw'};
	$mw->update;

	my $idx = $pc->{'current'};
	while (1) {
		last if $pc->{'b_stop_play'};

		# Calculate the delay, based on speed from 0% to 100%
		my $speed = $pc->{'speed'};
		my $delay = $max_delay * (1 - $speed / 100);

		$pc->{'current'} = $idx;
		$pc->{'chosen'}  = $idx;

		# Show the image
		playback_this($idx);
		$mw->update();

		# Adjust image if the user moved the slider
		if ($idx != $pc->{'chosen'}) {
			$idx = $pc->{'current'} = $pc->{'chosen'};
		}

		my $b_reverse = $pc->{'b_reverse'};
		$idx = $b_reverse? ($idx - 1): ($idx + 1);

		if ($idx > $slast) {
			last unless $pc->{'b_loop'};
			$idx = $sfirst;
		} elsif ($idx < $sfirst) {
			last unless $pc->{'b_loop'};
			$idx = $slast;
		} else {
			$delay and select(undef, undef, undef, $delay);
		}
	}

	my $pbsub = sub { playback_all($btn) };
	$btn->configure(-command => $pbsub);
	$btn->configure(-image => $pc->{'startxpm'});
	$pc->{'b_playing'} = 0;
}


sub playback {
	my ($idx, $offset) = @_;

	my $psaved = $pc->{'psaved'};
	my $sfirst = $pc->{'sfirst'};
	my $slast  = $pc->{'slast'};
	$idx ||= $pc->{'current'};

	if ($offset || 0) {
		$idx += $offset;
		($idx < $sfirst) and $idx = $sfirst;
		($idx > $slast)  and $idx = $slast;
	}

	my $mw = $pc->{'mw'};
	$pc->{'current'} = $idx;
	$pc->{'chosen'}  = $idx;
	playback_this($idx);
	$mw->update();
}


sub playback_this {
	my ($idx) = @_;

	my $imgdir = $pc->{'images'};
	my $data  = "";
	my $fname = "$imgdir/$idx.jpg";
	my $fh    = new FileHandle;
	open($fh, "<", $fname) or return;

	binmode $fh;
	my $bytes = "";

	while (1) {
		my $count = sysread($fh, $bytes, 1024);
		(0 == $count) and last;
		$data .= $bytes;
	}

	close $fh;
	render_image($data, $pc);
}


sub pick_image {
	my ($pthis) = @_;

	($pthis->{'b_playing'} || 0) and return;

	my $mw      = $pthis->{'mw'};
	my $dbtitle = "Pick Images";
	my $pbtns   = [ "Okay", "Cancel" ];
	my @dbopts  = (-title => $dbtitle, -buttons => $pbtns);
	my $db = $mw->DialogBox(@dbopts);

	my $f0 = $db->add('Frame', -width => 80);
	packit($f0, '1bt');

    my $f1 = $db->add('Frame', -width => 80);
	packit($f1, '1bt');

	my $first   = $pthis->{'first'};
	my $last    = $pthis->{'last'};
	my $sfirst  = $pthis->{'sfirst'};
	my $slast   = $pthis->{'slast'};
	my $current = $pthis->{'current'};

	labent($f1, 'First image',    16, \$pc->{'first'}, 16, '0xt', 0, 1);
	labent($f1, 'Last image ',    16, \$pc->{'last'},  16, '0xt', 0, 1);
	labent($f1, 'Selected First', 16, \$sfirst,        16, '0xt', 0);
	labent($f1, 'Selected Last ', 16, \$slast,         16, '0xt', 0);
	labent($f1, 'Current Image',  16, \$current,       16, '0xt');

	my $res = $db->Show();
	$mw->update();
	($res eq 'Okay') or return;

	# Fix bad parameters
	($sfirst  =~ /^(\d+)$/) or $sfirst  = $pthis->{'sfirst'};
	($slast   =~ /^(\d+)$/) or $slast   = $pthis->{'slast'};
	($current =~ /^(\d+)$/) or $current = $pthis->{'current'};
	
	($sfirst < $first or $sfirst > $last) and $sfirst = $first;
	($slast  < $first or $slast  > $last) and $slast  = $last;
	($slast  < $sfirst) and $slast = $sfirst;
	($current < $sfirst or $current > $slast) and $current = $sfirst;
	$pthis->{'sfirst'} = $sfirst;
	$pthis->{'slast'}  = $slast;
	$pthis->{'current'} = $current;
	scale_range($pc->{'iscale'}, [ $sfirst, $slast ]);
	$pc->{'stotal'} = $slast - $sfirst + 1;

	$mw->update;
}


sub starting_image {
	my ($pthis) = @_;
	my $ppic = $pthis->{'pic'};

	my $mw = $pc->{'mw'};
	(-e $startimg) or create_graphic($startimg);
	my $newimg = $mw->Photo(-format => 'xpm', -file => $startimg);

	# Configure the label with the image; delete the old image
	$ppic->configure(-image => $newimg);
	my $oldimg = $pthis->{'img'} || 0;
	$oldimg and $oldimg->delete();
	$pthis->{'img'} = $newimg;
	$mw->update();
	select(undef, undef, undef, 1.0);
}


sub connect_to_server {
	my ($addr, $port) = @_;

	my %params = (
		'PeerAddr'  => $addr,
		'PeerPort'  => $port,
		'Proto'     => 'tcp',
		'ReuseAddr' => 1,
	);

	print "Connecting to server '$addr' on port $port ...\n";
	my $sock = new IO::Socket::INET(%params);
	if (!$sock) {
		my $err = 0 + $!;
		fatal_error("unable to connect to server '$addr' ($err)");
	}

	print "[Connected to $addr]\n";

	# Send header to server
	my $hostname = hostname();
	print $sock "#host=$hostname\n";
	print $sock "#\n";

	# Get server handshake
	client_get_socket($sock);
	return $sock;
}


sub client_put_socket {
	my ($sock, $command) = @_;
	print $sock "$command\n";
}


sub client_get_socket {
	my ($sock) = @_;

	while (1) {
		my $response = <$sock>;
		defined($response) or return 0;
		if ($response) {
			chomp $response;
			($response eq '#') and return 1;
			print "$response\n";
		} else {
			return -1;
		}
	}
}


sub client_get_image {
	my ($sock) = @_;

	my $data  = "";

	while (1) {
		my $input = <$sock>;
		if ($input) {
			chomp $input;
			($input eq '#') and return $data;
			$data .= decode_base64($input);
		}
	}
}


sub client_initialize {
	# Connect client to ALL servers
	my $pservers = $pc->{'servers'};
	my $pserver  = $pc->{'server'};
	my $nservers = @$pservers;

	$pc->{'lasttime'} = $pc->{'starttime'} = [ gettimeofday ];

	for (my $i = 0; $i < $nservers; $i++) {
		my $label = $pservers->[$i];
		my $pthis = $pserver->{$label};
		my $addr  = $pthis->{'address'};
		my $sock  = connect_to_server($addr, $srvrport);
		$pthis->{'socket'} = $sock;
		client_put_socket($sock, 'start');
		if (!client_get_socket($sock)) {
			fatal_error("server '$addr' went away");
		}
	}

	$pc->{'b_shrink'} = ($nservers > 1)? 1: 0;
	my $mw = $pc->{'mw'};
	$mw->update();

	client_gui_loop();
}


sub finish {
	(my $ts = localtime(time)) =~ s/(\S+\s+){3}(\S+).*/$2/;
	print STDERR "[$ts] Thanks for using " . $pc->{'name'} . "!\n";
	Tk::exit;
	exit;
}


sub client_gui_loop {
	my $mw = $pc->{'mw'};

	($pc->{'done'} || 0) and finish();

	my $elapsed = tv_interval($pc->{'lasttime'});

	if ($elapsed < 1.0) {
		$mw->update();
		$pc->{'after'} = $mw->after(50 => sub { client_gui_loop() });
		return;
	}

	# Use current timestamp for any updates
	(my $timestamp = localtime(time)) =~ s/.*\s(\d+:\d+:\d+).*/$1/;

	$pc->{'lasttime'} = [ gettimeofday ];
	my $delta         = tv_interval($pc->{'starttime'});
	my $title         = $pc->{'title'};
	$mw->configure(-title => "$title  --  $timestamp");

	my $pservers   = $pc->{'servers'};
	my $pserver    = $pc->{'server'};

	foreach my $addr (@$pservers) {
		my $pthis    = $pserver->{$addr};
		my $b_fetch  = $pthis->{'fetch'};
		my $sock     = $pthis->{'socket'};
		my $savetime = $pthis->{'savetime'} || 1;
		my $showtime = $pthis->{'showtime'} || 1;
		my $ftptime  = $pthis->{'ftptime'}  || 1;
		my $fname    = "";
		my $data     = 0;

		# See if we need to save an image
		my $b_save = $pthis->{'save'};
		if ($b_save) {
			my $savemark = $pthis->{'savemark'} || 0;
			$b_save = (!$savemark or $delta >= $savemark + $savetime);
			$b_save and $pthis->{'savemark'} = $delta;
		}

		# See if we need to show an image
		my $b_show = $pthis->{'show'};
		if ($b_show) {
			my $showmark = $pthis->{'showmark'} || 0;
			$b_show = (!$showmark or $delta >= $showmark + $showtime);
			$b_show and $pthis->{'showmark'} = $delta;
		}

		# See if we need to FTP an image
		my $b_ftp  = $pthis->{'ftp'};
		if ($b_ftp) {
			my $ftpmark = $pthis->{'ftpmark'} || 0;
			$b_ftp = (!$ftpmark or $delta >= $ftpmark + $ftptime);
			$b_ftp and $pthis->{'ftpmark'} = $delta;
		}

		# See if we need to fetch an image
		$b_fetch and $b_fetch = ($b_save || $b_show || $b_ftp)? 1: 0;

		if ($b_fetch) {
			client_put_socket($sock, 'image');
			$data = client_get_image($sock);
			$data and $pthis->{'lastfetch'} = $timestamp;
		}

		if ($data) {
			if ($b_save) {
				$fname = save_image($pthis, $data, 0);
				$pthis->{'lastsave'} = $timestamp;
			} elsif ($b_ftp) {
				$fname = save_image($pthis, $data, 1);
			}

			if ($b_show) {
				render_image($data, $pthis);
				$pthis->{'lastshow'} = $timestamp;
			}

			# Send file via FTP
			if ($fname and $b_ftp) {
				if (ftp_put_image($pthis, $fname)) {
					$pthis->{'lastftp'} = $timestamp;
				}
			}
		}
	}

	$pc->{'after'} = $mw->after(50 => sub { client_gui_loop() });
	$mw->update();
}


sub ftp_put_image {
	my ($pthis, $fname) = @_;

	my $host     = $pthis->{'host'};
	my $user     = $pthis->{'user'};
	my $password = $pthis->{'password'};
	my $target   = $pthis->{'target'};
	my $file     = $pthis->{'file'};

	my $ftp = Net::FTP->new($host);
	$ftp or return 0;

	if (!$ftp->login($user, $password)) {
		return 0;
	}

	$ftp->binary();

	if (!$ftp->cwd($target)) {
		return 0;
	}

	if (!$ftp->put($fname, $ftp_temp)) {
		return 0;
	}

	$ftp->delete($file);

	if (!$ftp->rename($ftp_temp, $file)) {
		return 0;
	}

	$ftp->close();
	return 1;
}


sub save_image {
	my ($pthis, $data, $b_tmp) = @_;

	# Calculate the next index number
	my $psaved = $pthis->{'psaved'} || [ ];
	my $imgdir = $pthis->{'images'};
	my $newidx = 1;
	if (@$psaved > 0 and $psaved->[-1] =~ /(\d+)/) {
		$newidx = $1 + 1;
	}

	# Open the jpeg file and write the image data
	my $fname = $b_tmp? "last.jpg": "$newidx.jpg";
	my $path  = "$imgdir/$fname";
	my $fh    = new FileHandle;
	if (!open($fh, ">", $path)) {
		return 0;
	}
	binmode $fh;
	my $offset = 0;
	my $total  = my $length = length($data);
	while (1) {
		my $size = $length - $offset;
		($size > 1024) and $size = 1024;
		my $buf   = substr($data, $offset, $size);
		my $count = syswrite($fh, $buf, $size);
		$offset += $size;
		last if ($offset >= $length);
	}
	close $fh;

	# Do pruning, etc. ONLY if not saving file temporarily ($b_tmp)
	if (!$b_tmp) {
		push @$psaved, $newidx;

		# Prune if necessary
		my $pruned = "";
		my $nprune = 0;
		while (@$psaved > $pthis->{'maxsave'}) {
			my $oldidx = shift @$psaved;
			$pruned = $oldidx;
			my $path = "$imgdir/$oldidx.jpg";
			unlink $path;
			++$nprune;
		}

		$pthis->{'psaved'}  = $psaved;
		$pthis->{'nsaved'} = @$psaved;
	}

	return $path;
}


sub render_image {
	my ($data, $pthis) = @_;
	my $mw   = $pc->{'mw'};
	my $ppic = $pthis->{'pic'};

	my $res;
	my $newimg;

	# Create the new image
	my $b_shrink = $pc->{'b_shrink'} || 0;

	my $enc = encode_base64($data);
	$res = eval { $newimg = $mw->Photo(-format => 'jpeg', -data => $enc) };

	undef $enc;
	undef $data;

	if (!($res || 0)) {
		warn "FAILED to render image\n";
		return 0;
	}

	if ($b_shrink) {
		my $w  = $iwidth  / 2;
		my $h  = $iheight / 2;
		my $imgcopy = $mw->Photo(-width => $w, -height => $h);
		$imgcopy->copy($newimg, -subsample, 2, 2);
		$newimg = $imgcopy;
		undef $imgcopy;
	}

	# Configure the label with the image; delete the old image
	$ppic->configure(-image => $newimg);
	my $oldimg = $pthis->{'img'} || 0;
	$oldimg and $oldimg->delete();
	$pthis->{'img'} = $newimg;
	$mw->update();
}


sub canvas {
	my ($w, $bg, $width, $height, $pack) = @_;
	my $can = $w->Canvas();
	($bg || 0) and $can->configure(-bg => $bg);
	$can->configure(-width => $width, -height => $height);
	$can->configure(-highlightthickness => 0);
	$can->pack();
	return packit($can, $pack);
}


sub label {
	my ($w, $text, $width, $bg, $pack, $font) = @_;
	my $label = $w->Label();
	($width || 0) and $label->configure(-width => $width);
	($bg    || 0) and $label->configure(-bg    => $bg);
	if ($text || 0) {
		(ref $text eq "") and $label->configure(-text    => $text);
		(ref $text eq "")  or $label->configure(-textvar => $text);
	}
	($font || 0) and $label->configure(-font => $font);
	return packit($label, $pack);
}


sub entry {
	my ($w, $text, $width, $bg, $pack) = @_;
	my $entry = $w->Entry();
	($width || 0) and $entry->configure(-width => $width);
	if ($bg eq '-') {
		$entry->configure(-relief => 'flat');
		$bg = $w->cget(-bg);
	}
	($bg || 0) and $entry->configure(-bg => $bg);
	if ($text || 0) {
		(ref $text eq "") and $entry->configure(-text    => $text);
		(ref $text eq "")  or $entry->configure(-textvar => $text);
	}
	return packit($entry, $pack);
}


sub frame {
	my ($w, $pack, $width, $height, $label, $lwidth, $lpack) = @_;
	my $frame = $w->Frame();
	($width  || 0) and $frame->configure(-width  => $width);
	($height || 0) and $frame->configure(-height => $width);
	if ($label || 0) {
		$lwidth  ||= length($label);
		$lpack   ||= '0nl';
		my $lb = label($frame, $label, $lwidth, 0, $lpack);
	}
	return packit($frame, $pack);
}


sub filler {
	my ($w, $width, $height, $pack) = @_;
	my $frame = $w->Frame();
	($width  || 0) and $frame->configure(-width  => $width);
	($height || 0) and $frame->configure(-height => $height);
	return packit($frame, $pack);
}


sub scale_range {
	my ($sc, $prange) = @_;
	my ($from, $to) = @$prange;
	$sc->configure(-from  => $from, -to => $to);
}


sub scale {
	my ($w, $label, $pvar, $prange, $pack) = @_;
	my $scale = $w->Scale();
	my $porient = {qw( - h | v )};
	my $orient = 'h';
	if ($label =~ s/^(.)//) {
		$orient = $1;
		exists($porient->{$orient}) and $orient = $porient->{$orient};
	}
	($label  || 0) and $scale->configure(-label    => $label);
	($orient || 0) and $scale->configure(-orient   => $orient);
	($pvar   || 0) and $scale->configure(-variable => $pvar);
	($prange || 0) and scale_range($scale, $prange);
	packit($scale, $pack);
	return $scale;
}


sub button {
	my ($w, $text, $width, $bind, $psub) = @_;
	$text =~ s/^(.)//;
	my $side = $1;
	my $button = $w->Button(-bg => 'skyblue');
	($width || 0) and $button->configure(-width => $width);
	($psub || 0)  and $button->configure(-command => $psub);
	my $mw = $w->toplevel();
	if ($bind || 0) {
		$text .= "  ($bind)";
		(lc $bind eq lc 'esc') and $bind = 'Escape';
		$mw->bind("<$bind>" => sub { $button->invoke() });
	}
	$button->configure(-text => $text);
	my $psides = { qw( > right < left ^ top v bottom ) };
	my @args = ($side || 0)? ( -side => $psides->{$side} ): ( );
	$button->pack(@args);
	return $button;
}


sub checkb {
	my ($w, $text, $width, $pvar, $pack) = @_;
	my $cb = $w->Checkbutton();
	($text  || 0) and $cb->configure(-text  => $text);
	($width || 0) and $cb->configure(-width => $width);
	($pvar  || 0) and $cb->configure(-var   => $pvar);
	return packit($cb, $pack);
}


sub optmenu {
	my ($w, $width, $pitems, $pvar, $pack) = @_;
	my $omenu = $w->Optionmenu(-options => $pitems, -variable => $pvar);
	($width || 0) and $omenu->configure(-width => $width);
	$pack ||= '0xl';
	packit($omenu, $pack);
	return $omenu;
}


sub labent {
	my ($w, $text, $lwidth, $pvar, $ewidth, $pack, $show, $b_ro) = @_;
	my $fr = frame($w, $pack);
    my $lb = $fr->Label(-width => $lwidth, -text => $text);
    my $en = $fr->Entry(-width => $ewidth, -textvar => $pvar);
	($b_ro || 0) and $en->configure(-state => 'readonly');
	$lb->configure(-relief => 'groove', -borderwidth => 2);
	$en->configure(-relief => 'sunken', -borderwidth => 2);
	($lwidth || 0) and $lb->configure(-width => $lwidth);
	($ewidth || 0) and $en->configure(-width => $ewidth);
	($show || 0) and $en->configure(-show => $show);
	$lb->pack(-side => 'left');
	$en->pack(-side => 'left');
	return [ $lb, $en ];
}


sub packit {
	my ($w, $pack) = @_;
	$pack ||= "0ntf";
	my $exp    = ($pack =~ s/^(.)//)?  $1: '0';
	my $fill   = ($pack =~ s/^(.)//)?  $1: 'n';
	my $side   = ($pack =~ s/^(.)//)?  $1: 't';
	my $relief = $pack;
	my $pfills = { 'b' => 'both', 'n' => 'none', 'x' => 'x', 'y' => 'y' };
	my @args = ( -expand => $exp, -fill => $pfills->{$fill} );
	my $psides = { qw( r right l left t top b bottom ) };
	($side || 0) and push @args, (-side => $psides->{$side});
	if ($relief) {
		my ($rel, $bw) = ($pack =~ /^(.)(.*)$/);
		my $prel = { qw(f flat g groove R raised r ridge s solid S sunken) };
		exists($prel->{$rel}) and $rel = $prel->{$rel};
		$bw ||= 4;
		$w->configure(-rel => $rel, -borderwidth => $bw);
	}
	$w->pack(@args);
	return $w;
}


sub xpm_image {
	my ($data) = @_;
	my $mw  = $pc->{'mw'};
	my $p   = decode($data);
	my $img = $mw->Photo(-format => 'xpm', -data => $p->[0]);
	return $img;
}


sub image_button {
	my ($w, $pack, $psub, $data) = @_;
	my $img = xpm_image($data);
	my $btn = $w->Button();
	$btn->configure(-image => $img);
	($psub || 0) and $btn->configure(-command => $psub);
	return packit($btn, $pack);
}


sub begin_button {
	my ($w, $pack, $psub) = @_;
    my $data = '32,32,none,000000,00f03b;]`]`]a]_bi( ]s( )( ]q]b )( ]o(* * )('
    . ' ]m() * )( ]k(]c * )( ]i(]e * )( ]g(]g * )( ]e(]i * )( ]c(]k * )( )(]m'
    . ' * )( *(]o * )( *(]o * )( )(]m * )( ]c(]k * )( ]e(]i * )( ]g(]g * )( ]'
    . 'i(]e * )( ]k(]c * )( ]m() * )( ]o(* * )( ]q]b )( ]s( ';
	return image_button($w, $pack, $psub, $data);
}


sub end_button {
	my ($w, $pack, $psub) = @_;
    my $data = '32,32,none,000000,00f03b;]`]`]a]_bi( ]s( )]b ]q( )** ( ]o( )*'
    . ') ( ]m( )*]c ( ]k( )*]e ( ]i( )*]g ( ]g( )*]i ( ]e( )*]k ( ]c( )*]m ( '
    . ')( )*]o ( *( )*]o ( *( )*]m ( )( )*]k ( ]c( )*]i ( ]e( )*]g ( ]g( )*]e'
    . ' ( ]i( )*]c ( ]k( )*) ( ]m( )** ( ]o( )]b ]q( )( ]s( ';
	return image_button($w, $pack, $psub, $data);
}


sub start_playback_image {
    my $data = '32,32,none,000000,00f03b;]_]_]``e) ]z]b ]x(( ) ]v(]a ) ]t(]c '
    . ') ]r(]e ) ]p(]g ) ]n(]i ) ]l(]k ) ]j(]m ) ]h(]o ) ]f(]q ) ]d(]s ) ]b(]'
    . 's ) ]b(]q ) ]d(]o ) ]f(]m ) ]h(]k ) ]j(]i ) ]l(]g ) ]n(]e ) ]p(]c ) ]r'
    . '(]a ) ]t(( ) ]v]b ]x) ';
	return xpm_image($data);
}


sub stop_playback_image {
    my $data = '32,32,none,000000,ff0000,fcfffb;]a]^]`]_]c^i]i{]p(]i{({]n(]k{'
    . '({]l(]m{({]j(]o{({]h(]q{({]f(]s{({]d(]u{({]b(]w{({)(]y{({*()){*]b{*){)'
    . ']a{){({*(*({)({)({)({)({*({)({*{({*(*({]d({)({)({*({)({*{({*()*{]b({)('
    . '{)({*({)({*{({*(]b({]a({)({)({*]a{){({*(+({)({)({)({*({+{({*(+({)({)({'
    . ')({*({+{({*(*({)({)({)({)({*({+{({*()){]a({]a){)({+{({*(]y{({)(]w{({]b'
    . '(]u{({]d(]s{({]f(]q{({]h(]o{({]j(]m{({]l(]k{({]n(]i{({]p]i{';
	return xpm_image($data);
}


sub step_ahead_button {
	my ($w, $pack, $psub) = @_;
    my $data = '32,32,none,000000,ffa500,1ff9ec;]c]_]^]a]x]v]b_q*{]y)({({+(({'
    . '({+(({({+(({({+(({({+(({({+(({({+(({({+(({({]f({*({*({*(({({]d) ( ){()'
    . ' ( ){() ( ){*(({({]c) ( ){() ( ){() ( ){-(({({-) ( ){() ( ){() ( ){-(('
    . '{({-) ( ){() ( ){() ( ){-(({({-) ( ){() ( ){() ( ){*(({({]d({*({*({*(('
    . '{({,(({({,(({({,(({({,(({({,(({({,(({({,(({({,(({({]w)({({+*{';
	return image_button($w, $pack, $psub, $data);
}


sub step_back_button {
	my ($w, $pack, $psub) = @_;
    my $data = '32,32,none,000000,ffa500,1ff9ec;]c]_]^]a]x]v]b_m*{+(({){]w(({'
    . '({,(({({,(({({,(({({,(({({,(({({,(({({,(({({,(({({*({*({*({]d(({({*) ('
    . ' ){() ( ){() ( ){-(({({-) ( ){() ( ){() ( ){-(({({-) ( ){() ( ){() ( )'
    . '{-(({({-) ( ){() ( ){() ( ){]c(({({*) ( ){() ( ){() ( ){]d(({({*({*({*'
    . '({]f(({({+(({({+(({({+(({({+(({({+(({({+(({({+(({({+(({){]y*{';
	return image_button($w, $pack, $psub, $data);
}


sub pick_image_button {
	my ($w, $pack, $psub) = @_;
    my $data = '32,32,none,f8e811,fefffc,c347dc,fff5fb;]d]^]_]`]a]b]d]c_b]k|,'
    . '.|-(-|(+|(|,(+|.|)((,|*)|(|-()|(|(+|(|)((.|))|(|(,|(()|*)|(|(|)(()({()'
    . '|-*|*)|( (|)|)|(|)(()|))|))|),|))|()({(|)|)(()|))|))|))|)(|)+|)|)|*((.'
    . '|))|))|)(|)*|)|)|+((,|*)|))|,+|)|(|+(()|+|(()|))|,+|)|(|+(()|(|+()|))|'
    . ')(|),|)|(|*(()|(|(|)(()|))|)(|))|()({(|(|*(()|(|(|)(()|),|))|))|(|(|*('
    . '()|(|(|)(()|**|*)({()|(|(|*(+|(|)(+|(,|)-|(|*.|)]r|^a.|]w(+|]y()|]f|(,'
    . '|(]h|)()|(+|()|**|*+|)*|)|(()|(]e|()|()|()|()|()|()|(|(()|()|()|()|+)|'
    . '()|()|(,|(|(()|()|()|()|)+|(,|()|+|(()|()|()|()|()|()|)+|()|()|(|(()|('
    . ')|()|()|()|()|+)|()|()|(|(()|()|()|()|)+|()|()|)*|)|(]q*|-|]s*|]e|]q,|';
	return image_button($w, $pack, $psub, $data);
}


sub create_graphic {
	my ($fname) = @_;
	my $fh = new FileHandle;
	open($fh, ">", $fname) or die "$iam:  can't write '$fname' ($!)\n";

    my $data = '640,480,a000c0,fc0fc0,^s]_]`]a]^]b]d]c]e]f]o]p]l]m]g]n]k]h]j]'
    . 'i]r]s]q]u]t]v]w]x]z^]]y^c^a^^^`^_^d^eer^k^biy_b^p^f^g^m^res_a^i^o^s#_a'
    . 'ou-q]0;:pi@23p^G26p]G62p]G3<ozG7?ozI7@ozJ9A>0nwJ8E;7o_>5C21o^?0H4;o^;0'
    . 'J3?o];0J7@aa)js;/I9Ba`-jo;-G:Ca_8jk;.O8Da_3jg;.O5Ja^2E=V2fe;,F0IF2_c?='
    . 'CTDf`=,K/ODE40K@7408IKf]=,K-FBI7K0@:738EYey=*L-F>L:F5@571:>Uew=*L.L;^h'
    . '5F8@0729;Rev=)S,S2N0F5A-3662Veu=)S*T1U-F84-).49;1;8;et=(:)@*T4R.F8344:'
    . '>31=1W=(5-?)8)B3^q,F:3445A34?6W=(0/?(5.A7[*.9493360E93A6M=+05<(0/@9^t<'
    . '693710E:4B4W2+/8<+00@:^u;67731/C86B6MB9;+/5@8^v=19372/C81A6MB9C8@5^x11'
    . '737=-C5=>1MA7E:@0^y62737=-E8<;2MA7E:@/^z42339;/A:B9?eq@3B9>0^z3=339</>'
    . ':Xeq@3A7>/_]3=749<813Xeq@4@9@/E:=7=337?^jXeq>6>7@->?79;337>YXM?6>7>/;C'
    . '8:;347@^hXM<1?3>-2G0:;347BS?)LM<1<4>-6K/8<347D097<5JM<1<3>/3T-5<443^u8'
    . '<4AM<1;4>-3^h-5<363^w0<<=M;2;4?/9^j-0?364^w/<E7W=2=6?/:N.5<466^w-<G/W='
    . '2=4?08N-0?36=^v.<S)W=2=4<55N/0?36?9/H.<ga2=26<55^j0/>71^nE-;:9ff2=24<8'
    . '0^j5/>71RB.;52fb2=16;:0Y8/?31^qA.;/>f`1=16=90T:/>72V@.;-Bf^1=14;95K7/>'
    . '72?37>-=.Cf]1216=35G4/>9=1?8>-=.Dez121624:C1/@9=4B5?-=.Hez1114263<</@:'
    . ';+/,D0?/=,Hez1166122:B/@:J(J/?/=,Jey11641=^x0A5I+I/?02.Hey11646<^w0A0_'
    . 'e0;52.Hez61644?^v5B-_f0;82.Deq-(61634@^u5B-_f0;:1.DeoC4133B[8C)/(_]5=9'
    . '1-CeoC4172>V:S)_]5=71/AeqE417A1^q:L)_]82460@eqE417C4Z7F*>,D82165<ME329'
    . 'D6U3O,=0E:221:1WC729H6N4G.6:A92;173WC7=8J2^h1H/74<7=?197etC7=5G2S=E5:2'
    . '44;B653eu.:89;XK<@:5<7:>D2,4ev)=-:;_cG@;9/A^nILew+@*8?_dDE13-C^jKGfx+8'
    . '@_dAG52,ILYDgjA_d;Q)LHR>gq?_g9_f+^l=^y6gy2qv7r^0rc*"jdh4qq@qiHqdFq_Tpy'
    . '1/6pw694pt463pr4=7pp4<7pn4>7pl4A9pl4B9pj4E7ph6;;ph41A_k(mt63C_g-ms67D_'
    . 'c8mr19J^z6^w,kq69I^t?^u0ko6:G^nC[:km18ONJV9km18O^lHA594kl15F^lH0B:6kk2'
    . '5F;53Q:2>0jg25F168A)F8=;3jd25F3<0>,O8;1=jb25F7@/<.O5<6<ja28G9C.<-G0>7@'
    . 'j_=:I:H,<7B/@9Bj^;9D:I*<4>/A8Dj];7E:F);4>-B5Hj];6?7K(;6?.E0Iiz;<34S+;6'
    . '?.E/Giz;[__6?,C-FP;V_`6?,C.KP<^q_`6<,D.KP<RX1;*H,8)>P<RX1;*H*0-?P<ZQ1;'
    . ')J)00<P<ZQ1;)8(2)/5<P?^nQ1;(5,1(/8<P?UE:A1;(//6+/:<P?U<<<2=(-06+-9<P?U'
    . '2B=2=+/0@9;iz?^l6H22=+-8?7;iz>N3G12B:<7<iz>N9F12A9<7;j]>N:F22A9;3;j^?O'
    . '+/8K1;>7=4;j^>I(/5F=;>7=4=j_>I(-8O;;>724=j`>J)-8G<;?324=j`@D*-:H><<316'
    . '2jb>D*-7AB<<3142jc@E,-6=D<;4662jc@B.-<8I?;4661jd@B.-_c>=4641jf@@--_c>2'
    . '6466jgA?-/_c>26446jhA<//Q@26364jjA25/Q(0314463jkB68/_m314443jmB990_m,/'
    . '(23367jnC-65_l,C3347jpV8_l,C3346jmV8_l,C333>jhR9^j(C,C333BjfZ9Y)D*C747'
    . 'EjgU3S,D*D947CjgN6F-D*D949DjhY2I/H*D94:JjhT<C515)*,:9:1kvL@>9:?+</81kx'
    . 'GD32/^t,52kzDQ.^z(52l^@_e)_m1la3_k+_s1qw4qy8r`-rd)#_cfh(rd)rc*_k(op*_k'
    . ',ol._j.`f(l`)+)_i)+(`f*l_(((_j(^t(Z,lb(^n+*+=([*G+8,lc(Y82(V.J)8+L(k]('
    . 'T:=(^q(()D,5(K)k](^h+(,?(R+,(B/5+L)k]+U*?+R+,)A)(,/(K)k^+U*<(Z+.(A)),/'
    . '+L)k^+6(B*<(Z+,)A(*..(K*k](,)/)E)5-,(2)-+6+.)A+,..+:-,),+*8,-.)-+iv:*,'
    . '-)1)/0,+2).)4+-(I(+*,+50**)6*0,).)iv:),-*1)-,+*,+,)5*,*3(-+G(+**(0,+*('
    . '.+*(-0,+***,*iv*)*)(+)-*1(/(***(*,-,,,3(Y+)*)(0(**(/0(5(**(,,,iv+-))+('
    . ')-*1(-(,),().5(*(+)3+6+>()*((0(,).*5(0(,).(*(+)iv+-(-).*2(.),(.(((+*5('
    . '(()(3(3)>(**+(/),(-)8(/),(-((()(iw+-(-),,2(.),(.(+((*5+((*(3(7*>(,./),'
    . '(-(:(/),(-+((*(iw+.(/))(()2(.)*).**)5+(+,(3(3(@(,./)*).)8(0)*)-+(+,(iw'
    . '(*(/*(()(2(-)*(-**)0(+(*)7)7(A(.,/)*(-)8(0)*(-(+(*)iw+*(0*+(*(2(-))(-*'
    . ',*/*,)*+0)9+B(/,-))(/)5)0))(/*,)*+ir+)(5.,(2(-))(-).*)()).)()0)8(0+1(/'
    . ',-))(/(8).+())(/).)()iq(((8,.(2+/)((/).*())).-8*-(0*6(0*-)((0(8),(()(('
    . '0).-ir(+(:*-(1(/.0).*+(,(-,988,3(5*-.0)5**().5(-,it*9)/+2(/,5)-,,)-*4-'
    . '9,7)5*-,5)8*+)*,5)-*it*>(2+0)8)/)-+0(T(3)5)/):(:-,):+0(iu)A(1(?(0+ah,j'
    . 'y(B+2(bm)kz+2+qo+2(qo+1(qo(1+qp+1(qp+6(qp(4(qq(7(qs+7(qs(:)qt+:(qu(:+q'
    . 'v+re(re+re("`hk(rd)rc*rb*ob*_v.oa-_s)+)oa5_p(((ob:_r(_^(5*5*lb*+/_p(^y'
    . './,0,..(,km),._o(^v//./.,7kk,-,_n(^t,((/)+*.)+**9kk.0*_m+^t*)(/))),)))'
    . '9)ko)5*_l+[)*)/(*),(*)9(kp)8)<)?+A+[+,)0(***(**8(kq):(-*0.0*-)@(,)0*/)'
    . ',+2(5(,*)(,*8(kq(9(,././.-)@:,.-*))1(8(,*)(,*5(kq)9(*)+*.,0)+*,*,(.(5:'
    . '*)+**.+*1(:(,*)(,*0(kr)7+)))),)8)))**,**)5*)**)))*/=+9(.*((.*0(kr)9())'
    . ')(.)8))(.)*,),0+-)*))(/*=+7(.*((.*0+ks)9+*()).(:()).(*(+)(++*0+-(,())/'
    . ')2(3(.))(.)0(ks(9(*-.):--()(()++))0+-(,-0(2(4(.))(.)0+kt(:(*--)8-/(((*'
    . '*))0+.(,-0)2+6+-))+-)/(kt(5),)8)8):((+***)0(*(.)9)1(6+-(*+-(0+ku(0(.):'
    . ')5)9+((***)*+*+*(.)7)4.5+*+.(,+.(0(ku+/)-*/+()5*/+)*,),))(*+)(-*/+*(40'
    . '.,((*(.(*(5)ks(.)0*.)()-(+*.))).).(((*(((/*.)*(79*,(()).())5)ks(*)8*)*'
    . '**)*(*)*,(.)-(+(,(+(0*)*,)7*)/+,*./.8(kt+(*90.5)0.).)-*.*50-)9)/5.)8):'
    . ')ks,4-/-.-/).(5+.*8-0(7(^u(kr,2(9*0(8*>)7(nn*_`(@(oa)Q+p^(';

	my $p = decode($data);
	print $fh $p->[0];
	close $fh;
}


sub decode {
	my $text = shift;

	$text =~ s/^([^,]+),([^,]+),//;
	my ($w, $h) = ($1, $2);
	
	my @colors;
	while ($text =~ s/([^,;]+)([,;])//) {
		my ($color, $delim) = ($1, $2);
		push @colors, $color;
		last if ($delim eq ';');
	}

	my $ncolors = @colors;
	if ($ncolors > 7) {
		die "$iam:  image has $ncolors defined (more than 7 colors)\n";
	}

	my $pdecode = sub {
		my $penc = shift;
		my $res  = ($$penc =~ s/^([!"#\$%&])//)? 900: 0;
		my $len = $res? ord($1) - ord('!') + 2: 2;
		for (my $pow = $len - 1; $pow >= 0; $pow--) {
			$res += (30 ** $pow) * (ord(substr($$penc, 0, 1, "")) - 93);
		}
		return $res;
	};

	my $pmaps = { };
	my $ncodes = $pdecode->(\$text);

	for (my $i = 0; $i < $ncodes; $i++) {
		my $code = $pdecode->(\$text);
		my $e = chr(41 + $i);
		$pmaps->{$e} = $code;
	}

	my @counts = ( );
	while ($text) {
		my $c = substr($text, 0, 1);
		my $idx = index(" {|}~", $c);
		if ($idx >= 0) {
			substr($text, 0, 1, "");
			push @counts, - $idx - 2;
		} else {
			$c = ord($c) - 40;
			($c < 0 or $c > 51) and $c = -1;
			if ($c >= 0) {
				substr($text, 0, 1, "");
				my $e = chr(41 + $c);
				push @counts, $pmaps->{$e};
			} else {
				push @counts, $pdecode->(\$text);
			}
		}
	}
	
	# Create the XPM image
	my $psyms = [qw/ .  o  *  @  !  %  X /];
	my $xpm = "/* XPM */\nstatic char * image[] = {\n";
	$xpm  .= "\"$w $h $ncolors 1\",\n";
	for (my $i = 0; $i < $ncolors; $i++) {
		my $sym   = $psyms->[$i];
		my $color = $colors[$i];
		($color =~ /^[0-9a-f]+$/) and $color = "#$color";
		$xpm .= sprintf "\"%s\tc %s\",\n", $sym, $color;
	}

	my $string = "";
	my $k      = 0;
	my $char   = $psyms->[$k];

	while (@counts) {
		my $next = shift @counts;
		if ($next < 0) {
			$char = $psyms->[$k = ($k - $next - 1) % $ncolors];
		} else {
			$string .= $char x $next;
			$char = $psyms->[$k = ($k + 1) % $ncolors];
		}
	}

	my $length = length($string);
	my $remain = ($h * $w) - $length;
	$string .= $char x $remain;

	while ($string) {
		my $substr = substr($string, 0, $w, "");
		$xpm .= sprintf "\"%s\"", $substr;
		$string and $xpm .= ",\n";
	}
	$xpm .= "};\n";

	return [ $xpm, $w, $h ];
}


sub create_example_file {
	my $text = "
		|#
		|#  This file documents parameters used by the MouseCam program.
		|#
		|#  This machine's IP address is 192.168.1.3 (see ADDRESS below).
		|#  Lines starting with '#' are comments.
		|#  Parameters are case-insensitive.
		|#
		|# The server ADDRESS is mandatory.  It specifies the network address
		|# for this server.
		|ADDRESS      192.168.1.3
		|
		|# == Fetching images ==
		|# If FETCH is zero, no images will be fetched initially, otherwise
		|# they will.
		|FETCH        1
		|
		|# == Saving images ==
		|# If SAVE is zero, images will not be saved to disk initially,
		|# otherwise they will.  The image directory will be the name of
		|# the profile without the '.txt' extension, if one was given,
		|# otherwise it will be the address of the server.  The variable
		|# SAVETIME specifies how often (in seconds) to save images.  It
		|# must be a minimum of 1.  The maximum number of saved images is
		|# specified by MAXSAVE.  If saves occur once a second, a MAXSAVE
		|# value of 600, for example, would represent 10 minutes worth of
		|# images.  Once this number of images have been saved, each further
		|# image save causes the oldest image to be removed.
		|SAVE         1
		|SAVETIME     1
		|MAXSAVE      600
		|
		|# == Showing images ==
		|# If SHOW is zero, no images will be shown initially, otherwise
		|# they will.  The variable DISPLAYTIME specifies how often (in
		|# seconds) to show images.
		|SHOW         1
		|SHOWTIME     1
		|
		|# == FTP-uploading images ==
		|# You can upload images, using FTP (file-transfer protocol) to a
		|# remote host (eg. a webserver).  If FTP is zero, no images will
		|# be uploaded initially, otherwise they will.  The variable FTPTIME
		|# specifies how often (in seconds) to upload images.  Variables
		|# USER and PASSWORD are the username and password credentials which
		|# the remote FTP server prompts for before logging the user in.
		|# The variable HOST gives the name of the remote FTP server.  The
		|# variable TARGET is the remote directory to save the image to, and
		|# FILE is the remote destination filename.
		|FTP          0
		|FTPTIME      30
		|HOST         mysite.isp.net
		|USER         myself
		|PASSWORD     pa55w0Rd
		|TARGET       mousecam
		|FILE         pic.jpg
		|
	";

	$text =~ s/\s*\Z//m;
	$text =~ s/^\s*\|//gm;

	if (!-e $example) {
		my $fh = new FileHandle;
		if (open($fh, ">", $example)) {
			print $fh "$text\n";
		}
	}

	return $text;
}