1#! /usr/bin/perl
2
3# This file a port from test/gdc.c in the ncurses-1.9.8a distribution.
4# No copyright license is publicly offered, but I don't think the
5# writer would mind the port.  It's not exact, because I was
6# simplifying things to find a bug in my port.
7#
8# Also note that this is basically a direct port.  If it looks like C
9# written in perl, that's because it is.  :-)
10#
11# /*
12#  * Grand digital clock for curses compatible terminals
13#  * Usage: gdc [-s] [n]   -- run for n seconds (default infinity)
14#  * Flags: -s: scroll
15#  *
16#  * modified 10-18-89 for curses (jrl)
17#  * 10-18-89 added signal handling
18#  */
19
20use ExtUtils::testlib;
21use Curses;
22
23$YBASE   = 10;
24$XBASE   = 10;
25$YDEPTH  =  5;
26$XLENGTH = 54;
27
28@disp = (075557, 011111, 071747, 071717, 055711, 074717,
29	 074757, 071111, 075757, 075717, 002020);
30
31
32$SIG{INT}  = \&sighndl;
33$SIG{TERM} = \&sighndl;
34
35initscr();
36cbreak();
37noecho();
38clear();
39refresh();
40
41$n = -1;
42for (@ARGV) {
43    /-s/ and $scroll = 1;
44    $n = $_;
45}
46$hascolor = eval { has_colors() };
47
48if ($hascolor) {
49    start_color();
50    init_pair(1, COLOR_BLACK, COLOR_RED);
51    init_pair(2, COLOR_RED, COLOR_BLACK);
52    init_pair(3, COLOR_WHITE, COLOR_BLACK);
53    attrset(COLOR_PAIR(3));
54
55    addch($YBASE - 1,  $XBASE - 1, ACS_ULCORNER);
56    hline(ACS_HLINE, $XLENGTH);
57    addch($YBASE - 1,  $XBASE + $XLENGTH, ACS_URCORNER);
58
59    addch($YBASE + $YDEPTH,  $XBASE - 1, ACS_LLCORNER);
60    hline(ACS_HLINE, $XLENGTH);
61    addch($YBASE + $YDEPTH,  $XBASE + $XLENGTH, ACS_LRCORNER);
62
63    move($YBASE,  $XBASE - 1);
64    vline(ACS_VLINE, $YDEPTH);
65
66    move($YBASE,  $XBASE + $XLENGTH);
67    vline(ACS_VLINE, $YDEPTH);
68
69    attrset(COLOR_PAIR(2));
70}
71
72while ($n--) {
73    $mask = 0;
74    $time = time;
75    my($sec, $min, $hour) = localtime $time;
76    set($sec  % 10,  0);
77    set($sec  / 10,  4);
78    set($min  % 10, 10);
79    set($min  / 10, 14);
80    set($hour % 10, 20);
81    set($hour / 10, 24);
82    set(10,          7);
83    set(10,         17);
84    foreach $k (0..5) {
85	if($scroll) {
86	    foreach $i (0..4) {
87		$new[$i] = ($new[$i] & ~$mask) | ($new[$i+1] & $mask);
88	    }
89	    $new[5] = ($new[5] & ~$mask) | ($next[$k] & $mask);
90	}
91	else { $new[$k] = ($new[$k] & ~$mask) | ($next[$k] & $mask) }
92	$next[$k] = 0;
93	for($s = 1; $s >= 0; $s--) {
94	    standt($s);
95	    foreach $i (0..5) {
96		if($a = (($new[$i] ^ $old[$i]) & ($s ? $new[$i] : $old[$i]))) {
97		    for ($j = 0, $t = 1 << 26; $t; $t >>= 1, $j++) {
98			if($a & $t) {
99			    if(!($a & ($t << 1))) {
100				move($YBASE + $i, $XBASE + 2*$j);
101			    }
102			    addstr("  ");
103			}
104		    }
105		}
106		if(!$s) { $old[$i] = $new[$i]; }
107	    }
108	}
109	refresh();
110    }
111#    /* this depends on the detailed format of ctime(3) */
112    my($ctime) = scalar localtime $time;
113    addstr(16, 30, substr($ctime, 0, 10) . substr($ctime, 19));
114
115    move(0, 0);
116    refresh();
117    sleep(1);
118    if ($sigtermed) {
119	last;
120    }
121}
122standend();
123clear();
124refresh();
125endwin();
126print STDERR "gdc terminated by signal $sigtermed\n" if $sigtermed;
127
128sub set {
129    my($t, $n) = @_;
130    my($m)     = 7 << $n;
131
132    foreach $i (0..4) {
133	$next[$i] |= (($disp[$t] >> (4-$i)*3) & 07) << $n;
134	$mask     |= ($next[$i] ^ $old[$i]) & $m;
135    }
136    if ($mask & $m) { $mask |= $m }
137}
138
139sub standt {
140    my($on) = @_;
141
142    if ($on) { $hascolor ? attron(COLOR_PAIR(1)) : standout() }
143    else     { $hascolor ? attron(COLOR_PAIR(2)) : standend() }
144}
145
146sub sighndl {
147    local($sig) = @_;
148
149    $sigtermed = $sig;
150}
151