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