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