libtest-spec-perl 0.54-1 / usr / share / perl5 / Test / Spec / Example.pm

This file is indexed.

/usr/share/perl5/Test/Spec/Example.pm is in libtest-spec-perl 0.54-1.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below. 

  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
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
package Test::Spec::Example;

# Purpose: represents an `it` block

use strict;
use warnings;

########################################################################
# NO USER-SERVICEABLE PARTS INSIDE.
########################################################################

use Carp ();
use Scalar::Util ();

sub new {
  my ($class, $args) = @_;

  if (!$args || ref($args) ne 'HASH') {
    Carp::croak "usage: $class->new(\\%args)";
  }

  my $self = bless {}, $class;
  foreach my $attr ( qw/name description code builder context/ ) {
    $self->{$attr} = $args->{$attr} || Carp::croak "$attr missing";
  }

  Scalar::Util::weaken($self->{context});

  return $self;
}

sub name        { shift->{name} }
sub description { shift->{description} }
sub code        { shift->{code} }
sub builder     { shift->{builder} }
sub context     { shift->{context} }

# Build a stack from the starting context
# down to the current context
sub stack {
  my ($self) = @_;

  my $ctx = $self->context;

  my @ancestors = $ctx;
  while ( $ctx = $ctx->parent ) {
      push @ancestors, $ctx;
  }

  return reverse(@ancestors);
}

sub run  {
  my ($self) = @_;

  # clobber Test::Builder's ok() method just like Test::Class does,
  # but without screwing up underscores.
  no warnings 'redefine';
  my $orig_builder_ok = \&Test::Builder::ok;
  local *Test::Builder::ok = sub {
    my ($builder,$test,$desc) = splice(@_,0,3);
    $desc ||= $self->description;
    local $Test::Builder::Level = $Test::Builder::Level+1;
    $orig_builder_ok->($builder, $test, $desc, @_);
  };

  # Run the test
  eval { $self->_runner($self->stack) };

  # And trap any errors
  if (my $err = $@) {
    my $builder = $self->builder;
    my $description = $self->description;

    # eval in case stringification overload croaks
    chomp($err = eval { $err . '' } || 'unknown error');
    my ($file,$line);
    ($file,$line) = ($1,$2) if ($err =~ s/ at (.+?) line (\d+)\.\Z//);

    # disable ok()'s diagnostics so we can generate a custom TAP message
    my $old_diag = $builder->no_diag;
    $builder->no_diag(1);
    # make sure we can restore no_diag
    eval { $builder->ok(0, $description) };
    my $secondary_err = $@;
    # no_diag needs a defined value, so double-negate it to get either '' or 1
    $builder->no_diag(!!$old_diag);

    unless ($builder->no_diag) {
      # emulate Test::Builder::ok's diagnostics, but with more details
      my ($msg,$diag_fh);
      if ($builder->in_todo) {
        $msg = "Failed (TODO)";
        $diag_fh = $builder->todo_output;
      }
      else {
        $msg = "Failed";
        $diag_fh = $builder->failure_output;
      }
      print {$diag_fh} "\n" if $ENV{HARNESS_ACTIVE};
      print {$builder->failure_output} qq[#   $msg test '$description' by dying:\n];
      print {$builder->failure_output} qq[#     $err\n];
      print {$builder->failure_output} qq[#     at $file line $line.\n] if defined($file);
    }
    die $secondary_err if $secondary_err;
  }
}

sub _runner {
  my ($self, $ctx, @remainder) = @_;

  # This recursive closure essentially does this
  # $outer->contextualize {
  #   $outer->before_each
  #   $inner->contextualize {
  #     $inner->before_each
  #     $anon->contextualize {
  #       $anon->before_each (no-op)
  #         execute test
  #       $anon->after_each (no-op)
  #     }
  #     $inner->after_each
  #   }
  #   $outer->after_each
  # }
  #
  return $ctx->contextualize(sub {
    $ctx->_run_before_all_once;
    $ctx->_run_before('each');
    if ( @remainder ) {
      $self->_runner(@remainder);
    }
    else {
      $ctx->_in_anonymous_context($self->code, $self);
    }
    $ctx->_run_after('each');
    # "after 'all'" only happens during context destruction (DEMOLISH).
    # This is the only way I can think to make this work right
    # in the case that only specific test methods are run.
    # Otherwise, the global teardown would only happen when you
    # happen to run the last test of the context.
  }, $self);
}

1;

APT Browse - Built by Thomas Orozco.