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/;
  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_package_without_redefine_warnings {
  42     my ($pkg, $code) = @_;
  43
  44     my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
  45
  46     local $SIG{__WARN__} = sub {
  47         $warn_handler->(@_)
  48             unless $_[0] =~ /^Subroutine \S+ redefined/;
  49     };
  50
  51     # This hairiness is to handle people using "use warnings FATAL => 'all';"
  52     # in their custom or external content.
  53     my @delete_syms;
  54     my $try_again = 1;
  55
  56     while ($try_again) {
  57         eval $code;
  58
  59         if (my ($sym) = $@ =~ /^Subroutine (\S+) redefined/) {
  60             delete $INC{ +class_path($pkg) };
  61             push @delete_syms, $sym;
  62
  63             foreach my $sym (@delete_syms) {
  64                 no strict 'refs';
  65                 undef *{"${pkg}::${sym}"};
  66             }
  67         }
  68         elsif ($@) {
  69             die $@ if $@;
  70         }
  71         else {
  72             $try_again = 0;
  73         }
  74     }
  75 }
  76
  77 sub class_path {
  78     my $class = shift;
  79
  80     my $class_path = $class;
  81     $class_path =~ s{::}{/}g;
  82     $class_path .= '.pm';
  83
  84     return $class_path;
  85 }
  86
  87 sub no_warnings(&;$) {
  88     my ($code, $test_name) = @_;
  89
  90     my $failed = 0;
  91
  92     my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
  93     local $SIG{__WARN__} = sub {
  94         $failed = 1;
  95         $warn_handler->(@_);
  96     };
  97
  98     $code->();
  99
 100     ok ((not $failed), $test_name);
 101 }
 102
 103 sub warnings_exist(&$$) {
 104     my ($code, $re, $test_name) = @_;
 105
 106     my $matched = 0;
 107
 108     my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
 109     local $SIG{__WARN__} = sub {
 110         if ($_[0] =~ $re) {
 111             $matched = 1;
 112         }
 113         else {
 114             $warn_handler->(@_)
 115         }
 116     };
 117
 118     $code->();
 119
 120     ok $matched, $test_name;
 121 }
 122
 123 sub warnings_exist_silent(&$$) {
 124     my ($code, $re, $test_name) = @_;
 125
 126     my $matched = 0;
 127
 128     local $SIG{__WARN__} = sub { $matched = 1 if $_[0] =~ $re; };
 129
 130     $code->();
 131
 132     ok $matched, $test_name;
 133 }
 134
 135
 136 1;
 137 # vim:et sts=4 sw=4 tw=0: