File: callback.t

package info (click to toggle)
libterm-readline-gnu-perl 1.07-2
  • links: PTS
  • area: main
  • in suites: potato
  • size: 252 kB
  • ctags: 133
  • sloc: perl: 1,402; makefile: 51
file content (85 lines) | stat: -rw-r--r-- 2,383 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
# -*- perl -*-
#	callback.t - Test script for Term::ReadLine:GNU callback function
#
#	$Id: callback.t,v 1.2 1999-04-04 20:24:44+09 hayashi Exp $
#
#	Copyright (c) 1999 Hiroo Hayashi.  All rights reserved.
#
#	This program is free software; you can redistribute it and/or
#	modify it under the same terms as Perl itself.

BEGIN {print "1..7\n"; $n = 1;}
END {print "not ok 1\tfail to loading\n" unless $loaded;}

my $verbose = defined @ARGV && ($ARGV[0] eq 'verbose');

$^W = 1;			# perl -w
use strict;
use vars qw($loaded $n);
eval "use ExtUtils::testlib;" or eval "use lib './blib';";
use Term::ReadLine;

$loaded = 1;
print "ok 1\tloading\n"; $n++;

########################################################################
# test new method

my $term = new Term::ReadLine 'ReadLineTest';
print defined $term ? "ok $n\n" : "not ok $n\n"; $n++;

my $attribs = $term->Attribs;
print defined $attribs ? "ok $n\n" : "not ok $n\n"; $n++;

my ($IN, $OUT);
if ($verbose) {
    $IN = $attribs->{instream};
    $OUT = $attribs->{outstream};
} else {
    open(IN, 't/button.pl') or die "cannot open 't/button.pl': $!\n";
    $IN = \*IN;
    # $IN = \*DATA;		# does not work.  Why?
    open(NULL, '>/dev/null') or die "cannot open \`/dev/null\': $!\n";
    $attribs->{outstream} = $OUT = \*NULL;
}

########################################################################
# check Tk is installed
if (eval "use Tk; 1") {
    print "ok $n\tuse Tk\n"; $n++;
} else {
    print "ok $n\t# skipped since Tk is not installed.\n"; $n++;
    print "ok $n\t# skipped since Tk is not installed.\n"; $n++;
    print "ok $n\t# skipped since Tk is not installed.\n"; $n++;
    print "ok $n\t# skipped since Tk is not installed.\n"; $n++;
    exit 0;
}
my $mw;
$mw = MainWindow->new();
$mw->protocol('WM_DELETE_WINDOW' => \&quit);

$attribs->{instream} = $IN;
$mw->fileevent($IN, 'readable', $attribs->{callback_read_char});
print "ok $n\tcallback_read_char\n"; $n++;

$term->callback_handler_install("> ", sub {
    my $line = shift;
    quit() unless defined $line;
    eval $line;
    print $OUT "$@\n" if $@;
});
print "ok $n\tcallback_handler_install\n"; $n++;

&MainLoop;

sub quit {
   $mw->fileevent($IN, 'readable', '');
   $term->callback_handler_remove();
   $mw->destroy;
   print "ok $n\n"; $n++;
   exit 0;
}

__END__
$b=$mw->Button(-text=>'hello',-command=>sub{print $OUT 'hello'})
$b->pack;