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 List::Util 'all';
  10 use Data::Dumper ();
  11 use base 'Exporter';
  12 use namespace::clean;
  13
  14
  15 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 array_eq sigwarn_silencer apply firstidx uniq/;
  16
  17 use constant BY_CASE_TRANSITION_V7 =>
  18     qr/(?<=[[:lower:]\d])[\W_]*(?=[[:upper:]])|[\W_]+/;
  19
  20 use constant BY_NON_ALPHANUM =>
  21     qr/[\W_]+/;
  22
  23 my $LF   = "\x0a";
  24 my $CRLF = "\x0d\x0a";
  25
  26 sub split_name($;$) {
  27     my ($name, $v) = @_;
  28
  29     my $is_camel_case = $name =~ /[[:upper:]]/ && $name =~ /[[:lower:]]/;
  30
  31     if ((not $v) || $v >= 8) {
  32         return map split(BY_NON_ALPHANUM, $_), wordsplit($name);
  33     }
  34
  35     return split $is_camel_case ? BY_CASE_TRANSITION_V7 : BY_NON_ALPHANUM, $name;
  36 }
  37
  38 sub dumper($) {
  39     my $val = shift;
  40
  41     my $dd = Data::Dumper->new([]);
  42     $dd->Terse(1)->Indent(1)->Useqq(1)->Deparse(1)->Quotekeys(0)->Sortkeys(1);
  43     return $dd->Values([ $val ])->Dump;
  44 }
  45
  46 sub dumper_squashed($) {
  47     my $val = shift;
  48
  49     my $dd = Data::Dumper->new([]);
  50     $dd->Terse(1)->Indent(1)->Useqq(1)->Deparse(1)->Quotekeys(0)->Sortkeys(1)->Indent(0);
  51     return $dd->Values([ $val ])->Dump;
  52 }
  53
  54 # copied from DBIx::Class::_Util, import from there once it's released
  55 sub sigwarn_silencer {
  56     my $pattern = shift;
  57
  58     croak "Expecting a regexp" if ref $pattern ne 'Regexp';
  59
  60     my $orig_sig_warn = $SIG{__WARN__} || sub { CORE::warn(@_) };
  61
  62     return sub { &$orig_sig_warn unless $_[0] =~ $pattern };
  63 }
  64
  65 # Copied with stylistic adjustments from List::MoreUtils::PP
  66 sub firstidx (&@) {
  67     my $f = shift;
  68     foreach my $i (0..$#_) {
  69         local *_ = \$_[$i];
  70         return $i if $f->();
  71     }
  72     return -1;
  73 }
  74
  75 sub uniq (@) {
  76     my %seen = ();
  77     grep { not $seen{$_}++ } @_;
  78 }
  79
  80 sub apply (&@) {
  81     my $action = shift;
  82     $action->() foreach my @values = @_;
  83     wantarray ? @values : $values[-1];
  84 }
  85
  86 sub eval_package_without_redefine_warnings {
  87     my ($pkg, $code) = @_;
  88
  89     local $SIG{__WARN__} = sigwarn_silencer(qr/^Subroutine \S+ redefined/);
  90
  91     # This hairiness is to handle people using "use warnings FATAL => 'all';"
  92     # in their custom or external content.
  93     my @delete_syms;
  94     my $try_again = 1;
  95
  96     while ($try_again) {
  97         eval $code;
  98
  99         if (my ($sym) = $@ =~ /^Subroutine (\S+) redefined/) {
 100             delete $INC{ +class_path($pkg) };
 101             push @delete_syms, $sym;
 102
 103             foreach my $sym (@delete_syms) {
 104                 no strict 'refs';
 105                 undef *{"${pkg}::${sym}"};
 106             }
 107         }
 108         elsif ($@) {
 109             die $@ if $@;
 110         }
 111         else {
 112             $try_again = 0;
 113         }
 114     }
 115 }
 116
 117 sub class_path {
 118     my $class = shift;
 119
 120     my $class_path = $class;
 121     $class_path =~ s{::}{/}g;
 122     $class_path .= '.pm';
 123
 124     return $class_path;
 125 }
 126
 127 sub no_warnings(&;$) {
 128     my ($code, $test_name) = @_;
 129
 130     my $failed = 0;
 131
 132     my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
 133     local $SIG{__WARN__} = sub {
 134         $failed = 1;
 135         $warn_handler->(@_);
 136     };
 137
 138     $code->();
 139
 140     ok ((not $failed), $test_name);
 141 }
 142
 143 sub warnings_exist(&$$) {
 144     my ($code, $re, $test_name) = @_;
 145
 146     my $matched = 0;
 147
 148     my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
 149     local $SIG{__WARN__} = sub {
 150         if ($_[0] =~ $re) {
 151             $matched = 1;
 152         }
 153         else {
 154             $warn_handler->(@_)
 155         }
 156     };
 157
 158     $code->();
 159
 160     ok $matched, $test_name;
 161 }
 162
 163 sub warnings_exist_silent(&$$) {
 164     my ($code, $re, $test_name) = @_;
 165
 166     my $matched = 0;
 167
 168     local $SIG{__WARN__} = sub { $matched = 1 if $_[0] =~ $re; };
 169
 170     $code->();
 171
 172     ok $matched, $test_name;
 173 }
 174
 175 sub slurp_file($) {
 176     my $file_name = shift;
 177
 178     open my $fh, '<:encoding(UTF-8)', $file_name,
 179         or croak "Can't open '$file_name' for reading: $!";
 180
 181     my $data = do { local $/; <$fh> };
 182
 183     close $fh;
 184
 185     $data =~ s/$CRLF|$LF/\n/g;
 186
 187     return $data;
 188 }
 189
 190 sub write_file($$) {
 191     my $file_name = shift;
 192
 193     open my $fh, '>:encoding(UTF-8)', $file_name,
 194         or croak "Can't open '$file_name' for writing: $!";
 195
 196     print $fh shift;
 197     close $fh;
 198 }
 199
 200 sub array_eq($$) {
 201     no warnings 'uninitialized';
 202     my ($l, $r) = @_;
 203
 204     return @$l == @$r && all { $l->[$_] eq $r->[$_] } 0..$#$l;
 205 }
 206
 207 1;
 208 # vim:et sts=4 sw=4 tw=0: