lib/DBIx/Class/Schema/Loader/Utils.pm

   1 package # hide from PAUSE
   2     DBIx::Class::Schema::Loader::Utils;
   3
   4 use strict;
   5 use warnings;
   6 use Data::Dumper ();
   7 use Test::More;
   8 use namespace::clean;
   9 use Exporter 'import';
  10
  11 our @EXPORT_OK = qw/split_name dumper dumper_squashed eval_without_redefine_warnings warnings_exist warnings_exist_silent/;
  12
  13 use constant BY_CASE_TRANSITION =>
  14     qr/(?<=[[:lower:]\d])[\W_]*(?=[[:upper:]])|[\W_]+/;
  15
  16 use constant BY_NON_ALPHANUM =>
  17     qr/[\W_]+/;
  18
  19 sub split_name($) {
  20     my $name = shift;
  21
  22     split $name =~ /[[:upper:]]/ && $name =~ /[[:lower:]]/ ? BY_CASE_TRANSITION : BY_NON_ALPHANUM, $name;
  23 }
  24
  25 sub dumper($) {
  26     my $val = shift;
  27
  28     my $dd = Data::Dumper->new([]);
  29     $dd->Terse(1)->Indent(1)->Useqq(1)->Deparse(1)->Quotekeys(0)->Sortkeys(1);
  30     return $dd->Values([ $val ])->Dump;
  31 }
  32
  33 sub dumper_squashed($) {
  34     my $val = shift;
  35
  36     my $dd = Data::Dumper->new([]);
  37     $dd->Terse(1)->Indent(1)->Useqq(1)->Deparse(1)->Quotekeys(0)->Sortkeys(1)->Indent(0);
  38     return $dd->Values([ $val ])->Dump;
  39 }
  40
  41 sub eval_without_redefine_warnings {
  42     my $code = shift;
  43
  44     my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
  45     local $SIG{__WARN__} = sub {
  46         $warn_handler->(@_)
  47             unless $_[0] =~ /^Subroutine \S+ redefined/;
  48     };
  49     eval $code;
  50     die $@ if $@;
  51 }
  52
  53 sub warnings_exist(&$$) {
  54     my ($code, $re, $test_name) = @_;
  55
  56     my $matched = 0;
  57
  58     my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
  59     local $SIG{__WARN__} = sub {
  60         if ($_[0] =~ $re) {
  61             $matched = 1;
  62         }
  63         else {
  64             $warn_handler->(@_)
  65         }
  66     };
  67
  68     $code->();
  69
  70     ok $matched, $test_name;
  71 }
  72
  73 sub warnings_exist_silent(&$$) {
  74     my ($code, $re, $test_name) = @_;
  75
  76     my $matched = 0;
  77
  78     local $SIG{__WARN__} = sub { $matched = 1 if $_[0] =~ $re; };
  79
  80     $code->();
  81
  82     ok $matched, $test_name;
  83 }
  84
  85
  86 1;
  87 # vim:et sts=4 sw=4 tw=0: