Switch travis-perl tests to 5.18

[dbsrgits/DBIx-Class.git] / t / 106dbic_carp.t

use strict;
use warnings;

# without this the stacktrace of $schema will be activated
BEGIN { $ENV{DBIC_TRACE} = 0 }

use Test::More;
use Test::Warn;
use Test::Exception;
use DBIx::Class::Carp;
use lib 't/lib';
use DBICTest;

{
  sub DBICTest::DBICCarp::frobnicate {
    DBICTest::DBICCarp::branch1();
    DBICTest::DBICCarp::branch2();
  }

  sub DBICTest::DBICCarp::branch1 { carp_once 'carp1' }
  sub DBICTest::DBICCarp::branch2 { carp_once 'carp2' }


  warnings_exist {
    DBICTest::DBICCarp::frobnicate();
  } [
    qr/carp1/,
    qr/carp2/,
  ], 'expected warnings from carp_once';
}

{
  {
    package DBICTest::DBICCarp::Exempt;
    use DBIx::Class::Carp;

    sub _skip_namespace_frames { qr/^DBICTest::DBICCarp::Exempt/ }

    sub thrower {
      sub {
        DBICTest->init_schema(no_deploy => 1)->storage->dbh_do(sub {
          shift->throw_exception('time to die');
        })
      }->();
    }

    sub dcaller {
      sub {
        thrower();
      }->();
    }

    sub warner {
      eval {
        sub {
          eval {
            carp ('time to warn')
          }
        }->()
      }
    }

    sub wcaller {
      warner();
    }
  }

  # the __LINE__ relationship below is important - do not reformat
  throws_ok { DBICTest::DBICCarp::Exempt::dcaller() }
    qr/\QDBICTest::DBICCarp::Exempt::thrower(): time to die at @{[ __FILE__ ]} line @{[ __LINE__ - 1 ]}\E$/,
    'Expected exception callsite and originator'
  ;

  # the __LINE__ relationship below is important - do not reformat
  warnings_like { DBICTest::DBICCarp::Exempt::wcaller() }
    qr/\QDBICTest::DBICCarp::Exempt::warner(): time to warn at @{[ __FILE__ ]} line @{[ __LINE__ - 1 ]}\E$/,
  ;
}

done_testing;