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