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 File::Slurp 'read_file';
   9 use namespace::clean;
  10 use Exporter 'import';
  11
  12 our @EXPORT_OK = qw/split_name dumper dumper_squashed eval_package_without_redefine_warnings class_path no_warnings warnings_exist warnings_exist_silent slurp_file/;
  13
  14 use constant BY_CASE_TRANSITION =>
  15     qr/(?<=[[:lower:]\d])[\W_]*(?=[[:upper:]])|[\W_]+/;
  16
  17 use constant BY_NON_ALPHANUM =>
  18     qr/[\W_]+/;
  19
  20 my $LF   = "\x0a";
  21 my $CRLF = "\x0d\x0a";
  22
  23 sub split_name($) {
  24     my $name = shift;
  25
  26     split $name =~ /[[:upper:]]/ && $name =~ /[[:lower:]]/ ? BY_CASE_TRANSITION : BY_NON_ALPHANUM, $name;
  27 }
  28
  29 sub dumper($) {
  30     my $val = shift;
  31
  32     my $dd = Data::Dumper->new([]);
  33     $dd->Terse(1)->Indent(1)->Useqq(1)->Deparse(1)->Quotekeys(0)->Sortkeys(1);
  34     return $dd->Values([ $val ])->Dump;
  35 }
  36
  37 sub dumper_squashed($) {
  38     my $val = shift;
  39
  40     my $dd = Data::Dumper->new([]);
  41     $dd->Terse(1)->Indent(1)->Useqq(1)->Deparse(1)->Quotekeys(0)->Sortkeys(1)->Indent(0);
  42     return $dd->Values([ $val ])->Dump;
  43 }
  44
  45 sub eval_package_without_redefine_warnings {
  46     my ($pkg, $code) = @_;
  47
  48     my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
  49
  50     local $SIG{__WARN__} = sub {
  51         $warn_handler->(@_)
  52             unless $_[0] =~ /^Subroutine \S+ redefined/;
  53     };
  54
  55     # This hairiness is to handle people using "use warnings FATAL => 'all';"
  56     # in their custom or external content.
  57     my @delete_syms;
  58     my $try_again = 1;
  59
  60     while ($try_again) {
  61         eval $code;
  62
  63         if (my ($sym) = $@ =~ /^Subroutine (\S+) redefined/) {
  64             delete $INC{ +class_path($pkg) };
  65             push @delete_syms, $sym;
  66
  67             foreach my $sym (@delete_syms) {
  68                 no strict 'refs';
  69                 undef *{"${pkg}::${sym}"};
  70             }
  71         }
  72         elsif ($@) {
  73             die $@ if $@;
  74         }
  75         else {
  76             $try_again = 0;
  77         }
  78     }
  79 }
  80
  81 sub class_path {
  82     my $class = shift;
  83
  84     my $class_path = $class;
  85     $class_path =~ s{::}{/}g;
  86     $class_path .= '.pm';
  87
  88     return $class_path;
  89 }
  90
  91 sub no_warnings(&;$) {
  92     my ($code, $test_name) = @_;
  93
  94     my $failed = 0;
  95
  96     my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
  97     local $SIG{__WARN__} = sub {
  98         $failed = 1;
  99         $warn_handler->(@_);
 100     };
 101
 102     $code->();
 103
 104     ok ((not $failed), $test_name);
 105 }
 106
 107 sub warnings_exist(&$$) {
 108     my ($code, $re, $test_name) = @_;
 109
 110     my $matched = 0;
 111
 112     my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
 113     local $SIG{__WARN__} = sub {
 114         if ($_[0] =~ $re) {
 115             $matched = 1;
 116         }
 117         else {
 118             $warn_handler->(@_)
 119         }
 120     };
 121
 122     $code->();
 123
 124     ok $matched, $test_name;
 125 }
 126
 127 sub warnings_exist_silent(&$$) {
 128     my ($code, $re, $test_name) = @_;
 129
 130     my $matched = 0;
 131
 132     local $SIG{__WARN__} = sub { $matched = 1 if $_[0] =~ $re; };
 133
 134     $code->();
 135
 136     ok $matched, $test_name;
 137 }
 138
 139 sub slurp_file($) {
 140     my $data = read_file(shift, binmode => ':encoding(UTF-8)');
 141
 142     $data =~ s/$CRLF|$LF/\n/g;
 143
 144     return $data;
 145 }
 146
 147 1;
 148 # vim:et sts=4 sw=4 tw=0: