← Back to branch summary

~ubuntu-branches/ubuntu/saucy/libconvert-pem-perl/saucy

« back to all changes in this revision

Viewing changes to inc/Test/Exception.pm

  • Committer: Bazaar Package Importer
  • Author(s): Jose Luis Rivas, gregor herrmann, Nathan Handler, Jose Luis Rivas
  • Date: 2010-12-25 15:58:17 UTC
  • mfrom: (1.1.1 upstream)
  • Revision ID: james.westby@ubuntu.com-20101225155817-mgdr457j5e61tvem
Tags: 0.08-1
[ gregor herrmann ]
* debian/control: Changed: Switched Vcs-Browser field to ViewSVN
  (source stanza).

[ Nathan Handler ]
* debian/watch: Update to ignore development releases.

[ gregor herrmann ]
* Change my email address.

[ Jose Luis Rivas ]
* New upstream release.
* debian/control: 
        + Added myself to uploaders field.
  + Refreshed.
  + Bumped to Standards-Version 3.9.1 by removing versioned perl and 
  versioning debhelper >= 7.
* debian/compat,copyright: refreshed.
* debian/rules: refreshed to tiny version using DH7.
* debian/libconvert-pem-perl.docs: Added.
* Switch to dpkg-source 3.0 (quilt) format.

Show diffs side-by-side

added added

removed removed

Lines of Context:
inc/Test/Exception.pm
 
1
#line 1
 
2
use strict;
 
3
use warnings;
 
4
 
 
5
package Test::Exception;
 
6
use Test::Builder;
 
7
use Sub::Uplevel qw( uplevel );
 
8
use base qw( Exporter );
 
9
 
 
10
our $VERSION = '0.29';
 
11
our @EXPORT = qw(dies_ok lives_ok throws_ok lives_and);
 
12
 
 
13
my $Tester = Test::Builder->new;
 
14
 
 
15
sub import {
 
16
    my $self = shift;
 
17
    if ( @_ ) {
 
18
        my $package = caller;
 
19
        $Tester->exported_to( $package );
 
20
        $Tester->plan( @_ );
 
21
    };
 
22
    $self->export_to_level( 1, $self, $_ ) foreach @EXPORT;
 
23
}
 
24
 
 
25
#line 83
 
26
 
 
27
sub _quiet_caller (;$) { ## no critic Prototypes
 
28
    my $height = $_[0];
 
29
    $height++;
 
30
    if( wantarray and !@_ ) {
 
31
        return (CORE::caller($height))[0..2];
 
32
    }
 
33
    else {
 
34
        return CORE::caller($height);
 
35
    }
 
36
}
 
37
 
 
38
sub _try_as_caller {
 
39
    my $coderef = shift;
 
40
 
 
41
    # local works here because Sub::Uplevel has already overridden caller
 
42
    local *CORE::GLOBAL::caller;
 
43
    { no warnings 'redefine'; *CORE::GLOBAL::caller = \&_quiet_caller; }
 
44
 
 
45
    eval { uplevel 3, $coderef };
 
46
    return $@;
 
47
};
 
48
 
 
49
 
 
50
sub _is_exception {
 
51
    my $exception = shift;
 
52
    return ref $exception || $exception ne '';
 
53
};
 
54
 
 
55
 
 
56
sub _exception_as_string {
 
57
    my ( $prefix, $exception ) = @_;
 
58
    return "$prefix normal exit" unless _is_exception( $exception );
 
59
    my $class = ref $exception;
 
60
    $exception = "$class ($exception)" 
 
61
            if $class && "$exception" !~ m/^\Q$class/;
 
62
    chomp $exception;
 
63
    return "$prefix $exception";
 
64
};
 
65
 
 
66
 
 
67
#line 168
 
68
 
 
69
 
 
70
sub throws_ok (&$;$) {
 
71
    my ( $coderef, $expecting, $description ) = @_;
 
72
    unless (defined $expecting) {
 
73
      require Carp;
 
74
      Carp::croak( "throws_ok: must pass exception class/object or regex" ); 
 
75
    }
 
76
    $description = _exception_as_string( "threw", $expecting )
 
77
        unless defined $description;
 
78
    my $exception = _try_as_caller( $coderef );
 
79
    my $regex = $Tester->maybe_regex( $expecting );
 
80
    my $ok = $regex 
 
81
        ? ( $exception =~ m/$regex/ ) 
 
82
        : eval { 
 
83
            $exception->isa( ref $expecting ? ref $expecting : $expecting ) 
 
84
        };
 
85
    $Tester->ok( $ok, $description );
 
86
    unless ( $ok ) {
 
87
        $Tester->diag( _exception_as_string( "expecting:", $expecting ) );
 
88
        $Tester->diag( _exception_as_string( "found:", $exception ) );
 
89
    };
 
90
    $@ = $exception;
 
91
    return $ok;
 
92
};
 
93
 
 
94
 
 
95
#line 216
 
96
 
 
97
sub dies_ok (&;$) {
 
98
    my ( $coderef, $description ) = @_;
 
99
    my $exception = _try_as_caller( $coderef );
 
100
    my $ok = $Tester->ok( _is_exception($exception), $description );
 
101
    $@ = $exception;
 
102
    return $ok;
 
103
}
 
104
 
 
105
 
 
106
#line 255
 
107
 
 
108
sub lives_ok (&;$) {
 
109
    my ( $coderef, $description ) = @_;
 
110
    my $exception = _try_as_caller( $coderef );
 
111
    my $ok = $Tester->ok( ! _is_exception( $exception ), $description );
 
112
        $Tester->diag( _exception_as_string( "died:", $exception ) ) unless $ok;
 
113
    $@ = $exception;
 
114
    return $ok;
 
115
}
 
116
 
 
117
 
 
118
#line 295
 
119
 
 
120
sub lives_and (&;$) {
 
121
    my ( $test, $description ) = @_;
 
122
    {
 
123
        local $Test::Builder::Level = $Test::Builder::Level + 1;
 
124
        my $ok = \&Test::Builder::ok;
 
125
        no warnings;
 
126
        local *Test::Builder::ok = sub {
 
127
            $_[2] = $description unless defined $_[2];
 
128
            $ok->(@_);
 
129
        };
 
130
        use warnings;
 
131
        eval { $test->() } and return 1;
 
132
    };
 
133
    my $exception = $@;
 
134
    if ( _is_exception( $exception ) ) {
 
135
        $Tester->ok( 0, $description );
 
136
        $Tester->diag( _exception_as_string( "died:", $exception ) );
 
137
    };
 
138
    $@ = $exception;
 
139
    return;
 
140
}
 
141
 
 
142
#line 462
 
143
 
 
144
1;