1package # hide from PAUSE 2 DBIx::Class::Schema::Loader::Utils; 3 4use strict; 5use warnings; 6use Test::More; 7use Carp::Clan qw/^DBIx::Class/; 8use List::Util 'all'; 9use namespace::clean; 10use Exporter 'import'; 11use Data::Dumper (); 12 13our @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 15use constant BY_CASE_TRANSITION_V7 => 16 qr/(?<=[[:lower:]\d])[\W_]*(?=[[:upper:]])|[\W_]+/; 17 18use constant BY_NON_ALPHANUM => 19 qr/[\W_]+/; 20 21my $LF = "\x0a"; 22my $CRLF = "\x0d\x0a"; 23 24# Copied from String::CamelCase because of RT#123030 25sub wordsplit { 26 my $s = shift; 27 split /[_\s]+|\b|(?<![A-Z])(?=[A-Z])|(?<=[A-Z])(?=[A-Z][a-z])/, $s; 28} 29 30sub 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 42sub 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 50sub 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 59sub 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 70sub firstidx (&@) { 71 my $f = shift; 72 foreach my $i (0..$#_) { 73 local *_ = \$_[$i]; 74 return $i if $f->(); 75 } 76 return -1; 77} 78 79sub uniq (@) { 80 my %seen = (); 81 grep { not $seen{$_}++ } @_; 82} 83 84sub apply (&@) { 85 my $action = shift; 86 $action->() foreach my @values = @_; 87 wantarray ? @values : $values[-1]; 88} 89 90sub 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 121sub 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 131sub 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 147sub 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 167sub 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 179sub 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 194sub 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 204sub array_eq($$) { 205 no warnings 'uninitialized'; 206 my ($l, $r) = @_; 207 208 return @$l == @$r && all { $l->[$_] eq $r->[$_] } 0..$#$l; 209} 210 2111; 212# vim:et sts=4 sw=4 tw=0: 213