1#!/usr/bin/perl -w 2# 3# Make sure the VT102 module's callbacks work. 4# 5# Copyright (C) Andrew Wood 6# NO WARRANTY - see COPYING. 7# 8 9require Term::VT102; 10 11my $nt = 5; 12my $i = 1; 13my ($testarg1, $testarg2, $testpriv) = (0, 0, 0); 14 15print "$i..$nt\n"; 16 17my $vt = Term::VT102->new ('cols' => 80, 'rows' => 25); 18 19# Test 1 - ROWCHANGE callback runs at all 20 21$vt->callback_call ('ROWCHANGE', 0, 0); 22print "ok $i\n"; 23$i ++; 24 25# Test 2 - ROWCHANGE callback sets private data 26 27$vt->callback_set ('ROWCHANGE', \&testcallback, 123); 28$vt->callback_call ('ROWCHANGE', 0, 0); 29if ($testpriv != 123) { 30 print "not ok $i\n"; 31} else { 32 print "ok $i\n"; 33} 34$vt->callback_set ('ROWCHANGE', undef); 35$i ++; 36 37# Test 3 - STRING callback reports ESC _ values OK 38 39$vt->callback_set ('STRING', \&testcallback, $i); 40$vt->process ("\033_Test String\033\\test"); 41if (($testarg1 ne 'APC') || ($testarg2 ne 'Test String') || ($testpriv != $i)) { 42 print "not ok $i\n"; 43 print STDERR "\nTest $i: arg1=[$testarg1], arg2=[$testarg2], priv=[$testpriv]\n"; 44} else { 45 print "ok $i\n"; 46} 47$vt->callback_set ('STRING', undef); 48$i ++; 49 50# Test 4 - XICONNAME callback reports X icon name changes 51 52$vt->callback_set ('XICONNAME', \&testcallback, $i); 53$vt->process ("\033]1;Test Icon Name\033\\test"); 54if (($testarg1 ne 'Test Icon Name') || ($testpriv != $i)) { 55 print "not ok $i\n"; 56 print STDERR "\nTest $i: arg1=[$testarg1], arg2=[$testarg2], priv=[$testpriv]\n"; 57} else { 58 print "ok $i\n"; 59} 60$vt->callback_set ('XICONNAME', undef); 61$i ++; 62 63# Test 5 - XWINTITLE callback reports X title changes 64 65$vt->callback_set ('XWINTITLE', \&testcallback, $i); 66$vt->process ("\033]2;Test Title\033\\test"); 67if (($testarg1 ne 'Test Title') || ($testpriv != $i)) { 68 print "not ok $i\n"; 69 print STDERR "\nTest $i: arg1=[$testarg1], arg2=[$testarg2], priv=[$testpriv]\n"; 70} else { 71 print "ok $i\n"; 72} 73$vt->callback_set ('XWINTITLE', undef); 74$i ++; 75 76 77sub testcallback { 78 my ($vtobj, $callname, $arg1, $arg2, $privdata) = @_; 79 ($testarg1, $testarg2, $testpriv) = ($arg1, $arg2, $privdata); 80} 81 82# EOF 83