#! /usr/bin/perl
# This file a port from test/gdc.c in the ncurses-1.9.8a distribution.
# No copyright license is publicly offered, but I don't think the
# writer would mind the port. It's not exact, because I was
# simplifying things to find a bug in my port.
#
# Also note that this is basically a direct port. If it looks like C
# written in perl, that's because it is. :-)
#
# /*
# * Grand digital clock for curses compatible terminals
# * Usage: gdc [-s] [n] -- run for n seconds (default infinity)
# * Flags: -s: scroll
# *
# * modified 10-18-89 for curses (jrl)
# * 10-18-89 added signal handling
# */
use ExtUtils::testlib;
use Curses;
$YBASE = 10;
$XBASE = 10;
$YDEPTH = 5;
$XLENGTH = 54;
@disp = (075557, 011111, 071747, 071717, 055711, 074717,
074757, 071111, 075757, 075717, 002020);
$SIG{INT} = \&sighndl;
$SIG{TERM} = \&sighndl;
initscr();
cbreak();
noecho();
clear();
refresh();
$n = -1;
for (@ARGV) {
/-s/ and $scroll = 1;
$n = $_;
}
$hascolor = eval { has_colors() };
if ($hascolor) {
start_color();
init_pair(1, COLOR_BLACK, COLOR_RED);
init_pair(2, COLOR_RED, COLOR_BLACK);
init_pair(3, COLOR_WHITE, COLOR_BLACK);
attrset(COLOR_PAIR(3));
addch($YBASE - 1, $XBASE - 1, ACS_ULCORNER);
hline(ACS_HLINE, $XLENGTH);
addch($YBASE - 1, $XBASE + $XLENGTH, ACS_URCORNER);
addch($YBASE + $YDEPTH, $XBASE - 1, ACS_LLCORNER);
hline(ACS_HLINE, $XLENGTH);
addch($YBASE + $YDEPTH, $XBASE + $XLENGTH, ACS_LRCORNER);
move($YBASE, $XBASE - 1);
vline(ACS_VLINE, $YDEPTH);
move($YBASE, $XBASE + $XLENGTH);
vline(ACS_VLINE, $YDEPTH);
attrset(COLOR_PAIR(2));
}
while ($n--) {
$mask = 0;
$time = time;
my($sec, $min, $hour) = localtime $time;
set($sec % 10, 0);
set($sec / 10, 4);
set($min % 10, 10);
set($min / 10, 14);
set($hour % 10, 20);
set($hour / 10, 24);
set(10, 7);
set(10, 17);
foreach $k (0..5) {
if($scroll) {
foreach $i (0..4) {
$new[$i] = ($new[$i] & ~$mask) | ($new[$i+1] & $mask);
}
$new[5] = ($new[5] & ~$mask) | ($next[$k] & $mask);
}
else { $new[$k] = ($new[$k] & ~$mask) | ($next[$k] & $mask) }
$next[$k] = 0;
for($s = 1; $s >= 0; $s--) {
standt($s);
foreach $i (0..5) {
if($a = (($new[$i] ^ $old[$i]) & ($s ? $new[$i] : $old[$i]))) {
for ($j = 0, $t = 1 << 26; $t; $t >>= 1, $j++) {
if($a & $t) {
if(!($a & ($t << 1))) {
move($YBASE + $i, $XBASE + 2*$j);
}
addstr(" ");
}
}
}
if(!$s) { $old[$i] = $new[$i]; }
}
}
refresh();
}
# /* this depends on the detailed format of ctime(3) */
my($ctime) = scalar localtime $time;
addstr(16, 30, substr($ctime, 0, 10) . substr($ctime, 19));
move(0, 0);
refresh();
sleep(1);
if ($sigtermed) {
last;
}
}
standend();
clear();
refresh();
endwin();
print STDERR "gdc terminated by signal $sigtermed\n" if $sigtermed;
sub set {
my($t, $n) = @_;
my($m) = 7 << $n;
foreach $i (0..4) {
$next[$i] |= (($disp[$t] >> (4-$i)*3) & 07) << $n;
$mask |= ($next[$i] ^ $old[$i]) & $m;
}
if ($mask & $m) { $mask |= $m }
}
sub standt {
my($on) = @_;
if ($on) { $hascolor ? attron(COLOR_PAIR(1)) : standout() }
else { $hascolor ? attron(COLOR_PAIR(2)) : standend() }
}
sub sighndl {
local($sig) = @_;
$sigtermed = $sig;
}