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