view release on metacpan or  search on metacpan

lib/Test/Unit/TkTestRunner.pm  view on Meta::CPAN

    $self->{number_of_runs} = $self->{result}->run_count();
    $self->show_info("Running: " . $test->name());
}

sub add_pass {
    my $self = shift;
    my ($test, $exception)=@_;
    $self->update();
}

sub update {
    my $self = shift;
    my $result   = $self->{result};
    my $total    = $result->run_count();
    my $failures = $result->failure_count();
    my $errors   = $result->error_count();
    my $passes   = $total-$failures-$errors;
    my $bad      = $failures+$errors;
    #$passes = $result->run_count();
    my $todo = ($total>$self->{planned})?0:$self->{planned}-$total;
    $self->{progress_bar}->value($passes, $bad, $todo);
    # force entry into the event loop.
    # this makes it nearly like its threaded...
    #sleep 1;
    $self->{frame}->update();
}

sub add_to_history {
    my $self = shift;
    my $new_item = $self->{suite_name};
    my $h = $self->{suite_field};
    my $choices = $h->cget('-choices');
    my @choices = ();
    if (ref($choices)) {
        @choices=@{$h->cget('-choices')};
    }
    elsif ($choices) {
        # extraordinarily bad - choices is a scalar if theres
        # only one, and undefined if there are none!
        @choices = ($h->cget('-choices'));
    }
    @choices = ($new_item, grep {$_ ne $new_item} @choices);
    if (@choices>10) {
        @choices=@choices[0..9];
    }
    $h->configure(-choices => \@choices);
}

package Tk::ArrayBar;
# progressbar doesnt cut it.
# This expects a variable which is an array ref, and
# a matching list of colours. Sortof like stacked progress bars.
# Heavily - ie almost totally - based on the code in ProgressBar.
use Tk;
use Tk::Canvas;
use Tk::ROText;
use Tk::DialogBox;
use Carp;
use strict;

use base qw(Tk::Derived Tk::Canvas);

Construct Tk::Widget 'ArrayBar';

sub ClassInit {
  my ($class, $mw) = @_;

  $class->SUPER::ClassInit($mw);

  $mw->bind($class, '<Configure>', [ '_layoutRequest', 1 ]);
}

sub Populate {
    my($c, $args) = @_;

    $c->ConfigSpecs(
        -width              => [ PASSIVE => undef, undef, 0           ],
        '-length'           => [ PASSIVE => undef, undef, 0           ],
        -padx               => [ PASSIVE => 'padX', 'Pad', 0          ],
        -pady               => [ PASSIVE => 'padY', 'Pad', 0          ],
        -colors             => [ PASSIVE => undef, undef, undef       ],
        -relief             => [ SELF => 'relief', 'Relief', 'sunken' ],
        -value              => [ METHOD  => undef, undef, undef       ],
        -variable           => [ PASSIVE  => undef, undef, [ 0 ]      ],
        -anchor             => [ METHOD  => 'anchor', 'Anchor', 'w'   ],
        -resolution         => [ PASSIVE => undef, undef, 1.0         ],
        -highlightthickness => [
            SELF => 'highlightThickness', 'HighlightThickness', 0
        ],
        -troughcolor        => [
            PASSIVE => 'troughColor', 'Background', 'grey55'
        ],
    );

    _layoutRequest($c, 1);
    $c->OnDestroy([ Destroyed => $c ]);
}

sub anchor {
    my $c = shift;
    my $var = \$c->{Configure}{'-anchor'};
    my $old = $$var;

    if (@_) {
        my $new = shift;
        croak "bad anchor position \"$new\": must be n, s, w or e"
            unless $new =~ /^[news]$/;
        $$var = $new;
    }

    $old;
}

sub _layoutRequest {
    my $c = shift;
    my $why = shift;
    $c->afterIdle([ '_arrange', $c ]) unless $c->{layout_pending};
    $c->{layout_pending} |= $why;
}

sub _arrange {