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