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