util/mknum.pl

   1
   2 #! /usr/bin/env perl
   3 # Copyright 2018-2021 The OpenSSL Project Authors. All Rights Reserved.
   4 #
   5 # Licensed under the Apache License 2.0 (the "License").  You may not use
   6 # this file except in compliance with the License.  You can obtain a copy
   7 # in the file LICENSE in the source distribution or at
   8 # https://www.openssl.org/source/license.html
   9
  10 use strict;
  11 use warnings;
  12
  13 use Getopt::Long;
  14 use FindBin;
  15 use lib "$FindBin::Bin/perl";
  16
  17 use OpenSSL::Ordinals;
  18 use OpenSSL::ParseC;
  19
  20 my $ordinals_file = undef;      # the ordinals file to use
  21 my $symhacks_file = undef;      # a symbol hacking file (optional)
  22 my $version = undef;            # the version to use for added symbols
  23 my $checkexist = 0;             # (unsure yet)
  24 my $warnings = 1;
  25 my $renumber = 0;
  26 my $verbose = 0;
  27 my $debug = 0;
  28
  29 GetOptions('ordinals=s' => \$ordinals_file,
  30            'symhacks=s' => \$symhacks_file,
  31            'version=s'  => \$version,
  32            'exist'      => \$checkexist,
  33            'renumber'   => \$renumber,
  34            'warnings!'  => \$warnings,
  35            'verbose'    => \$verbose,
  36            'debug'      => \$debug)
  37     or die "Error in command line arguments\n";
  38
  39 die "Please supply ordinals file\n"
  40     unless $ordinals_file;
  41
  42 my $ordinals = OpenSSL::Ordinals->new(from => $ordinals_file,
  43                                       warnings => $warnings,
  44                                       verbose => $verbose,
  45                                       debug => $debug);
  46 $ordinals->set_version($version);
  47
  48 my %orig_names = ();
  49 %orig_names = map { $_->name() => 1 }
  50     $ordinals->items(comparator => sub { $_[0] cmp $_[1] },
  51                      filter => sub { $_->exists() })
  52     if $checkexist;
  53
  54 # Invalidate all entries, they get revalidated when we re-check below
  55 $ordinals->invalidate();
  56
  57 foreach my $f (($symhacks_file // (), @ARGV)) {
  58     print STDERR $f," ","-" x (69 - length($f)),"\n" if $verbose;
  59     open IN, $f or die "Couldn't open $f: $!\n";
  60     foreach (parse(<IN>, { filename => $f,
  61                            warnings => $warnings,
  62                            verbose => $verbose,
  63                            debug => $debug })) {
  64         $_->{value} = $_->{value}||"";
  65         next if grep { $_ eq 'CONST_STRICT' } @{$_->{conds}};
  66         printf STDERR "%s> %s%s : %s\n",
  67             $_->{type},
  68             $_->{name},
  69             ($_->{type} eq 'M' && defined $symhacks_file && $f eq $symhacks_file
  70              ? ' = ' . $_->{value}
  71              : ''),
  72             join(', ', @{$_->{conds}})
  73             if $verbose;
  74         if ($_->{type} eq 'M'
  75                 && defined $symhacks_file
  76                 && $f eq $symhacks_file
  77                 && $_->{value} =~ /^\w(?:\w|\d)*/) {
  78             $ordinals->add_alias($f, $_->{value}, $_->{name}, @{$_->{conds}});
  79         } else {
  80             next if $_->{returntype} =~ /\b(?:ossl_)inline/;
  81             my $type = {
  82                 F => 'FUNCTION',
  83                 V => 'VARIABLE',
  84             } -> {$_->{type}};
  85             if ($type) {
  86                 $ordinals->add($f, $_->{name}, $type, @{$_->{conds}});
  87             }
  88         }
  89     }
  90     close IN;
  91 }
  92
  93 $ordinals->renumber() if $renumber;
  94
  95 if ($checkexist) {
  96     my %new_names = map { $_->name() => 1 }
  97         $ordinals->items(comparator => sub { $_[0] cmp $_[1] },
  98                          filter => sub { $_->exists() });
  99     # Eliminate common names
 100     foreach (keys %orig_names) {
 101         next unless exists $new_names{$_};
 102         delete $orig_names{$_};
 103         delete $new_names{$_};
 104     }
 105     if (%orig_names) {
 106         print "The following symbols do not seem to exist in code:\n";
 107         foreach (sort keys %orig_names) {
 108             print "\t$_\n";
 109         }
 110     }
 111     if (%new_names) {
 112         print "The following existing symbols are not in ordinals file:\n";
 113         foreach (sort keys %new_names) {
 114             print "\t$_\n";
 115         }
 116     }
 117 } else {
 118     my $dropped = 0;
 119     my $unassigned;
 120     my $filter = sub {
 121         my $item = shift;
 122         my $result = $item->number() ne '?' || $item->exists();
 123         $dropped++ unless $result;
 124         return $result;
 125     };
 126     $ordinals->rewrite(filter => $filter);
 127     my %stats = $ordinals->stats();
 128     print STDERR
 129         "${ordinals_file}: $stats{modified} old symbols have updated info\n"
 130         if $stats{modified};
 131     if ($stats{new}) {
 132         print STDERR "${ordinals_file}: Added $stats{new} new symbols\n";
 133     } else {
 134         print STDERR "${ordinals_file}: No new symbols added\n";
 135     }
 136     if ($dropped) {
 137         print STDERR "${ordinals_file}: Dropped $dropped new symbols\n";
 138     }
 139     $stats{unassigned} = 0 unless defined $stats{unassigned};
 140     $unassigned = $stats{unassigned} - $dropped;
 141     if ($unassigned) {
 142         my $symbol = $unassigned == 1 ? "symbol" : "symbols";
 143         my $is = $unassigned == 1 ? "is" : "are";
 144         print STDERR "${ordinals_file}: $unassigned $symbol $is without ordinal number\n";
 145     }
 146 }