1package Alien::wxWidgets::Utility;
2
3=head1 NAME
4
5Alien::wxWidgets::Utility - INTERNAL: do not use
6
7=cut
8
9use strict;
10use base qw(Exporter);
11use Config;
12use File::Basename qw();
13
14BEGIN {
15    if( $^O eq 'MSWin32' && $Config{_a} ne $Config{lib_ext} ) {
16        print STDERR <<EOT;
17
18\$Config{_a} is '$Config{_a}' and \$Config{lib_ext} is '$Config{lib_ext}':
19they need to be equal for the build to succeed. If you are using ActivePerl
20with MinGW/GCC, please:
21
22- install ExtUtils::FakeConfig
23- set PERL5OPT=-MConfig_m
24- rerun Build.PL
25
26EOT
27        exit 1;
28    }
29}
30
31our $VERSION = '0.59';
32
33our @EXPORT_OK = qw(awx_capture awx_cc_is_gcc awx_cc_version awx_cc_abi_version
34                    awx_sort_config awx_grep_config awx_smart_config);
35
36my $quotes = $^O =~ /MSWin32/ ? '"' : "'";
37my $compiler_checked = '';
38
39sub _exename {
40    return File::Basename::basename( lc $_[0], '.exe' );
41}
42
43sub _warn_nonworking_compiler {
44    my( $cc ) = @_;
45
46    return if $compiler_checked eq $cc;
47
48    eval { require ExtUtils::CBuilder; };
49    return if $@; # avoid failing when called a Build.PL time
50
51    # a C++ compiler can act as a linker, except for MS cl.exe
52    my $ld = _exename( $Config{cc} ) eq 'cl' ? 'link' : $cc;
53    my $b = ExtUtils::CBuilder->new( config => { cc => $cc, ld => $ld },
54                                     quiet  => 1,
55                                     );
56
57    if( !$b->have_compiler ) {
58        print STDERR <<EOT;
59
60ATTENTION: It apperars '$cc' is not a working compiler, please make
61sure all necessary packages are installed.
62
63EOT
64        sleep 5;
65    }
66
67    $compiler_checked = $cc;
68}
69
70sub awx_capture {
71    qx!$^X -e ${quotes}open STDERR, q[>&STDOUT]; exec \@ARGV${quotes} -- $_[0]!;
72}
73
74sub awx_cc_is_msvc {
75    my( $cc ) = @_;
76
77    return ( $^O =~ /MSWin32/ and $cc =~ /^cl/i ) ? 1 : 0;
78}
79
80sub awx_cc_is_gcc {
81    my( $cc ) = @_;
82
83    return    scalar( awx_capture( "$cc --version" ) =~ m/(cc|\+\+)/i ) # 3.x
84           || scalar( awx_capture( "$cc --version" ) =~ m/clang/i) # clang
85           || scalar( awx_capture( "$cc" ) =~ m/gcc/i );          # 2.95
86}
87
88sub awx_cc_abi_version {
89    my( $cc ) = @_;
90
91    _warn_nonworking_compiler( $cc );
92
93    my $is_gcc = awx_cc_is_gcc( $cc );
94    my $is_msvc = awx_cc_is_msvc( $cc );
95    return 0 unless $is_gcc || $is_msvc;
96    my $ver = awx_cc_version( $cc );
97    if( $is_gcc ) {
98        return 0 unless $ver > 0;
99        return '3.4' if $ver >= 3.4;
100        return '3.2' if $ver >= 3.2;
101        return $ver;
102    } elsif( $is_msvc ) {
103        return 0 if $ver < 7;
104        return $ver;
105    }
106}
107
108sub awx_cc_version {
109    my( $cc ) = @_;
110
111    _warn_nonworking_compiler( $cc );
112
113    my $is_gcc = awx_cc_is_gcc( $cc );
114    my $is_msvc = awx_cc_is_msvc( $cc );
115    return 0 unless $is_gcc || $is_msvc;
116
117    if( $is_gcc ) {
118        my $ver = awx_capture( "$cc --version" );
119        return 3.4 if ($ver =~ m/clang/i);
120        $ver =~ m/(\d+\.\d+)(?:\.\d+)?/ or return 0;
121        return $1;
122    } elsif( $is_msvc ) {
123        my $ver = awx_capture( $cc );
124        $ver =~ m/(\d+\.\d+)\.\d+/ or return 0;
125        return 8.0 if $1 >= 14;
126        return 7.1 if $1 >= 13.10;
127        return 7.0 if $1 >= 13;
128        return 6.0 if $1 >= 12;
129        return 5.0 if $1 >= 11;
130        return 0;
131    }
132}
133
134sub awx_compiler_kind {
135    my( $cc ) = @_;
136
137    _warn_nonworking_compiler( $cc );
138
139    return 'gcc' if awx_cc_is_gcc( $cc );
140    return 'cl'  if awx_cc_is_msvc( $cc );
141
142    return 'nc'; # as in 'No Clue'
143}
144
145# sort a list of configurations by version, debug/release, unicode/ansi, mslu
146sub awx_sort_config {
147    # comparison functions treating undef as 0 or ''
148    # numerico comparison
149    my $make_cmpn = sub {
150        my $k = shift;
151        sub { exists $a->{$k} && exists $b->{$k} ? $a->{$k} <=> $b->{$k} :
152              exists $a->{$k}                    ? 1                     :
153              exists $b->{$k}                    ? -1                    :
154                                                   0 }
155    };
156    # string comparison
157    my $make_cmps = sub {
158        my $k = shift;
159        sub { exists $a->{$k} && exists $b->{$k} ? $a->{$k} cmp $b->{$k} :
160              exists $a->{$k}                    ? 1                     :
161              exists $b->{$k}                    ? -1                    :
162                                                   0 }
163    };
164    # reverse comparison
165    my $rev = sub { my $cmp = shift; sub { -1 * &$cmp } };
166    # compare by different criteria, using the first nonzero as tie-breaker
167    my $crit_sort = sub {
168        my @crit = @_;
169        sub {
170            foreach ( @crit ) {
171                my $cmp = &$_;
172                return $cmp if $cmp;
173            }
174
175            return 0;
176        }
177    };
178
179    my $cmp = $crit_sort->( $make_cmpn->( 'version' ),
180                            $rev->( $make_cmpn->( 'debug' ) ),
181                            $make_cmpn->( 'unicode' ),
182                            $make_cmpn->( 'mslu' ) );
183
184    return reverse sort $cmp @_;
185}
186
187sub awx_grep_config {
188    my( $cfgs ) = shift;
189    my( %a ) = @_;
190    # compare to a numeric range or value
191    # low extreme included, high extreme excluded
192    # if $a{key} = [ lo, hi ] then range else low extreme
193    my $make_cmpr = sub {
194        my $k = shift;
195        sub {
196            return 1 unless exists $a{$k};
197            ref $a{$k} ? $a{$k}[0] <= $_->{$k} && $_->{$k} < $a{$k}[1] :
198                         $a{$k}    <= $_->{$k};
199        }
200    };
201    # compare for numeric equality
202    my $make_cmpn = sub {
203        my $k = shift;
204        sub { exists $a{$k} ? $a{$k} == $_->{$k} : 1 }
205    };
206    # compare for string equality
207    my $make_cmps = sub {
208        my $k = shift;
209        sub { exists $a{$k} ? $a{$k} eq $_->{$k} : 1 }
210    };
211    my $compare_tk = sub {
212        return 1 unless exists $a{toolkit};
213        my $atk = $a{toolkit} eq 'mac'   ? 'osx_carbon' :
214                                           $a{toolkit};
215        my $btk = $_->{toolkit} eq 'mac' ? 'osx_carbon' :
216                                           $_->{toolkit};
217        return $atk eq $btk;
218    };
219
220    # note tha if the criteria was not supplied, the comparison is a noop
221    my $wver = $make_cmpr->( 'version' );
222    my $ckind = $make_cmps->( 'compiler_kind' );
223    my $cver = $make_cmpn->( 'compiler_version' );
224    my $tkit = $compare_tk;
225    my $deb = $make_cmpn->( 'debug' );
226    my $uni = $make_cmpn->( 'unicode' );
227    my $mslu = $make_cmpn->( 'mslu' );
228    my $key = $make_cmps->( 'key' );
229
230    grep { &$wver  } grep { &$ckind } grep { &$cver  }
231    grep { &$tkit  } grep { &$deb   } grep { &$uni   }
232    grep { &$mslu  } grep { &$key   }
233         @{$cfgs}
234}
235
236# automatically add compiler data unless the key was supplied
237sub awx_smart_config {
238    my( %args ) = @_;
239    # the key already identifies the configuration
240    return %args if $args{key};
241
242    my $cc = $ENV{CXX} || $ENV{CC} || $Config{ccname} || $Config{cc};
243    my $kind = awx_compiler_kind( $cc );
244    my $version = awx_cc_abi_version( $cc );
245
246    $args{compiler_kind} ||= $kind;
247    $args{compiler_version} ||= $version;
248
249    return %args;
250}
251
252# allow to remap srings in the configuration; useful when building
253# archives
254my @prefixes;
255
256BEGIN {
257    if( $ENV{ALIEN_WX_PREFIXES} ) {
258        my @kv = split /,\s*/, $ENV{ALIEN_WX_PREFIXES};
259
260        while( @kv ) {
261            my( $match, $repl ) = ( shift( @kv ) || '', shift( @kv ) || '' );
262
263            push @prefixes, [ $match, $^O eq 'MSWin32' ?
264                                          qr/\Q$match\E/i :
265                                          qr/\Q$match\E/, $repl ];
266        }
267    }
268}
269
270sub _awx_remap {
271    my( $string ) = @_;
272    return $string if ref $string;
273    return $string if $Alien::wxWidgets::dont_remap;
274
275    foreach my $prefix ( @prefixes ) {
276        my( $str, $rx, $repl ) = @$prefix;
277
278        $string =~ s{$rx(\S*)}{$repl$1}g;
279    }
280
281    return $string;
282}
283
2841;
285