Add code to manipulate the items in OpenSSL::Ordinals (15ba1096) · Commits · CYBER - Cyber Security / TS 103 523 MSP / TLMSP / TLMSP OpenSSL

util/perl/OpenSSL/Ordinals.pm

+545 −35

Original line number	Diff line number	Diff line
		@@ -13,6 +13,12 @@ use warnings;
		use Carp;
		use Scalar::Util qw(blessed);

		use constant {
		# "magic" filters, see the filters at the end of the file
		F_NAME => 1,
		F_NUMBER => 2,
		};

		=head1 NAME

		OpenSSL::Ordinals - a private module to read and walk through ordinals
		@@ -76,7 +82,16 @@ sub new {
		my %opts = @_;

		my $instance = {
		contents => [], # The items themselves
		filename => undef, # File name registered when loading
		loaded_maxnum => 0, # Highest allocated item number when loading
		loaded_contents => [], # Loaded items, if loading there was
		maxnum => 0, # Current highest allocated item number
		contents => [], # Items, indexed by number
		name2num => {}, # Name to number dictionary
		aliases => {}, # Aliases cache.
		stats => {}, # Statistics, see 'sub validate'
		currversion => $opts{version} // '', # '' is for "we don't care"
		debug => $opts{debug},
		};
		bless $instance, $class;

		@@ -90,16 +105,21 @@ sub new {
		Loads the data from FILENAME into the instance. Any previously loaded data
		is dropped.

		Two internal databases are created. One database is simply a copy of the file
		contents and is treated as read-only. The other database is an exact copy of
		the first, but is treated as a work database, i.e. it can be modified and added
		to.

		=cut

		sub load {
		my $self = shift;
		my $filename = shift;

		croak "Bad instance" unless blessed($self);
		croak "Undefined filename" unless defined($filename);

		my @tmp_contents;
		my @tmp_contents = ();
		my %tmp_name2num = ();
		my $max_num = 0;
		open F, '<', $filename or croak "Unable to open $filename";
		while (<F>) {
		@@ -108,16 +128,69 @@ sub load {
		next if /^\s*$/;

		my $item = OpenSSL::Ordinals::Item->new(from => $_);
		my $num = $item->number();

		my $num = $item->number();
		croak "Disordered ordinals, $num < $max_num"
		if $num < $max_num;
		$max_num = $num;

		push @tmp_contents, $item;
		push @{$tmp_contents[$item->number()]}, $item;
		$tmp_name2num{$item->name()} = $item->number();
		}
		close F;

		$self->{contents} = [ @tmp_contents ];
		$self->{name2num} = { %tmp_name2num };
		$self->{maxnum} = $max_num;
		$self->{filename} = $filename;

		# Make a deep copy, allowing {contents} to be an independent work array
		foreach my $i (1..$max_num) {
		if ($tmp_contents[$i]) {
		$self->{loaded_contents}->[$i] =
		[ map { OpenSSL::Ordinals::Item->new($_) }
		@{$tmp_contents[$i]} ];
		}
		}
		$self->{loaded_maxnum} = $max_num;
		return 1;
		}

		=item B<$ordinals-E<gt>rewrite>

		If an ordinals file has been loaded, it gets rewritten with the data from
		the current work database.

		=cut

		sub rewrite {
		my $self = shift;

		$self->write($self->{filename});
		}

		=item B<$ordinals-E<gt>write FILENAME>

		Writes the current work database data to the ordinals file FILENAME.
		This also validates the data, see B<$ordinals-E<gt>validate> below.

		=cut

		sub write {
		my $self = shift;
		my $filename = shift;

		croak "Undefined filename" unless defined($filename);

		$self->validate();

		open F, '>', $filename or croak "Unable to open $filename";
		foreach ($self->items(by => by_number())) {
		print F $_->to_string(),"\n";
		}
		close F;
		$self->{filename} = $filename;
		$self->{loaded_maxnum} = $self->{maxnum};
		return 1;
		}

		@@ -151,12 +224,383 @@ sub items {
		my $comparator = $opts{sort};
		my $filter = $opts{filter} // sub { 1; };

		my @l = grep { $filter->($_) } @{$self->{contents}};
		my @l = undef;
		if (ref($filter) eq 'ARRAY') {
		# run a "magic" filter
		if ($filter->[0] == F_NUMBER) {
		my $index = $filter->[1];
		@l = $index ? @{$self->{contents}->[$index] // []} : ();
		} elsif ($filter->[0] == F_NAME) {
		my $index = $self->{name2num}->{$filter->[1]};
		@l = $index ? @{$self->{contents}->[$index] // []} : ();
		} else {
		croak __PACKAGE__."->items called with invalid filter";
		}
		} elsif (ref($filter) eq 'CODE') {
		@l = grep { $filter->($_) }
		map { @{$_ // []} }
		@{$self->{contents}};
		} else {
		croak __PACKAGE__."->items called with invalid filter";
		}

		return sort { $comparator->($a, $b); } @l
		if (defined $comparator);
		return @l;
		}

		# Put an array of items back into the object after having checked consistency
		# If there are exactly two items:
		# - They MUST have the same number
		# - For platforms, both MUST hold the same ones, but with opposite values
		# - For features, both MUST hold the same ones.
		# If there's just one item, just put it in the slot of its number
		# In all other cases, something is wrong
		sub _putback {
		my $self = shift;
		my @items = @_;

		if (scalar @items < 1 \|\| scalar @items > 2) {
		croak "Wrong number of items: ", scalar @items, " : ",
		join(", ", map { $_->name() } @items), "\n";
		}
		if (scalar @items == 2) {
		# Collect some data
		my %numbers = ();
		my %versions = ();
		my %features = ();
		foreach (@items) {
		$numbers{$_->number()} = 1;
		$versions{$_->version()} = 1;
		foreach ($_->features()) {
		$features{$_}++;
		}
		}

		# Check that all items we're trying to put back have the same number
		croak "Items don't have the same numeral: ",
		join(", ", map { $_->name()." => ".$_->number() } @items), "\n"
		if (scalar keys %numbers > 1);
		croak "Items don't have the same version: ",
		join(", ", map { $_->name()." => ".$_->version() } @items), "\n"
		if (scalar keys %versions > 1);

		# Check that both items run with the same features
		foreach (@items) {
		}
		foreach (keys %features) {
		delete $features{$_} if $features{$_} == 2;
		}
		croak "Features not in common between ",
		$items[0]->name(), " and ", $items[1]->name(), ":",
		join(", ", sort keys %features), "\n"
		if %features;

		# Check that all platforms exist in both items, and have opposite values
		my @platforms = ( { $items[0]->platforms() },
		{ $items[1]->platforms() } );
		foreach my $platform (keys %{$platforms[0]}) {
		if (exists $platforms[1]->{$platform}) {
		if ($platforms[0]->{$platform} != !$platforms[1]->{$platform}) {
		croak "Platforms aren't opposite: ",
		join(", ",
		map { my %tmp_h = $_->platforms();
		$_->name().":".$platform
		." => "
		.$tmp_h{$platform} } @items),
		"\n";
		}

		# We're done with these
		delete $platforms[0]->{$platform};
		delete $platforms[1]->{$platform};
		}
		}
		# If there are any remaining platforms, something's wrong
		if (%{$platforms[0]} \|\| %{$platforms[0]}) {
		croak "There are platforms not in common between ",
		$items[0]->name(), " and ", $items[1]->name(), "\n";
		}
		}
		$self->{contents}->[$items[0]->number()] = [ @items ];
		}

		sub _parse_platforms {
		my $self = shift;
		my @defs = @_;

		my %platforms = ();
		foreach (@defs) {
		m{^(!)?};
		my $op = !(defined $1 && $1 eq '!');
		my $def = $';

		if ($def =~ m{^_?WIN32$}) { $platforms{$&} = $op; }
		if ($def =~ m{^__FreeBSD__$}) { $platforms{$&} = $op; }
		# For future support
		# if ($def =~ m{^__DragonFly__$}) { $platforms{$&} = $op; }
		# if ($def =~ m{^__OpenBSD__$}) { $platforms{$&} = $op; }
		# if ($def =~ m{^__NetBSD__$}) { $platforms{$&} = $op; }
		if ($def =~
		m{^OPENSSL_(EXPORT_VAR_AS_FUNCTION)$}) { $platforms{$1} = $op; }
		if ($def =~ m{^OPENSSL_SYS_}) { $platforms{$'} = $op; }
		}

		return %platforms;
		}

		sub _parse_features {
		my $self = shift;
		my @defs = @_;

		my %features = ();
		foreach (@defs) {
		m{^(!)?};
		my $op = !(defined $1 && $1 eq '!');
		my $def = $';

		if ($def =~ m{^ZLIB$}) { $features{$&} = $op; }
		if ($def =~ m{^OPENSSL_USE_}) { $features{$'} = $op; }
		if ($def =~ m{^OPENSSL_NO_}) { $features{$'} = !$op; }
		if ($def =~ m{^DEPRECATEDIN_(.*)$}) { $features{$&} = !$op; }
		}

		return %features;
		}

		=item B<$ordinals-E<gt>add NAME, TYPE, LIST>

		Adds a new item named NAME with the type TYPE, and a set of C macros in
		LIST that are expected to be defined or undefined to use this symbol, if
		any. For undefined macros, they each must be prefixed with a C<!>.

		If this symbol already exists in loaded data, it will be rewritten using
		the new input data, but will keep the same ordinal number and version.
		If it's entirely new, it will get a new number and the current default
		version. The new ordinal number is a simple increment from the last
		maximum number.

		=cut

		sub add {
		my $self = shift;
		my $name = shift;
		my $type = shift; # FUNCTION or VARIABLE
		my @defs = @_; # Macros from #ifdef and #ifndef
		# (the latter prefixed with a '!')

		# call signature for debug output
		my $verbsig = "add('$name' , '$type' , [ " . join(', ', @defs) . " ])";

		croak __PACKAGE__."->add got a bad type '$type'"
		unless $type eq 'FUNCTION' \|\| $type eq 'VARIABLE';

		my %platforms = _parse_platforms(@defs);
		my %features = _parse_features(@defs);

		my @items = $self->items(filter => f_name($name));
		my $version = @items ? $items[0]->version() : $self->{currversion};
		my $number = @items ? $items[0]->number() : ++$self->{maxnum};
		print STDERR "DEBUG[",__PACKAGE__,":add] $verbsig\n",
		@items ? map { "\t".$_->to_string()."\n" } @items : "No previous items\n",
		if $self->{debug};
		@items = grep { $_->exists() } @items;

		my $new_item =
		OpenSSL::Ordinals::Item->new( name => $name,
		type => $type,
		number => $number,
		version => $version,
		exists => 1,
		platforms => { %platforms },
		features => [
		grep { $features{$_} } keys %features
		] );

		push @items, $new_item;
		print STDERR "DEBUG[",__PACKAGE__,"::add] $verbsig\n", map { "\t".$_->to_string()."\n" } @items
		if $self->{debug};
		$self->_putback(@items);

		# If an alias was defined beforehand, add an item for it now
		my $alias = $self->{aliases}->{$name};
		delete $self->{aliases}->{$name};

		# For the caller to show
		my @returns = ( $new_item );
		push @returns, $self->add_alias($alias->{name}, $name, @{$alias->{defs}})
		if defined $alias;
		return @returns;
		}

		=item B<$ordinals-E<gt>add_alias ALIAS, NAME, LIST>

		Adds an alias ALIAS for the symbol NAME, and a set of C macros in LIST
		that are expected to be defined or undefined to use this symbol, if any.
		For undefined macros, they each must be prefixed with a C<!>.

		If this symbol already exists in loaded data, it will be rewritten using
		the new input data. Otherwise, the data will just be store away, to wait
		that the symbol NAME shows up.

		=cut

		sub add_alias {
		my $self = shift;
		my $alias = shift; # This is the alias being added
		my $name = shift; # For this name (assuming it exists)
		my @defs = @_; # Platform attributes for the alias

		# call signature for debug output
		my $verbsig =
		"add_alias('$alias' , '$name' , [ " . join(', ', @defs) . " ])";

		croak "You're kidding me..." if $alias eq $name;

		my %platforms = _parse_platforms(@defs);
		my %features = _parse_features(@defs);

		croak "Alias with associated features is forbidden\n"
		if %features;

		my $f_byalias = f_name($alias);
		my $f_byname = f_name($name);
		my @items = $self->items(filter => $f_byalias);
		foreach my $item ($self->items(filter => $f_byname)) {
		push @items, $item unless grep { $_ == $item } @items;
		}
		@items = grep { $_->exists() } @items;

		croak "Alias already exists ($alias => $name)"
		if scalar @items > 1;
		if (scalar @items == 0) {
		# The item we want to alias for doesn't exist yet, so we cache the
		# alias and hope the item we're making an alias of shows up later
		$self->{aliases}->{$name} = { name => $alias, defs => [ @defs ] };

		print STDERR "DEBUG[",__PACKAGE__,":add_alias] $verbsig\n",
		"\tSet future alias $alias => $name\n"
		if $self->{debug};
		return ();
		} elsif (scalar @items == 1) {
		# The rule is that an alias is more or less a copy of the original
		# item, just with another name. Also, the platforms given here are
		# given to the original item as well, with opposite values.
		my %alias_platforms = $items[0]->platforms();
		foreach (keys %platforms) {
		$alias_platforms{$_} = !$platforms{$_};
		}
		# We supposedly do now know how to do this... ahem
		$items[0]->{platforms} = { %alias_platforms };

		my $alias_item = OpenSSL::Ordinals::Item->new(
		name => $alias,
		type => $items[0]->type(),
		number => $items[0]->number(),
		version => $items[0]->version(),
		exists => $items[0]->exists(),
		platforms => { %platforms },
		features => [ $items[0]->features() ]
		);
		push @items, $alias_item;

		print STDERR "DEBUG[",__PACKAGE__,":add_alias] $verbsig\n",
		map { "\t".$_->to_string()."\n" } @items
		if $self->{debug};
		$self->_putback(@items);

		# For the caller to show
		return ( $alias_item->to_string() );
		}
		croak "$name has an alias already (trying to add alias $alias)\n",
		"\t", join(", ", map { $_->name() } @items), "\n";
		}

		=item B<$ordinals-E<gt>set_version VERSION>

		Sets the default version for new symbol to VERSION.

		=cut

		sub set_version {
		my $self = shift;
		my $version = shift;

		$version //= '*';
		$version =~ s\|-.*\|\|g;
		$version =~ s\|\.\|_\|g;
		$self->{currversion} = $version;
		foreach ($self->items(filter => sub { $_[0] eq '*' })) {
		$_->{version} = $self->{currversion};
		}
		return 1;
		}

		=item B<$ordinals-E<gt>invalidate>

		Invalidates the whole working database. The practical effect is that all
		symbols are set to not exist, but are kept around in the database to retain
		ordinal numbers and versions.

		=cut

		sub invalidate {
		my $self = shift;

		foreach (@{$self->{contents}}) {
		foreach (@{$_ // []}) {
		$_->{exists} = 0;
		}
		}
		$self->{stats} = {};
		}

		=item B<$ordinals-E<gt>validate>

		Validates the current working database by collection statistics on how many
		symbols were added and how many were changed. These numbers can be retrieved
		with B<$ordinals-E<gt>stats>.

		=cut

		sub validate {
		my $self = shift;

		$self->{stats} = {};
		for my $i (1..$self->{maxnum}) {
		if ($i > $self->{loaded_maxnum}
		\|\| (!@{$self->{loaded_contents}->[$i] // []}
		&& @{$self->{contents}->[$i] // []})) {
		$self->{stats}->{new}++;
		}
		next if ($i > $self->{loaded_maxnum});

		my @loaded_strings =
		map { $_->to_string() } @{$self->{loaded_contents}->[$i] // []};
		my @current_strings =
		map { $_->to_string() } @{$self->{contents}->[$i] // []};

		foreach my $str (@current_strings) {
		@loaded_strings = grep { $str ne $_ } @loaded_strings;
		}
		if (@loaded_strings) {
		$self->{stats}->{modified}++;
		}
		}
		}

		=item B<$ordinals-E<gt>stats>

		Returns the statistics that B<validate> calculate.

		=cut

		sub stats {
		my $self = shift;

		return %{$self->{stats}};
		}

		=back

		=head2 Data elements
		@@ -184,8 +628,6 @@ Available options are:

		=item B<from =E<gt> STRING>

		MANDATORY OPTION!

		This will create a new item, filled with data coming from STRING.

		STRING must conform to the following EBNF description:
		@@ -207,25 +649,36 @@ STRING must conform to the following EBNF description:

		(C<letter> and C<digit> are assumed self evident)

		=item B<name =E<gt> STRING>, B<number =E<gt> NUMBER>, B<version =E<gt> STRING>,
		B<exists =E<gt> BOOLEAN>, B<type =E<gt> STRING>,
		B<platforms =E<gt> HASHref>, B<features =E<gt> LISTref>

		This will create a new item with data coming from the arguments.

		=back

		=cut

		sub new {
		my $class = shift;
		my %opts = @_;

		my $string = $opts{from};
		if (ref($_[0]) eq $class) {
		return $class->new( map { $_ => $_[0]->{$_} } keys %{$_[0]} );
		}

		my %opts = @_;

		croak "No ordinals string given" unless defined $string;
		croak "No argument given" unless %opts;

		my @a = split /\s+/, $string;
		my $instance = undef;
		if ($opts{from}) {
		my @a = split /\s+/, $opts{from};

		croak "Badly formatted ordinals string: $string"
		croak "Badly formatted ordinals string: $opts{from}"
		unless ( scalar @a == 4
		&& $a[0] =~ /^[A-Za-z_][A-Za-z_0-9]*$/
		&& $a[1] =~ /^\d+$/
		&& $a[2] =~ /^\d+_\d+_\d+(?:[a-z]{0,2})$/
		&& $a[2] =~ /^(?:\*\|\d+_\d+_\d+(?:[a-z]{0,2}))$/
		&& $a[3] =~ /^
		(?:NO)?EXIST:
		[^:]*:
		@@ -235,14 +688,30 @@ sub new {
		/x );

		my @b = split /:/, $a[3];
		my $instance = { name => $a[0],
		%opts = ( name => $a[0],
		number => $a[1],
		version => $a[2],
		exists => $b[0] eq 'EXIST',
		platforms => { map { m\|^(!)?\|; $' => !$1 }
		split /,/,$b[1] },
		type => $b[2],
		features => [ split /,/,$b[3] // '' ] };
		features => [ split /,/,$b[3] // '' ] );
		}

		if ($opts{name} && $opts{version} && defined $opts{exists} && $opts{type}
		&& ref($opts{platforms} // {}) eq 'HASH'
		&& ref($opts{features} // []) eq 'ARRAY') {
		$instance = { name => $opts{name},
		type => $opts{type},
		number => $opts{number},
		version => $opts{version},
		exists => !!$opts{exists},
		platforms => { %{$opts{platforms} // {}} },
		features => [ sort @{$opts{features} // []} ] };
		} else {
		croak __PACKAGE__."->new() called with bad arguments\n".
		join("", map { " $_\t=> ".$opts{$_}."\n" } sort keys %opts);
		}

		return bless $instance, $class;
		}
		@@ -374,6 +843,7 @@ OpenSSL::Ordinals::Item objects.
		sub by_version {
		sub _ossl_versionsplit {
		my $textversion = shift;
		return $textversion if $textversion eq '*';
		my ($major,$minor,$edit,$patch) =
		$textversion =~ /^(\d+)_(\d+)_(\d+)([a-z]{0,2})$/;
		return ($major,$minor,$edit,$patch);
		@@ -384,6 +854,7 @@ sub by_version {
		my @b_split = _ossl_versionsplit($_[1]->version());
		my $verdict = 0;
		while (@a_split) {
		# The last part is a letter sequence (or a '*')
		if (scalar @a_split == 1) {
		$verdict = $a_split[0] cmp $b_split[0];
		} else {
		@@ -425,6 +896,45 @@ sub f_version {
		return sub { $_[0]->version() eq $version };
		}

		=item B<f_number NUMBER>

		Returns a filter that only lets through symbols with the ordinal number
		matching B<NUMBER>.

		NOTE that this returns a "magic" value that can not be used as a function.
		It's only useful when passed directly as a filter to B<items>.

		=cut

		sub f_number {
		my $number = shift;

		croak "No number specified"
		unless $number && $number =~ /^\d+$/;

		return [ F_NUMBER, $number ];
		}


		=item B<f_name NAME>

		Returns a filter that only lets through symbols with the symbol name
		matching B<NAME>.

		NOTE that this returns a "magic" value that can not be used as a function.
		It's only useful when passed directly as a filter to B<items>.

		=cut

		sub f_name {
		my $name = shift;

		croak "No name specified"
		unless $name;

		return [ F_NAME, $name ];
		}

		=back

		=head1 AUTHORS