xref: /petsc/lib/petsc/bin/maint/abi-compliance-checker/modules/Internals/Utils.pm (revision e8b6250908b962c387f7ab2e7b38caaa661b5fa1) ! 
1###########################################################################
2# A module with basic functions
3#
4# Copyright (C) 2015-2018 Andrey Ponomarenko's ABI Laboratory
5#
6# Written by Andrey Ponomarenko
7#
8# This library is free software; you can redistribute it and/or
9# modify it under the terms of the GNU Lesser General Public
10# License as published by the Free Software Foundation; either
11# version 2.1 of the License, or (at your option) any later version.
12#
13# This library is distributed in the hope that it will be useful,
14# but WITHOUT ANY WARRANTY; without even the implied warranty of
15# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
16# Lesser General Public License for more details.
17#
18# You should have received a copy of the GNU Lesser General Public
19# License along with this library; if not, write to the Free Software
20# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
21# MA  02110-1301 USA
22###########################################################################
23use strict;
24
25my %Cache;
26
27my %IntrinsicKeywords = map {$_=>1} (
28    "true",
29    "false",
30    "_Bool",
31    "_Complex",
32    "const",
33    "int",
34    "long",
35    "void",
36    "short",
37    "float",
38    "volatile",
39    "restrict",
40    "unsigned",
41    "signed",
42    "char",
43    "double",
44    "class",
45    "struct",
46    "union",
47    "enum"
48);
49
50sub initABI($)
51{
52    my $V = $_[0];
53    foreach my $K ("SymbolInfo", "TypeInfo", "TName_Tid", "Constants")
54    {
55        if(not defined $In::ABI{$V}{$K}) {
56            $In::ABI{$V}{$K} = {};
57        }
58    }
59}
60
61sub cmdFind(@)
62{ # native "find" is much faster than File::Find (~6x)
63  # also the File::Find doesn't support --maxdepth N option
64  # so using the cross-platform wrapper for the native one
65    my ($Path, $Type, $Name, $MaxDepth, $UseRegex) = ();
66
67    $Path = shift(@_);
68    if(@_) {
69        $Type = shift(@_);
70    }
71    if(@_) {
72        $Name = shift(@_);
73    }
74    if(@_) {
75        $MaxDepth = shift(@_);
76    }
77    if(@_) {
78        $UseRegex = shift(@_);
79    }
80
81    my $TmpDir = $In::Opt{"Tmp"};
82
83    if($In::Opt{"OS"} eq "windows")
84    {
85        $Path = getAbsPath($Path);
86        my $Cmd = "cmd /C dir \"$Path\" /B /O";
87        if($MaxDepth!=1) {
88            $Cmd .= " /S";
89        }
90        if($Type eq "d") {
91            $Cmd .= " /AD";
92        }
93        elsif($Type eq "f") {
94            $Cmd .= " /A-D";
95        }
96        my @Files = split(/\n/, qx/$Cmd/);
97        if($Name)
98        {
99            if(not $UseRegex)
100            { # FIXME: how to search file names in MS shell?
101              # wildcard to regexp
102                $Name=~s/\*/.*/g;
103                $Name='\A'.$Name.'\Z';
104            }
105            @Files = grep { /$Name/i } @Files;
106        }
107        my @AbsPaths = ();
108        foreach my $File (@Files)
109        {
110            if(not isAbsPath($File)) {
111                $File = join_P($Path, $File);
112            }
113            if($Type eq "f" and not -f $File)
114            { # skip dirs
115                next;
116            }
117            push(@AbsPaths, pathFmt($File));
118        }
119        if($Type eq "d") {
120            push(@AbsPaths, $Path);
121        }
122        return @AbsPaths;
123    }
124    else
125    {
126        my $FindCmd = "find";
127        if(not checkCmd($FindCmd)) {
128            exitStatus("Not_Found", "can't find a \"find\" command");
129        }
130        $Path = getAbsPath($Path);
131        if(-d $Path and -l $Path
132        and $Path!~/\/\Z/)
133        { # for directories that are symlinks
134            $Path.="/";
135        }
136        my $Cmd = $FindCmd." \"$Path\"";
137        if($MaxDepth) {
138            $Cmd .= " -maxdepth $MaxDepth";
139        }
140        if($Type) {
141            $Cmd .= " -type $Type";
142        }
143        if($Name and not $UseRegex)
144        { # wildcards
145            $Cmd .= " -name \"$Name\"";
146        }
147        my $Res = `$Cmd 2>\"$TmpDir/null\"`;
148        if($? and $!) {
149            printMsg("ERROR", "problem with \'find\' utility ($?): $!");
150        }
151        my @Files = split(/\n/, $Res);
152        if($Name and $UseRegex)
153        { # regex
154            @Files = grep { /$Name/ } @Files;
155        }
156        return @Files;
157    }
158}
159
160sub findLibs($$$)
161{ # FIXME: correct the search pattern
162    my ($Path, $Type, $MaxDepth) = @_;
163    return cmdFind($Path, $Type, '\.'.$In::Opt{"Ext"}.'[0-9.]*\Z', $MaxDepth, 1);
164}
165
166sub getPrefixes($)
167{
168    my %Prefixes = ();
169    getPrefixes_I([$_[0]], \%Prefixes);
170    return keys(%Prefixes);
171}
172
173sub getPrefixes_I($$)
174{
175    my $S = "/";
176    if($In::Opt{"OS"} eq "windows") {
177        $S = "\\";
178    }
179
180    foreach my $P (@{$_[0]})
181    {
182        my @Parts = reverse(split(/[\/\\]+/, $P));
183        my $Name = $Parts[0];
184        foreach (1 .. $#Parts)
185        {
186            $_[1]->{$Name}{$P} = 1;
187            if($_>4 or $Parts[$_] eq "include") {
188                last;
189            }
190            $Name = $Parts[$_].$S.$Name;
191        }
192    }
193}
194
195sub getCompileCmd($$$$)
196{
197    my ($Path, $Opt, $Inc, $LVer) = @_;
198    my $GccCall = $In::Opt{"GccPath"};
199    if($Opt) {
200        $GccCall .= " ".$Opt;
201    }
202    $GccCall .= " -x ";
203    if($In::Opt{"OS"} eq "macos") {
204        $GccCall .= "objective-";
205    }
206
207    if($In::Opt{"GccMissedMangling"})
208    { # workaround for GCC 4.8 (C only)
209        $GccCall .= "c++";
210    }
211    elsif(checkGcc("4"))
212    { # compile as "C++" header
213      # to obtain complete dump using GCC 4.0
214        $GccCall .= "c++-header";
215    }
216    else
217    { # compile as "C++" source
218      # GCC 3.3 cannot compile headers
219        $GccCall .= "c++";
220    }
221    if(my $Opts = platformSpecs($LVer))
222    { # platform-specific options
223        $GccCall .= " ".$Opts;
224    }
225    # allow extra qualifications
226    # and other nonconformant code
227    $GccCall .= " -fpermissive";
228    $GccCall .= " -w";
229    if($In::Opt{"NoStdInc"})
230    {
231        $GccCall .= " -nostdinc";
232        $GccCall .= " -nostdinc++";
233    }
234    if(my $Opts = getGccOptions($LVer))
235    { # user-defined options
236        $GccCall .= " ".$Opts;
237    }
238    $GccCall .= " \"$Path\"";
239    if($Inc)
240    { # include paths
241        $GccCall .= " ".$Inc;
242    }
243    return $GccCall;
244}
245
246sub platformSpecs($)
247{
248    my $LVer = $_[0];
249
250    if($In::Opt{"Target"} eq "symbian")
251    { # options for GCCE compiler
252        my @Symbian_Opts = (
253            "-D__GCCE__",
254            "-DUNICODE",
255            "-fexceptions",
256            "-D__SYMBIAN32__",
257            "-D__MARM_INTERWORK__",
258            "-D_UNICODE",
259            "-D__S60_50__",
260            "-D__S60_3X__",
261            "-D__SERIES60_3X__",
262            "-D__EPOC32__",
263            "-D__MARM__",
264            "-D__EABI__",
265            "-D__MARM_ARMV5__",
266            "-D__SUPPORT_CPP_EXCEPTIONS__",
267            "-march=armv5t",
268            "-mapcs",
269            "-mthumb-interwork",
270            "-DEKA2",
271            "-DSYMBIAN_ENABLE_SPLIT_HEADERS"
272        );
273        return join(" ", @Symbian_Opts);
274    }
275    elsif($In::Opt{"OS"} eq "windows"
276    and $In::Opt{"GccTarget"}=~/mingw/i)
277    { # add options to MinGW compiler
278      # to simulate the MSVC compiler
279        my @MinGW_Opts = (
280            "-D__unaligned=\" \"",
281            "-D__nullptr=\"nullptr\"",
282            "-D_WIN32",
283            "-D_STDCALL_SUPPORTED",
284            "-D__int64=\"long long\"",
285            "-D__int32=int",
286            "-D__int16=short",
287            "-D__int8=char",
288            "-D__possibly_notnullterminated=\" \"",
289            "-D__nullterminated=\" \"",
290            "-D__nullnullterminated=\" \"",
291            "-D__assume=\" \"",
292            "-D__w64=\" \"",
293            "-D__ptr32=\" \"",
294            "-D__ptr64=\" \"",
295            "-D__forceinline=inline",
296            "-D__inline=inline",
297            "-D__uuidof(x)=IID()",
298            "-D__try=",
299            "-D__except(x)=",
300            "-D__declspec(x)=__attribute__((x))",
301            "-D__pragma(x)=",
302            "-D_inline=inline",
303            "-D__forceinline=__inline",
304            "-D__stdcall=__attribute__((__stdcall__))",
305            "-D__cdecl=__attribute__((__cdecl__))",
306            "-D__fastcall=__attribute__((__fastcall__))",
307            "-D__thiscall=__attribute__((__thiscall__))",
308            "-D_stdcall=__attribute__((__stdcall__))",
309            "-D_cdecl=__attribute__((__cdecl__))",
310            "-D_fastcall=__attribute__((__fastcall__))",
311            "-D_thiscall=__attribute__((__thiscall__))",
312            "-DSHSTDAPI_(x)=x",
313            "-D_MSC_EXTENSIONS",
314            "-DSECURITY_WIN32",
315            "-D_MSC_VER=1500",
316            "-D_USE_DECLSPECS_FOR_SAL",
317            "-D__noop=\" \"",
318            "-DDECLSPEC_DEPRECATED=\" \"",
319            "-D__builtin_alignof(x)=__alignof__(x)",
320            "-DSORTPP_PASS");
321
322        if($In::ABI{$LVer}{"Arch"} eq "x86")
323        {
324            push(@MinGW_Opts, "-D_X86_=300");
325            push(@MinGW_Opts, "-D_M_IX86=300");
326        }
327        elsif($In::ABI{$LVer}{"Arch"} eq "x86_64")
328        {
329            push(@MinGW_Opts, "-D_AMD64_=300");
330            push(@MinGW_Opts, "-D_M_AMD64=300");
331            push(@MinGW_Opts, "-D_M_X64=300");
332        }
333        elsif($In::ABI{$LVer}{"Arch"} eq "ia64")
334        {
335            push(@MinGW_Opts, "-D_IA64_=300");
336            push(@MinGW_Opts, "-D_M_IA64=300");
337        }
338
339        return join(" ", @MinGW_Opts);
340    }
341    return undef;
342}
343
344sub uncoverTypedefs($$)
345{
346    my ($TypeName, $LVer) = @_;
347
348    if(defined $Cache{"uncoverTypedefs"}{$LVer}{$TypeName}) {
349        return $Cache{"uncoverTypedefs"}{$LVer}{$TypeName};
350    }
351    my ($TypeName_New, $TypeName_Pre) = (formatName($TypeName, "T"), "");
352    while($TypeName_New ne $TypeName_Pre)
353    {
354        $TypeName_Pre = $TypeName_New;
355        my $TypeName_Copy = $TypeName_New;
356        my %Words = ();
357        while($TypeName_Copy=~s/\b([a-z_]([\w:]*\w|))\b//io)
358        {
359            if(not $IntrinsicKeywords{$1}) {
360                $Words{$1} = 1;
361            }
362        }
363        foreach my $Word (keys(%Words))
364        {
365            my $BaseType_Name = $In::ABI{$LVer}{"TypedefBase"}{$Word};
366
367            next if(not $BaseType_Name);
368            next if($BaseType_Name=~/\b$Word\b/);
369            next if($TypeName_New=~/\b(struct|union|enum)\s\Q$Word\E\b/);
370
371            if($BaseType_Name=~/\([\*]+\)/)
372            { # FuncPtr
373                if($TypeName_New=~/\Q$Word\E(.*)\Z/)
374                {
375                    my $Type_Suffix = $1;
376                    $TypeName_New = $BaseType_Name;
377                    if($TypeName_New=~s/\(([\*]+)\)/($1 $Type_Suffix)/) {
378                        $TypeName_New = formatName($TypeName_New, "T");
379                    }
380                }
381            }
382            else
383            {
384                if($TypeName_New=~s/\b\Q$Word\E\b/$BaseType_Name/g) {
385                    $TypeName_New = formatName($TypeName_New, "T");
386                }
387            }
388        }
389    }
390    return ($Cache{"uncoverTypedefs"}{$LVer}{$TypeName} = $TypeName_New);
391}
392
393sub getGccOptions($)
394{
395    my $LVer = $_[0];
396
397    my @Opt = ();
398
399    if(my $COpt = $In::Desc{$LVer}{"CompilerOptions"})
400    { # user-defined options
401        push(@Opt, $COpt);
402    }
403    if($In::Opt{"GccOptions"})
404    { # additional
405        push(@Opt, $In::Opt{"GccOptions"});
406    }
407
408    if(@Opt) {
409        return join(" ", @Opt);
410    }
411
412    return undef;
413}
414
415sub setTarget($)
416{
417    my $Target = $_[0];
418
419    if($Target eq "default")
420    {
421        $Target = getOSgroup();
422
423        $In::Opt{"OS"} = $Target;
424        $In::Opt{"Ar"} = getArExt($Target);
425    }
426
427    $In::Opt{"Target"} = $Target;
428    $In::Opt{"Ext"} = getLibExt($Target, $In::Opt{"UseStaticLibs"});
429}
430
431sub filterFormat($)
432{
433    my $FiltRef = $_[0];
434    foreach my $Entry (keys(%{$FiltRef}))
435    {
436        foreach my $Filt (@{$FiltRef->{$Entry}})
437        {
438            if($Filt=~/[\/\\]/) {
439                $Filt = pathFmt($Filt);
440            }
441        }
442    }
443}
444
445sub checkGcc(@)
446{
447    my $Req = shift(@_);
448    my $Gcc = $In::Opt{"GccPath"};
449
450    if(@_) {
451        $Gcc = shift(@_);
452    }
453
454    if(defined $Cache{"checkGcc"}{$Gcc}{$Req}) {
455        return $Cache{"checkGcc"}{$Gcc}{$Req};
456    }
457    if(my $Ver = dumpVersion($Gcc))
458    {
459        $Ver=~s/(-|_)[a-z_]+.*\Z//; # remove suffix (like "-haiku-100818")
460        if(cmpVersions($Ver, $Req)>=0) {
461            return ($Cache{"checkGcc"}{$Gcc}{$Req} = $Gcc);
462        }
463    }
464    return ($Cache{"checkGcc"}{$Gcc}{$Req} = "");
465}
466
467sub dumpVersion($)
468{
469    my $Cmd = $_[0];
470
471    if($Cache{"dumpVersion"}{$Cmd}) {
472        return $Cache{"dumpVersion"}{$Cmd};
473    }
474    my $TmpDir = $In::Opt{"Tmp"};
475    my $V = `$Cmd -dumpversion 2>\"$TmpDir/null\"`;
476    chomp($V);
477    return ($Cache{"dumpVersion"}{$Cmd} = $V);
478}
479
480sub dumpMachine($)
481{
482    my $Cmd = $_[0];
483
484    if($Cache{"dumpMachine"}{$Cmd}) {
485        return $Cache{"dumpMachine"}{$Cmd};
486    }
487    my $TmpDir = $In::Opt{"Tmp"};
488    my $Machine = `$Cmd -dumpmachine 2>\"$TmpDir/null\"`;
489    chomp($Machine);
490    return ($Cache{"dumpMachine"}{$Cmd} = $Machine);
491}
492
493return 1;
494