1#!/usr/bin/perl -w
2use strict;
3use warnings;
4
5use File::Find;
6use IO::Handle;
7
8die "Unsupported";
9
10##############################################################################
11
12=head1 NAME
13
14tprove_gtk - Simple proof of concept GUI for proving tests
15
16=head1 USAGE
17
18 tprove_gtk [ list of test files ]
19
20=head1 DESCRIPTION
21
22I've included this in the distribution.  It's a gtk interface by Torsten
23Schoenfeld.  I've not run it myself.
24
25C<tprove_gtk> is not installed on your system unless you explicitly copy it
26somewhere in your path.  The current incarnation B<must> be run in a directory
27with both C<t/> and C<lib/> (i.e., the standard "root" level directory in
28which CPAN style modules are developed).  This will probably change in the
29future.  As noted, this is a proof of concept.
30
31=head1 CAVEATS
32
33This is alpha code.  You've been warned.
34
35=cut
36
37my @tests;
38if (@ARGV) {
39    @tests = @ARGV;
40}
41else {
42    find(
43        sub { -f && /\.t$/ && push @tests => $File::Find::name },
44        "t"
45    );
46}
47
48pipe( my $reader, my $writer );
49
50# Unfortunately, autoflush-ing seems to be a big performance problem.  If you
51# don't care about "real-time" progress bars, turn this off.
52$writer->autoflush(1);
53
54if ( my $pid = fork ) {
55    close $writer;
56
57    my $gui = Gui->new( $pid, $reader );
58    $gui->add_tests(@tests);
59    $gui->run();
60}
61
62else {
63    die "Cannot fork: $!" unless defined $pid;
64    close $reader;
65
66    my $runner = TestRunner->new($writer);
67    $runner->add_tests(@tests);
68    $runner->run();
69
70    close $writer;
71}
72
73###############################################################################
74# --------------------------------------------------------------------------- #
75###############################################################################
76
77package Gui;
78
79use Glib qw(TRUE FALSE);
80use Gtk2 -init;
81
82use constant {
83    COLUMN_FILENAME => 0,
84    COLUMN_TOTAL    => 1,
85    COLUMN_RUN      => 2,
86    COLUMN_PASS     => 3,
87    COLUMN_FAIL     => 4,
88    COLUMN_SKIP     => 5,
89    COLUMN_TODO     => 6,
90};
91
92BEGIN {
93    if ( !Gtk2->CHECK_VERSION( 2, 6, 0 ) ) {
94        die("$0 needs gtk+ >= 2.6");
95    }
96}
97
98DESTROY {
99    my ($self) = @_;
100
101    if ( defined $self->{reader_source} ) {
102        Glib::Source->remove( $self->{reader_source} );
103    }
104}
105
106sub new {
107    my ( $class, $child_pid, $reader ) = @_;
108
109    my $self = bless {}, $class;
110
111    $self->create_window();
112    $self->create_menu();
113    $self->create_view();
114
115    $self->{child_pid}     = $child_pid;
116    $self->{child_running} = TRUE;
117
118    $self->{reader_source} = Glib::IO->add_watch(
119        fileno $reader, [qw(in pri hup)],
120        \&_callback_reader, $self
121    );
122
123    return $self;
124}
125
126sub add_tests {
127    my ( $self, @tests ) = @_;
128
129    my $model = $self->{_model};
130
131    $self->{_path_cache} = {};
132
133    foreach my $test (@tests) {
134        my $iter = $model->append();
135        $model->set( $iter, COLUMN_FILENAME, $test );
136        $self->{_path_cache}->{$test} = $model->get_path($iter);
137    }
138}
139
140sub create_window {
141    my ($self) = @_;
142
143    my $window = Gtk2::Window->new();
144    my $vbox = Gtk2::VBox->new( FALSE, 5 );
145
146    $window->add($vbox);
147    $window->set_title("Test Runner");
148    $window->set_default_size( 300, 600 );
149    $window->signal_connect( delete_event => \&_callback_quit, $self );
150
151    $self->{_window} = $window;
152    $self->{_vbox}   = $vbox;
153}
154
155sub create_menu {
156    my ($self) = @_;
157
158    my $window = $self->{_window};
159    my $vbox   = $self->{_vbox};
160
161    my $ui = <<"UI";
162<ui>
163  <menubar>
164    <menu action="test_menu">
165      <menuitem action="quit_item" />
166    </menu>
167  </menubar>
168</ui>
169UI
170
171    my $actions = [
172        [ "test_menu", undef, "_Tests" ],
173        [   "quit_item",
174            "gtk-quit",
175            "_Quit",
176            "<control>Q",
177            "Quit the test runner",
178            sub { _callback_quit( undef, undef, $self ) },
179        ],
180    ];
181
182    my $action_group = Gtk2::ActionGroup->new("main");
183    $action_group->add_actions($actions);
184
185    my $manager = Gtk2::UIManager->new();
186    $manager->insert_action_group( $action_group, 0 );
187    $manager->add_ui_from_string($ui);
188
189    my $menu_box = Gtk2::VBox->new( FALSE, 0 );
190    $manager->signal_connect(
191        add_widget => sub {
192            my ( $manager, $widget ) = @_;
193            $menu_box->pack_start( $widget, FALSE, FALSE, 0 );
194        }
195    );
196
197    $vbox->pack_start( $menu_box, FALSE, FALSE, 0 );
198    $window->add_accel_group( $manager->get_accel_group() );
199
200    $self->{_manager} = $manager;
201}
202
203sub create_view {
204    my ($self) = @_;
205
206    my $window = $self->{_window};
207    my $vbox   = $self->{_vbox};
208
209    my $scroller = Gtk2::ScrolledWindow->new();
210    $scroller->set_policy( "never", "automatic" );
211
212    my $model = Gtk2::ListStore->new(
213
214        #  filename     total     run       pass      fail      skip      todo
215        qw(Glib::String Glib::Int Glib::Int Glib::Int Glib::Int Glib::Int Glib::Int)
216    );
217    my $view = Gtk2::TreeView->new($model);
218
219 # ------------------------------------------------------------------------- #
220
221    my $column_filename = Gtk2::TreeViewColumn->new_with_attributes(
222        "Filename",
223        Gtk2::CellRendererText->new(),
224        text => COLUMN_FILENAME
225    );
226    $column_filename->set_sizing("autosize");
227    $column_filename->set_expand(TRUE);
228    $view->append_column($column_filename);
229
230 # ------------------------------------------------------------------------- #
231
232    my $renderer_progress = Gtk2::CellRendererProgress->new();
233    my $column_progress   = Gtk2::TreeViewColumn->new_with_attributes(
234        "Progress",
235        $renderer_progress
236    );
237    $column_progress->set_cell_data_func(
238        $renderer_progress,
239        sub {
240            my ( $column, $renderer, $model, $iter ) = @_;
241
242            my ( $total, $run )
243              = $model->get( $iter, COLUMN_TOTAL, COLUMN_RUN );
244
245            if ( $run == 0 ) {
246                $renderer->set(
247                    text  => "",
248                    value => 0
249                );
250                return;
251            }
252
253            if ( $total != 0 ) {
254                $renderer->set(
255                    text  => "$run/$total",
256                    value => $run / $total * 100
257                );
258            }
259            else {
260                $renderer->set(
261                    text  => $run,
262                    value => 0
263                );
264            }
265        }
266    );
267    $view->append_column($column_progress);
268
269 # ------------------------------------------------------------------------- #
270
271    my @count_columns = (
272        [ "Pass", COLUMN_PASS ],
273        [ "Fail", COLUMN_FAIL ],
274        [ "Skip", COLUMN_SKIP ],
275        [ "Todo", COLUMN_TODO ],
276    );
277
278    foreach (@count_columns) {
279        my ( $heading, $column_number ) = @{$_};
280
281        my $renderer = Gtk2::CellRendererText->new();
282        $renderer->set( xalign => 1.0 );
283
284        my $column = Gtk2::TreeViewColumn->new_with_attributes(
285            $heading,
286            $renderer,
287            text => $column_number
288        );
289
290        $view->append_column($column);
291    }
292
293 # ------------------------------------------------------------------------- #
294
295    $scroller->add($view);
296    $vbox->pack_start( $scroller, TRUE, TRUE, 0 );
297
298    $self->{_view}  = $view;
299    $self->{_model} = $model;
300}
301
302sub run {
303    my ($self) = @_;
304
305    $self->{_window}->show_all();
306
307    Gtk2->main();
308}
309
310# --------------------------------------------------------------------------- #
311
312sub _callback_reader {
313    my ( $fileno, $condition, $self ) = @_;
314
315    if ( $condition & "in" || $condition & "pri" ) {
316        my $data = <$reader>;
317
318        if ( $data !~ /^[^\t]+ \t \d+ \t \d+ \t \d+ \t \d+ \t \d+ \t \d+$/x )
319        {
320            return TRUE;
321        }
322
323        my ( $filename, $total, $run, $pass, $fail, $skip, $todo )
324          = split /\t/, $data;
325
326        my $view       = $self->{_view};
327        my $model      = $self->{_model};
328        my $path_cache = $self->{_path_cache};
329
330        if ( $path_cache->{$filename} ) {
331            my $iter = $model->get_iter( $path_cache->{$filename} );
332            $model->set(
333                $iter,
334                COLUMN_TOTAL, $total,
335                COLUMN_RUN,   $run,
336                COLUMN_PASS,  $pass,
337                COLUMN_FAIL,  $fail,
338                COLUMN_SKIP,  $skip,
339                COLUMN_TODO,  $todo
340            );
341            $view->scroll_to_cell( $path_cache->{$filename} );
342        }
343    }
344
345    elsif ( $condition & "hup" ) {
346        $self->{child_running} = FALSE;
347        return FALSE;
348    }
349
350    else {
351        warn "got unknown condition: $condition";
352        return FALSE;
353    }
354
355    return TRUE;
356}
357
358sub _callback_quit {
359    my ( $window, $event, $self ) = @_;
360
361    if ( $self->{child_running} ) {
362        kill "TERM", $self->{child_pid};
363    }
364
365    Gtk2->main_quit();
366}
367
368###############################################################################
369# --------------------------------------------------------------------------- #
370###############################################################################
371
372package TestRunner;
373
374use TAP::Parser;
375use TAP::Parser::Source::Perl;
376
377use constant {
378    INDEX_TOTAL => 0,
379    INDEX_RUN   => 1,
380    INDEX_PASS  => 2,
381    INDEX_FAIL  => 3,
382    INDEX_SKIP  => 4,
383    INDEX_TODO  => 5,
384};
385
386sub new {
387    my ( $class, $writer ) = @_;
388
389    my $self = bless {}, $class;
390
391    $self->{_writer} = $writer;
392
393    return $self;
394}
395
396sub add_tests {
397    my ( $self, @tests ) = @_;
398
399    $self->{_tests} = [@tests];
400
401    $self->{_results} = {};
402    foreach my $test ( @{ $self->{_tests} } ) {
403        $self->{_results}->{$test} = [ 0, 0, 0, 0, 0, 0 ];
404    }
405}
406
407sub run {
408    my ($self) = @_;
409
410    my $source = TAP::Parser::Source::Perl->new();
411
412    foreach my $test ( @{ $self->{_tests} } ) {
413        my $parser = TAP::Parser->new( { source => $test } );
414        $self->analyze( $test, $parser ) if $parser;
415    }
416
417    my $writer = $self->{_writer};
418    $writer->flush();
419    $writer->print("\n");
420}
421
422sub analyze {
423    my ( $self, $test, $parser ) = @_;
424
425    my $writer = $self->{_writer};
426    my $result = $self->{_results}->{$test};
427
428    while ( my $line = $parser->next() ) {
429        if ( $line->is_plan() ) {
430            $result->[INDEX_TOTAL] = $line->tests_planned();
431        }
432
433        elsif ( $line->is_test() ) {
434            $result->[INDEX_RUN]++;
435
436            if ( $line->has_skip() ) {
437                $result->[INDEX_SKIP]++;
438                next;
439            }
440
441            if ( $line->has_todo() ) {
442                $result->[INDEX_TODO]++;
443            }
444
445            if ( $line->is_ok() ) {
446                $result->[INDEX_PASS]++;
447            }
448            else {
449                $result->[INDEX_FAIL]++;
450            }
451        }
452
453        elsif ( $line->is_comment() ) {
454
455            # ignore
456        }
457
458        else {
459            warn "Unknown result type `"
460              . $line->type() . "�: "
461              . $line->as_string();
462        }
463
464        my $string = join "\t", $test, @{$result};
465        $writer->print("$string\n");
466    }
467
468    return $parser;
469}
470