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