| 1 | #! /usr/bin/env perl
|
|---|
| 2 | # Copyright 2018-2023 The OpenSSL Project Authors. All Rights Reserved.
|
|---|
| 3 | #
|
|---|
| 4 | # Licensed under the Apache License 2.0 (the "License"). You may not use
|
|---|
| 5 | # this file except in compliance with the License. You can obtain a copy
|
|---|
| 6 | # in the file LICENSE in the source distribution or at
|
|---|
| 7 | # https://www.openssl.org/source/license.html
|
|---|
| 8 |
|
|---|
| 9 | package OpenSSL::Ordinals;
|
|---|
| 10 |
|
|---|
| 11 | use strict;
|
|---|
| 12 | use warnings;
|
|---|
| 13 | use Carp;
|
|---|
| 14 | use Scalar::Util qw(blessed);
|
|---|
| 15 | use OpenSSL::Util;
|
|---|
| 16 |
|
|---|
| 17 | use constant {
|
|---|
| 18 | # "magic" filters, see the filters at the end of the file
|
|---|
| 19 | F_NAME => 1,
|
|---|
| 20 | F_NUMBER => 2,
|
|---|
| 21 | };
|
|---|
| 22 |
|
|---|
| 23 | =head1 NAME
|
|---|
| 24 |
|
|---|
| 25 | OpenSSL::Ordinals - a private module to read and walk through ordinals
|
|---|
| 26 |
|
|---|
| 27 | =head1 SYNOPSIS
|
|---|
| 28 |
|
|---|
| 29 | use OpenSSL::Ordinals;
|
|---|
| 30 |
|
|---|
| 31 | my $ordinals = OpenSSL::Ordinals->new(from => "foo.num");
|
|---|
| 32 | # or alternatively
|
|---|
| 33 | my $ordinals = OpenSSL::Ordinals->new();
|
|---|
| 34 | $ordinals->load("foo.num");
|
|---|
| 35 |
|
|---|
| 36 | foreach ($ordinals->items(comparator => by_name()) {
|
|---|
| 37 | print $_->name(), "\n";
|
|---|
| 38 | }
|
|---|
| 39 |
|
|---|
| 40 | =head1 DESCRIPTION
|
|---|
| 41 |
|
|---|
| 42 | This is a OpenSSL private module to load an ordinals (F<.num>) file and
|
|---|
| 43 | write out the data you want, sorted and filtered according to your rules.
|
|---|
| 44 |
|
|---|
| 45 | An ordinals file is a file that enumerates all the symbols that a shared
|
|---|
| 46 | library or loadable module must export. Each of them have a unique
|
|---|
| 47 | assigned number as well as other attributes to indicate if they only exist
|
|---|
| 48 | on a subset of the supported platforms, or if they are specific to certain
|
|---|
| 49 | features.
|
|---|
| 50 |
|
|---|
| 51 | The unique numbers each symbol gets assigned needs to be maintained for a
|
|---|
| 52 | shared library or module to stay compatible with previous versions on
|
|---|
| 53 | platforms that maintain a transfer vector indexed by position rather than
|
|---|
| 54 | by name. They also help keep information on certain symbols that are
|
|---|
| 55 | aliases for others for certain platforms, or that have different forms
|
|---|
| 56 | on different platforms.
|
|---|
| 57 |
|
|---|
| 58 | =head2 Main methods
|
|---|
| 59 |
|
|---|
| 60 | =over 4
|
|---|
| 61 |
|
|---|
| 62 | =cut
|
|---|
| 63 |
|
|---|
| 64 | =item B<new> I<%options>
|
|---|
| 65 |
|
|---|
| 66 | Creates a new instance of the C<OpenSSL::Ordinals> class. It takes options
|
|---|
| 67 | in keyed pair form, i.e. a series of C<< key => value >> pairs. Available
|
|---|
| 68 | options are:
|
|---|
| 69 |
|
|---|
| 70 | =over 4
|
|---|
| 71 |
|
|---|
| 72 | =item B<< from => FILENAME >>
|
|---|
| 73 |
|
|---|
| 74 | Not only create a new instance, but immediately load it with data from the
|
|---|
| 75 | ordinals file FILENAME.
|
|---|
| 76 |
|
|---|
| 77 | =back
|
|---|
| 78 |
|
|---|
| 79 | =cut
|
|---|
| 80 |
|
|---|
| 81 | sub new {
|
|---|
| 82 | my $class = shift;
|
|---|
| 83 | my %opts = @_;
|
|---|
| 84 |
|
|---|
| 85 | my $instance = {
|
|---|
| 86 | filename => undef, # File name registered when loading
|
|---|
| 87 | loaded_maxnum => 0, # Highest allocated item number when loading
|
|---|
| 88 | loaded_contents => [], # Loaded items, if loading there was
|
|---|
| 89 | maxassigned => 0, # Current highest assigned item number
|
|---|
| 90 | maxnum => 0, # Current highest allocated item number
|
|---|
| 91 | contents => [], # Items, indexed by number
|
|---|
| 92 | name2num => {}, # Name to number dictionary
|
|---|
| 93 | aliases => {}, # Aliases cache.
|
|---|
| 94 | stats => {}, # Statistics, see 'sub validate'
|
|---|
| 95 | debug => $opts{debug},
|
|---|
| 96 | };
|
|---|
| 97 | bless $instance, $class;
|
|---|
| 98 |
|
|---|
| 99 | $instance->set_version($opts{version});
|
|---|
| 100 | $instance->load($opts{from}) if defined($opts{from});
|
|---|
| 101 |
|
|---|
| 102 | return $instance;
|
|---|
| 103 | }
|
|---|
| 104 |
|
|---|
| 105 | =item B<< $ordinals->load FILENAME >>
|
|---|
| 106 |
|
|---|
| 107 | Loads the data from FILENAME into the instance. Any previously loaded data
|
|---|
| 108 | is dropped.
|
|---|
| 109 |
|
|---|
| 110 | Two internal databases are created. One database is simply a copy of the file
|
|---|
| 111 | contents and is treated as read-only. The other database is an exact copy of
|
|---|
| 112 | the first, but is treated as a work database, i.e. it can be modified and added
|
|---|
| 113 | to.
|
|---|
| 114 |
|
|---|
| 115 | =cut
|
|---|
| 116 |
|
|---|
| 117 | sub load {
|
|---|
| 118 | my $self = shift;
|
|---|
| 119 | my $filename = shift;
|
|---|
| 120 |
|
|---|
| 121 | croak "Undefined filename" unless defined($filename);
|
|---|
| 122 |
|
|---|
| 123 | my @tmp_contents = ();
|
|---|
| 124 | my %tmp_name2num = ();
|
|---|
| 125 | my $max_assigned = 0;
|
|---|
| 126 | my $max_num = 0;
|
|---|
| 127 | open F, '<', $filename or croak "Unable to open $filename";
|
|---|
| 128 | while (<F>) {
|
|---|
| 129 | s|\R$||; # Better chomp
|
|---|
| 130 | s|#.*||;
|
|---|
| 131 | next if /^\s*$/;
|
|---|
| 132 |
|
|---|
| 133 | my $item = OpenSSL::Ordinals::Item->new(source => $filename, from => $_);
|
|---|
| 134 |
|
|---|
| 135 | my $num = $item->number();
|
|---|
| 136 | if ($num eq '?') {
|
|---|
| 137 | $num = ++$max_num;
|
|---|
| 138 | } elsif ($num eq '?+') {
|
|---|
| 139 | $num = $max_num;
|
|---|
| 140 | } else {
|
|---|
| 141 | croak "Disordered ordinals, number sequence restarted"
|
|---|
| 142 | if $max_num > $max_assigned && $num < $max_num;
|
|---|
| 143 | croak "Disordered ordinals, $num < $max_num"
|
|---|
| 144 | if $num < $max_num;
|
|---|
| 145 | $max_assigned = $max_num = $num;
|
|---|
| 146 | }
|
|---|
| 147 |
|
|---|
| 148 | $item->intnum($num);
|
|---|
| 149 | push @{$tmp_contents[$num]}, $item;
|
|---|
| 150 | $tmp_name2num{$item->name()} = $num;
|
|---|
| 151 | }
|
|---|
| 152 | close F;
|
|---|
| 153 |
|
|---|
| 154 | $self->{contents} = [ @tmp_contents ];
|
|---|
| 155 | $self->{name2num} = { %tmp_name2num };
|
|---|
| 156 | $self->{maxassigned} = $max_assigned;
|
|---|
| 157 | $self->{maxnum} = $max_num;
|
|---|
| 158 | $self->{filename} = $filename;
|
|---|
| 159 |
|
|---|
| 160 | # Make a deep copy, allowing {contents} to be an independent work array
|
|---|
| 161 | foreach my $i (1..$max_num) {
|
|---|
| 162 | if ($tmp_contents[$i]) {
|
|---|
| 163 | $self->{loaded_contents}->[$i] =
|
|---|
| 164 | [ map { OpenSSL::Ordinals::Item->new($_) }
|
|---|
| 165 | @{$tmp_contents[$i]} ];
|
|---|
| 166 | }
|
|---|
| 167 | }
|
|---|
| 168 | $self->{loaded_maxnum} = $max_num;
|
|---|
| 169 | return 1;
|
|---|
| 170 | }
|
|---|
| 171 |
|
|---|
| 172 | =item B<< $ordinals->renumber >>
|
|---|
| 173 |
|
|---|
| 174 | Renumber any item that doesn't have an assigned number yet.
|
|---|
| 175 |
|
|---|
| 176 | =cut
|
|---|
| 177 |
|
|---|
| 178 | sub renumber {
|
|---|
| 179 | my $self = shift;
|
|---|
| 180 |
|
|---|
| 181 | my $max_assigned = 0;
|
|---|
| 182 | foreach ($self->items(sort => by_number())) {
|
|---|
| 183 | $_->number($_->intnum()) if $_->number() =~ m|^\?|;
|
|---|
| 184 | if ($max_assigned < $_->number()) {
|
|---|
| 185 | $max_assigned = $_->number();
|
|---|
| 186 | }
|
|---|
| 187 | }
|
|---|
| 188 | $self->{maxassigned} = $max_assigned;
|
|---|
| 189 | }
|
|---|
| 190 |
|
|---|
| 191 | =item B<< $ordinals->rewrite >>
|
|---|
| 192 |
|
|---|
| 193 | =item B<< $ordinals->rewrite >>, I<%options>
|
|---|
| 194 |
|
|---|
| 195 | If an ordinals file has been loaded, it gets rewritten with the data from
|
|---|
| 196 | the current work database.
|
|---|
| 197 |
|
|---|
| 198 | If there are more arguments, they are used as I<%options> with the
|
|---|
| 199 | same semantics as for B<< $ordinals->items >> described below, apart
|
|---|
| 200 | from B<sort>, which is forbidden here.
|
|---|
| 201 |
|
|---|
| 202 | =cut
|
|---|
| 203 |
|
|---|
| 204 | sub rewrite {
|
|---|
| 205 | my $self = shift;
|
|---|
| 206 | my %opts = @_;
|
|---|
| 207 |
|
|---|
| 208 | $self->write($self->{filename}, %opts);
|
|---|
| 209 | }
|
|---|
| 210 |
|
|---|
| 211 | =item B<< $ordinals->write FILENAME >>
|
|---|
| 212 |
|
|---|
| 213 | =item B<< $ordinals->write FILENAME >>, I<%options>
|
|---|
| 214 |
|
|---|
| 215 | Writes the current work database data to the ordinals file FILENAME.
|
|---|
| 216 | This also validates the data, see B<< $ordinals->validate >> below.
|
|---|
| 217 |
|
|---|
| 218 | If there are more arguments, they are used as I<%options> with the
|
|---|
| 219 | same semantics as for B<< $ordinals->items >> described next, apart
|
|---|
| 220 | from B<sort>, which is forbidden here.
|
|---|
| 221 |
|
|---|
| 222 | =cut
|
|---|
| 223 |
|
|---|
| 224 | sub write {
|
|---|
| 225 | my $self = shift;
|
|---|
| 226 | my $filename = shift;
|
|---|
| 227 | my %opts = @_;
|
|---|
| 228 |
|
|---|
| 229 | croak "Undefined filename" unless defined($filename);
|
|---|
| 230 | croak "The 'sort' option is not allowed" if $opts{sort};
|
|---|
| 231 |
|
|---|
| 232 | $self->validate();
|
|---|
| 233 |
|
|---|
| 234 | open F, '>', $filename or croak "Unable to open $filename";
|
|---|
| 235 | foreach ($self->items(%opts, sort => by_number())) {
|
|---|
| 236 | print F $_->to_string(),"\n";
|
|---|
| 237 | }
|
|---|
| 238 | close F;
|
|---|
| 239 | $self->{filename} = $filename;
|
|---|
| 240 | $self->{loaded_maxnum} = $self->{maxnum};
|
|---|
| 241 | return 1;
|
|---|
| 242 | }
|
|---|
| 243 |
|
|---|
| 244 | =item B<< $ordinals->items >> I<%options>
|
|---|
| 245 |
|
|---|
| 246 | Returns a list of items according to a set of criteria. The criteria is
|
|---|
| 247 | given in form keyed pair form, i.e. a series of C<< key => value >> pairs.
|
|---|
| 248 | Available options are:
|
|---|
| 249 |
|
|---|
| 250 | =over 4
|
|---|
| 251 |
|
|---|
| 252 | =item B<< sort => SORTFUNCTION >>
|
|---|
| 253 |
|
|---|
| 254 | SORTFUNCTION is a reference to a function that takes two arguments, which
|
|---|
| 255 | correspond to the classic C<$a> and C<$b> that are available in a C<sort>
|
|---|
| 256 | block.
|
|---|
| 257 |
|
|---|
| 258 | =item B<< filter => FILTERFUNCTION >>
|
|---|
| 259 |
|
|---|
| 260 | FILTERFUNCTION is a reference to a function that takes one argument, which
|
|---|
| 261 | is every OpenSSL::Ordinals::Item element available.
|
|---|
| 262 |
|
|---|
| 263 | =back
|
|---|
| 264 |
|
|---|
| 265 | =cut
|
|---|
| 266 |
|
|---|
| 267 | sub items {
|
|---|
| 268 | my $self = shift;
|
|---|
| 269 | my %opts = @_;
|
|---|
| 270 |
|
|---|
| 271 | my $comparator = $opts{sort};
|
|---|
| 272 | my $filter = $opts{filter} // sub { 1; };
|
|---|
| 273 |
|
|---|
| 274 | my @l = undef;
|
|---|
| 275 | if (ref($filter) eq 'ARRAY') {
|
|---|
| 276 | # run a "magic" filter
|
|---|
| 277 | if ($filter->[0] == F_NUMBER) {
|
|---|
| 278 | my $index = $filter->[1];
|
|---|
| 279 | @l = $index ? @{$self->{contents}->[$index] // []} : ();
|
|---|
| 280 | } elsif ($filter->[0] == F_NAME) {
|
|---|
| 281 | my $index = $self->{name2num}->{$filter->[1]};
|
|---|
| 282 | @l = $index ? @{$self->{contents}->[$index] // []} : ();
|
|---|
| 283 | } else {
|
|---|
| 284 | croak __PACKAGE__."->items called with invalid filter";
|
|---|
| 285 | }
|
|---|
| 286 | } elsif (ref($filter) eq 'CODE') {
|
|---|
| 287 | @l = grep { $filter->($_) }
|
|---|
| 288 | map { @{$_ // []} }
|
|---|
| 289 | @{$self->{contents}};
|
|---|
| 290 | } else {
|
|---|
| 291 | croak __PACKAGE__."->items called with invalid filter";
|
|---|
| 292 | }
|
|---|
| 293 |
|
|---|
| 294 | return sort { $comparator->($a, $b); } @l
|
|---|
| 295 | if (defined $comparator);
|
|---|
| 296 | return @l;
|
|---|
| 297 | }
|
|---|
| 298 |
|
|---|
| 299 | # Put an array of items back into the object after having checked consistency
|
|---|
| 300 | # If there are exactly two items:
|
|---|
| 301 | # - They MUST have the same number
|
|---|
| 302 | # - They MUST have the same version
|
|---|
| 303 | # - For platforms, both MUST hold the same ones, but with opposite values
|
|---|
| 304 | # - For features, both MUST hold the same ones.
|
|---|
| 305 | # - They MUST NOT have identical name, type, numeral, version, platforms, and features
|
|---|
| 306 | # If there's just one item, just put it in the slot of its number
|
|---|
| 307 | # In all other cases, something is wrong
|
|---|
| 308 | sub _putback {
|
|---|
| 309 | my $self = shift;
|
|---|
| 310 | my @items = @_;
|
|---|
| 311 |
|
|---|
| 312 | if (scalar @items < 1 || scalar @items > 2) {
|
|---|
| 313 | croak "Wrong number of items: ", scalar @items, "\n ",
|
|---|
| 314 | join("\n ", map { $_->{source}.": ".$_->name() } @items), "\n";
|
|---|
| 315 | }
|
|---|
| 316 | if (scalar @items == 2) {
|
|---|
| 317 | # Collect some data
|
|---|
| 318 | my %numbers = ();
|
|---|
| 319 | my %versions = ();
|
|---|
| 320 | my %features = ();
|
|---|
| 321 | foreach (@items) {
|
|---|
| 322 | $numbers{$_->intnum()} = 1;
|
|---|
| 323 | $versions{$_->version()} = 1;
|
|---|
| 324 | foreach ($_->features()) {
|
|---|
| 325 | $features{$_}++;
|
|---|
| 326 | }
|
|---|
| 327 | }
|
|---|
| 328 |
|
|---|
| 329 | # Check that all items we're trying to put back have the same number
|
|---|
| 330 | croak "Items don't have the same numeral: ",
|
|---|
| 331 | join(", ", map { $_->name()." => ".$_->intnum() } @items), "\n"
|
|---|
| 332 | if (scalar keys %numbers > 1);
|
|---|
| 333 | croak "Items don't have the same version: ",
|
|---|
| 334 | join(", ", map { $_->name()." => ".$_->version() } @items), "\n"
|
|---|
| 335 | if (scalar keys %versions > 1);
|
|---|
| 336 |
|
|---|
| 337 | # Check that both items run with the same features
|
|---|
| 338 | foreach (@items) {
|
|---|
| 339 | }
|
|---|
| 340 | foreach (keys %features) {
|
|---|
| 341 | delete $features{$_} if $features{$_} == 2;
|
|---|
| 342 | }
|
|---|
| 343 | croak "Features not in common between ",
|
|---|
| 344 | $items[0]->name(), " and ", $items[1]->name(), ":",
|
|---|
| 345 | join(", ", sort keys %features), "\n"
|
|---|
| 346 | if %features;
|
|---|
| 347 |
|
|---|
| 348 | # Check for in addition identical name, type, and platforms
|
|---|
| 349 | croak "Duplicate entries for ".$items[0]->name()." from ".
|
|---|
| 350 | $items[0]->source()." and ".$items[1]->source()."\n"
|
|---|
| 351 | if $items[0]->name() eq $items[1]->name()
|
|---|
| 352 | && $items[0]->type() eq $items[1]->type()
|
|---|
| 353 | && $items[0]->platforms() eq $items[1]->platforms();
|
|---|
| 354 |
|
|---|
| 355 | # Check that all platforms exist in both items, and have opposite values
|
|---|
| 356 | my @platforms = ( { $items[0]->platforms() },
|
|---|
| 357 | { $items[1]->platforms() } );
|
|---|
| 358 | foreach my $platform (keys %{$platforms[0]}) {
|
|---|
| 359 | if (exists $platforms[1]->{$platform}) {
|
|---|
| 360 | if ($platforms[0]->{$platform} != !$platforms[1]->{$platform}) {
|
|---|
| 361 | croak "Platforms aren't opposite: ",
|
|---|
| 362 | join(", ",
|
|---|
| 363 | map { my %tmp_h = $_->platforms();
|
|---|
| 364 | $_->name().":".$platform
|
|---|
| 365 | ." => "
|
|---|
| 366 | .$tmp_h{$platform} } @items),
|
|---|
| 367 | "\n";
|
|---|
| 368 | }
|
|---|
| 369 |
|
|---|
| 370 | # We're done with these
|
|---|
| 371 | delete $platforms[0]->{$platform};
|
|---|
| 372 | delete $platforms[1]->{$platform};
|
|---|
| 373 | }
|
|---|
| 374 | }
|
|---|
| 375 | # If there are any remaining platforms, something's wrong
|
|---|
| 376 | if (%{$platforms[0]} || %{$platforms[0]}) {
|
|---|
| 377 | croak "There are platforms not in common between ",
|
|---|
| 378 | $items[0]->name(), " and ", $items[1]->name(), "\n";
|
|---|
| 379 | }
|
|---|
| 380 | }
|
|---|
| 381 | $self->{contents}->[$items[0]->intnum()] = [ @items ];
|
|---|
| 382 | }
|
|---|
| 383 |
|
|---|
| 384 | sub _parse_platforms {
|
|---|
| 385 | my $self = shift;
|
|---|
| 386 | my @defs = @_;
|
|---|
| 387 |
|
|---|
| 388 | my %platforms = ();
|
|---|
| 389 | foreach (@defs) {
|
|---|
| 390 | m{^(!)?};
|
|---|
| 391 | my $op = !(defined $1 && $1 eq '!');
|
|---|
| 392 | my $def = $';
|
|---|
| 393 |
|
|---|
| 394 | if ($def =~ m{^_?WIN32$}) { $platforms{$&} = $op; }
|
|---|
| 395 | if ($def =~ m{^__FreeBSD__$}) { $platforms{$&} = $op; }
|
|---|
| 396 | # For future support
|
|---|
| 397 | # if ($def =~ m{^__DragonFly__$}) { $platforms{$&} = $op; }
|
|---|
| 398 | # if ($def =~ m{^__OpenBSD__$}) { $platforms{$&} = $op; }
|
|---|
| 399 | # if ($def =~ m{^__NetBSD__$}) { $platforms{$&} = $op; }
|
|---|
| 400 | if ($def =~ m{^OPENSSL_SYS_}) { $platforms{$'} = $op; }
|
|---|
| 401 | }
|
|---|
| 402 |
|
|---|
| 403 | return %platforms;
|
|---|
| 404 | }
|
|---|
| 405 |
|
|---|
| 406 | sub _parse_features {
|
|---|
| 407 | my $self = shift;
|
|---|
| 408 | my @defs = @_;
|
|---|
| 409 |
|
|---|
| 410 | my %features = ();
|
|---|
| 411 | foreach (@defs) {
|
|---|
| 412 | m{^(!)?};
|
|---|
| 413 | my $op = !(defined $1 && $1 eq '!');
|
|---|
| 414 | my $def = $';
|
|---|
| 415 |
|
|---|
| 416 | if ($def =~ m{^ZLIB$}) { $features{$&} = $op; }
|
|---|
| 417 | if ($def =~ m{^OPENSSL_USE_}) { $features{$'} = $op; }
|
|---|
| 418 | if ($def =~ m{^OPENSSL_NO_}) { $features{$'} = !$op; }
|
|---|
| 419 | }
|
|---|
| 420 |
|
|---|
| 421 | return %features;
|
|---|
| 422 | }
|
|---|
| 423 |
|
|---|
| 424 | sub _adjust_version {
|
|---|
| 425 | my $self = shift;
|
|---|
| 426 | my $version = shift;
|
|---|
| 427 | my $baseversion = $self->{baseversion};
|
|---|
| 428 |
|
|---|
| 429 | $version = $baseversion
|
|---|
| 430 | if ($baseversion ne '*' && $version ne '*'
|
|---|
| 431 | && cmp_versions($baseversion, $version) > 0);
|
|---|
| 432 |
|
|---|
| 433 | return $version;
|
|---|
| 434 | }
|
|---|
| 435 |
|
|---|
| 436 | =item B<< $ordinals->add SOURCE, NAME, TYPE, LIST >>
|
|---|
| 437 |
|
|---|
| 438 | Adds a new item from file SOURCE named NAME with the type TYPE,
|
|---|
| 439 | and a set of C macros in
|
|---|
| 440 | LIST that are expected to be defined or undefined to use this symbol, if
|
|---|
| 441 | any. For undefined macros, they each must be prefixed with a C<!>.
|
|---|
| 442 |
|
|---|
| 443 | If this symbol already exists in loaded data, it will be rewritten using
|
|---|
| 444 | the new input data, but will keep the same ordinal number and version.
|
|---|
| 445 | If it's entirely new, it will get a '?' and the current default version.
|
|---|
| 446 |
|
|---|
| 447 | =cut
|
|---|
| 448 |
|
|---|
| 449 | sub add {
|
|---|
| 450 | my $self = shift;
|
|---|
| 451 | my $source = shift; # file where item was defined
|
|---|
| 452 | my $name = shift;
|
|---|
| 453 | my $type = shift; # FUNCTION or VARIABLE
|
|---|
| 454 | my @defs = @_; # Macros from #ifdef and #ifndef
|
|---|
| 455 | # (the latter prefixed with a '!')
|
|---|
| 456 |
|
|---|
| 457 | # call signature for debug output
|
|---|
| 458 | my $verbsig = "add('$name' , '$type' , [ " . join(', ', @defs) . " ])";
|
|---|
| 459 |
|
|---|
| 460 | croak __PACKAGE__."->add got a bad type '$type'"
|
|---|
| 461 | unless $type eq 'FUNCTION' || $type eq 'VARIABLE';
|
|---|
| 462 |
|
|---|
| 463 | my %platforms = _parse_platforms(@defs);
|
|---|
| 464 | my %features = _parse_features(@defs);
|
|---|
| 465 |
|
|---|
| 466 | my @items = $self->items(filter => f_name($name));
|
|---|
| 467 | my $version = @items ? $items[0]->version() : $self->{currversion};
|
|---|
| 468 | my $intnum = @items ? $items[0]->intnum() : ++$self->{maxnum};
|
|---|
| 469 | my $number = @items ? $items[0]->number() : '?';
|
|---|
| 470 | print STDERR "DEBUG[",__PACKAGE__,":add] $verbsig\n",
|
|---|
| 471 | @items ? map { "\t".$_->to_string()."\n" } @items : "No previous items\n",
|
|---|
| 472 | if $self->{debug};
|
|---|
| 473 | @items = grep { $_->exists() } @items;
|
|---|
| 474 |
|
|---|
| 475 | my $new_item =
|
|---|
| 476 | OpenSSL::Ordinals::Item->new( source => $source,
|
|---|
| 477 | name => $name,
|
|---|
| 478 | type => $type,
|
|---|
| 479 | number => $number,
|
|---|
| 480 | intnum => $intnum,
|
|---|
| 481 | version =>
|
|---|
| 482 | $self->_adjust_version($version),
|
|---|
| 483 | exists => 1,
|
|---|
| 484 | platforms => { %platforms },
|
|---|
| 485 | features => [
|
|---|
| 486 | grep { $features{$_} } keys %features
|
|---|
| 487 | ] );
|
|---|
| 488 |
|
|---|
| 489 | push @items, $new_item;
|
|---|
| 490 | print STDERR "DEBUG[",__PACKAGE__,"::add] $verbsig\n", map { "\t".$_->to_string()."\n" } @items
|
|---|
| 491 | if $self->{debug};
|
|---|
| 492 | $self->_putback(@items);
|
|---|
| 493 |
|
|---|
| 494 | # If an alias was defined beforehand, add an item for it now
|
|---|
| 495 | my $alias = $self->{aliases}->{$name};
|
|---|
| 496 | delete $self->{aliases}->{$name};
|
|---|
| 497 |
|
|---|
| 498 | # For the caller to show
|
|---|
| 499 | my @returns = ( $new_item );
|
|---|
| 500 | push @returns, $self->add_alias($source, $alias->{name}, $name, @{$alias->{defs}})
|
|---|
| 501 | if defined $alias;
|
|---|
| 502 | return @returns;
|
|---|
| 503 | }
|
|---|
| 504 |
|
|---|
| 505 | =item B<< $ordinals->add_alias SOURCE, ALIAS, NAME, LIST >>
|
|---|
| 506 |
|
|---|
| 507 | Adds an alias ALIAS for the symbol NAME from file SOURCE, and a set of C macros
|
|---|
| 508 | in LIST that are expected to be defined or undefined to use this symbol, if any.
|
|---|
| 509 | For undefined macros, they each must be prefixed with a C<!>.
|
|---|
| 510 |
|
|---|
| 511 | If this symbol already exists in loaded data, it will be rewritten using
|
|---|
| 512 | the new input data. Otherwise, the data will just be store away, to wait
|
|---|
| 513 | that the symbol NAME shows up.
|
|---|
| 514 |
|
|---|
| 515 | =cut
|
|---|
| 516 |
|
|---|
| 517 | sub add_alias {
|
|---|
| 518 | my $self = shift;
|
|---|
| 519 | my $source = shift;
|
|---|
| 520 | my $alias = shift; # This is the alias being added
|
|---|
| 521 | my $name = shift; # For this name (assuming it exists)
|
|---|
| 522 | my @defs = @_; # Platform attributes for the alias
|
|---|
| 523 |
|
|---|
| 524 | # call signature for debug output
|
|---|
| 525 | my $verbsig =
|
|---|
| 526 | "add_alias('$source' , '$alias' , '$name' , [ " . join(', ', @defs) . " ])";
|
|---|
| 527 |
|
|---|
| 528 | croak "You're kidding me... $alias == $name" if $alias eq $name;
|
|---|
| 529 |
|
|---|
| 530 | my %platforms = _parse_platforms(@defs);
|
|---|
| 531 | my %features = _parse_features(@defs);
|
|---|
| 532 |
|
|---|
| 533 | croak "Alias with associated features is forbidden\n"
|
|---|
| 534 | if %features;
|
|---|
| 535 |
|
|---|
| 536 | my $f_byalias = f_name($alias);
|
|---|
| 537 | my $f_byname = f_name($name);
|
|---|
| 538 | my @items = $self->items(filter => $f_byalias);
|
|---|
| 539 | foreach my $item ($self->items(filter => $f_byname)) {
|
|---|
| 540 | push @items, $item unless grep { $_ == $item } @items;
|
|---|
| 541 | }
|
|---|
| 542 | @items = grep { $_->exists() } @items;
|
|---|
| 543 |
|
|---|
| 544 | croak "Alias already exists ($alias => $name)"
|
|---|
| 545 | if scalar @items > 1;
|
|---|
| 546 | if (scalar @items == 0) {
|
|---|
| 547 | # The item we want to alias for doesn't exist yet, so we cache the
|
|---|
| 548 | # alias and hope the item we're making an alias of shows up later
|
|---|
| 549 | $self->{aliases}->{$name} = { source => $source,
|
|---|
| 550 | name => $alias, defs => [ @defs ] };
|
|---|
| 551 |
|
|---|
| 552 | print STDERR "DEBUG[",__PACKAGE__,":add_alias] $verbsig\n",
|
|---|
| 553 | "\tSet future alias $alias => $name\n"
|
|---|
| 554 | if $self->{debug};
|
|---|
| 555 | return ();
|
|---|
| 556 | } elsif (scalar @items == 1) {
|
|---|
| 557 | # The rule is that an alias is more or less a copy of the original
|
|---|
| 558 | # item, just with another name. Also, the platforms given here are
|
|---|
| 559 | # given to the original item as well, with opposite values.
|
|---|
| 560 | my %alias_platforms = $items[0]->platforms();
|
|---|
| 561 | foreach (keys %platforms) {
|
|---|
| 562 | $alias_platforms{$_} = !$platforms{$_};
|
|---|
| 563 | }
|
|---|
| 564 | # We supposedly do now know how to do this... *ahem*
|
|---|
| 565 | $items[0]->{platforms} = { %alias_platforms };
|
|---|
| 566 |
|
|---|
| 567 | my $number =
|
|---|
| 568 | $items[0]->number() =~ m|^\?| ? '?+' : $items[0]->number();
|
|---|
| 569 | my $alias_item = OpenSSL::Ordinals::Item->new(
|
|---|
| 570 | source => $source,
|
|---|
| 571 | name => $alias,
|
|---|
| 572 | type => $items[0]->type(),
|
|---|
| 573 | number => $number,
|
|---|
| 574 | intnum => $items[0]->intnum(),
|
|---|
| 575 | version => $self->_adjust_version($items[0]->version()),
|
|---|
| 576 | exists => $items[0]->exists(),
|
|---|
| 577 | platforms => { %platforms },
|
|---|
| 578 | features => [ $items[0]->features() ]
|
|---|
| 579 | );
|
|---|
| 580 | push @items, $alias_item;
|
|---|
| 581 |
|
|---|
| 582 | print STDERR "DEBUG[",__PACKAGE__,":add_alias] $verbsig\n",
|
|---|
| 583 | map { "\t".$_->to_string()."\n" } @items
|
|---|
| 584 | if $self->{debug};
|
|---|
| 585 | $self->_putback(@items);
|
|---|
| 586 |
|
|---|
| 587 | # For the caller to show
|
|---|
| 588 | return ( $alias_item->to_string() );
|
|---|
| 589 | }
|
|---|
| 590 | croak "$name has an alias already (trying to add alias $alias)\n",
|
|---|
| 591 | "\t", join(", ", map { $_->name() } @items), "\n";
|
|---|
| 592 | }
|
|---|
| 593 |
|
|---|
| 594 | =item B<< $ordinals->set_version VERSION >>
|
|---|
| 595 |
|
|---|
| 596 | =item B<< $ordinals->set_version VERSION BASEVERSION >>
|
|---|
| 597 |
|
|---|
| 598 | Sets the default version for new symbol to VERSION.
|
|---|
| 599 |
|
|---|
| 600 | If given, BASEVERSION sets the base version, i.e. the minimum version
|
|---|
| 601 | for all symbols. If not given, it will be calculated as follows:
|
|---|
| 602 |
|
|---|
| 603 | =over 4
|
|---|
| 604 |
|
|---|
| 605 | If the given version is '*', then the base version will also be '*'.
|
|---|
| 606 |
|
|---|
| 607 | If the given version starts with '0.', the base version will be '0.0.0'.
|
|---|
| 608 |
|
|---|
| 609 | If the given version starts with '1.0.', the base version will be '1.0.0'.
|
|---|
| 610 |
|
|---|
| 611 | If the given version starts with '1.1.', the base version will be '1.1.0'.
|
|---|
| 612 |
|
|---|
| 613 | If the given version has a first number C<N> that's greater than 1, the
|
|---|
| 614 | base version will be formed from C<N>: 'N.0.0'.
|
|---|
| 615 |
|
|---|
| 616 | =back
|
|---|
| 617 |
|
|---|
| 618 | =cut
|
|---|
| 619 |
|
|---|
| 620 | sub set_version {
|
|---|
| 621 | my $self = shift;
|
|---|
| 622 | # '*' is for "we don't care"
|
|---|
| 623 | my $version = shift // '*';
|
|---|
| 624 | my $baseversion = shift // '*';
|
|---|
| 625 |
|
|---|
| 626 | if ($baseversion eq '*') {
|
|---|
| 627 | $baseversion = $version;
|
|---|
| 628 | if ($baseversion ne '*') {
|
|---|
| 629 | if ($baseversion =~ m|^(\d+)\.|, $1 > 1) {
|
|---|
| 630 | $baseversion = "$1.0.0";
|
|---|
| 631 | } else {
|
|---|
| 632 | $baseversion =~ s|^0\..*$|0.0.0|;
|
|---|
| 633 | $baseversion =~ s|^1\.0\..*$|1.0.0|;
|
|---|
| 634 | $baseversion =~ s|^1\.1\..*$|1.1.0|;
|
|---|
| 635 |
|
|---|
| 636 | die 'Invalid version'
|
|---|
| 637 | if ($baseversion ne '0.0.0'
|
|---|
| 638 | && $baseversion !~ m|^1\.[01]\.0$|);
|
|---|
| 639 | }
|
|---|
| 640 | }
|
|---|
| 641 | }
|
|---|
| 642 |
|
|---|
| 643 | die 'Invalid base version'
|
|---|
| 644 | if ($baseversion ne '*' && $version ne '*'
|
|---|
| 645 | && cmp_versions($baseversion, $version) > 0);
|
|---|
| 646 |
|
|---|
| 647 | $self->{currversion} = $version;
|
|---|
| 648 | $self->{baseversion} = $baseversion;
|
|---|
| 649 | foreach ($self->items(filter => sub { $_[0] eq '*' })) {
|
|---|
| 650 | $_->{version} = $self->{currversion};
|
|---|
| 651 | }
|
|---|
| 652 | return 1;
|
|---|
| 653 | }
|
|---|
| 654 |
|
|---|
| 655 | =item B<< $ordinals->invalidate >>
|
|---|
| 656 |
|
|---|
| 657 | Invalidates the whole working database. The practical effect is that all
|
|---|
| 658 | symbols are set to not exist, but are kept around in the database to retain
|
|---|
| 659 | ordinal numbers and versions.
|
|---|
| 660 |
|
|---|
| 661 | =cut
|
|---|
| 662 |
|
|---|
| 663 | sub invalidate {
|
|---|
| 664 | my $self = shift;
|
|---|
| 665 |
|
|---|
| 666 | foreach (@{$self->{contents}}) {
|
|---|
| 667 | foreach (@{$_ // []}) {
|
|---|
| 668 | $_->{exists} = 0;
|
|---|
| 669 | }
|
|---|
| 670 | }
|
|---|
| 671 | $self->{stats} = {};
|
|---|
| 672 | }
|
|---|
| 673 |
|
|---|
| 674 | =item B<< $ordinals->validate >>
|
|---|
| 675 |
|
|---|
| 676 | Validates the current working database by collection statistics on how many
|
|---|
| 677 | symbols were added and how many were changed. These numbers can be retrieved
|
|---|
| 678 | with B<< $ordinals->stats >>.
|
|---|
| 679 |
|
|---|
| 680 | =cut
|
|---|
| 681 |
|
|---|
| 682 | sub validate {
|
|---|
| 683 | my $self = shift;
|
|---|
| 684 |
|
|---|
| 685 | $self->{stats} = {};
|
|---|
| 686 | for my $i (1..$self->{maxnum}) {
|
|---|
| 687 | if ($i > $self->{loaded_maxnum}
|
|---|
| 688 | || (!@{$self->{loaded_contents}->[$i] // []}
|
|---|
| 689 | && @{$self->{contents}->[$i] // []})) {
|
|---|
| 690 | $self->{stats}->{new}++;
|
|---|
| 691 | }
|
|---|
| 692 | if ($i <= $self->{maxassigned}) {
|
|---|
| 693 | $self->{stats}->{assigned}++;
|
|---|
| 694 | } else {
|
|---|
| 695 | $self->{stats}->{unassigned}++;
|
|---|
| 696 | }
|
|---|
| 697 | next if ($i > $self->{loaded_maxnum});
|
|---|
| 698 |
|
|---|
| 699 | my @loaded_strings =
|
|---|
| 700 | map { $_->to_string() } @{$self->{loaded_contents}->[$i] // []};
|
|---|
| 701 | my @current_strings =
|
|---|
| 702 | map { $_->to_string() } @{$self->{contents}->[$i] // []};
|
|---|
| 703 |
|
|---|
| 704 | foreach my $str (@current_strings) {
|
|---|
| 705 | @loaded_strings = grep { $str ne $_ } @loaded_strings;
|
|---|
| 706 | }
|
|---|
| 707 | if (@loaded_strings) {
|
|---|
| 708 | $self->{stats}->{modified}++;
|
|---|
| 709 | }
|
|---|
| 710 | }
|
|---|
| 711 | }
|
|---|
| 712 |
|
|---|
| 713 | =item B<< $ordinals->stats >>
|
|---|
| 714 |
|
|---|
| 715 | Returns the statistics that B<validate> calculate.
|
|---|
| 716 |
|
|---|
| 717 | =cut
|
|---|
| 718 |
|
|---|
| 719 | sub stats {
|
|---|
| 720 | my $self = shift;
|
|---|
| 721 |
|
|---|
| 722 | return %{$self->{stats}};
|
|---|
| 723 | }
|
|---|
| 724 |
|
|---|
| 725 | =back
|
|---|
| 726 |
|
|---|
| 727 | =head2 Data elements
|
|---|
| 728 |
|
|---|
| 729 | Data elements, which is each line in an ordinals file, are instances
|
|---|
| 730 | of a separate class, OpenSSL::Ordinals::Item, with its own methods:
|
|---|
| 731 |
|
|---|
| 732 | =over 4
|
|---|
| 733 |
|
|---|
| 734 | =cut
|
|---|
| 735 |
|
|---|
| 736 | package OpenSSL::Ordinals::Item;
|
|---|
| 737 |
|
|---|
| 738 | use strict;
|
|---|
| 739 | use warnings;
|
|---|
| 740 | use Carp;
|
|---|
| 741 |
|
|---|
| 742 | =item B<new> I<%options>
|
|---|
| 743 |
|
|---|
| 744 | Creates a new instance of the C<OpenSSL::Ordinals::Item> class. It takes
|
|---|
| 745 | options in keyed pair form, i.e. a series of C<< key => value >> pairs.
|
|---|
| 746 | Available options are:
|
|---|
| 747 |
|
|---|
| 748 | =over 4
|
|---|
| 749 |
|
|---|
| 750 | =item B<< source => FILENAME >>, B<< from => STRING >>
|
|---|
| 751 |
|
|---|
| 752 | This will create a new item from FILENAME, filled with data coming from STRING.
|
|---|
| 753 |
|
|---|
| 754 | STRING must conform to the following EBNF description:
|
|---|
| 755 |
|
|---|
| 756 | ordinal string = symbol, spaces, ordinal, spaces, version, spaces,
|
|---|
| 757 | exist, ":", platforms, ":", type, ":", features;
|
|---|
| 758 | spaces = space, { space };
|
|---|
| 759 | space = " " | "\t";
|
|---|
| 760 | symbol = ( letter | "_" ), { letter | digit | "_" };
|
|---|
| 761 | ordinal = number | "?" | "?+";
|
|---|
| 762 | version = number, "_", number, "_", number, [ letter, [ letter ] ];
|
|---|
| 763 | exist = "EXIST" | "NOEXIST";
|
|---|
| 764 | platforms = platform, { ",", platform };
|
|---|
| 765 | platform = ( letter | "_" ) { letter | digit | "_" };
|
|---|
| 766 | type = "FUNCTION" | "VARIABLE";
|
|---|
| 767 | features = feature, { ",", feature };
|
|---|
| 768 | feature = ( letter | "_" ) { letter | digit | "_" };
|
|---|
| 769 | number = digit, { digit };
|
|---|
| 770 |
|
|---|
| 771 | (C<letter> and C<digit> are assumed self evident)
|
|---|
| 772 |
|
|---|
| 773 | =item B<< source => FILENAME >>, B<< name => STRING >>, B<< number => NUMBER >>,
|
|---|
| 774 | B<< version => STRING >>, B<< exists => BOOLEAN >>, B<< type => STRING >>,
|
|---|
| 775 | B<< platforms => HASHref >>, B<< features => LISTref >>
|
|---|
| 776 |
|
|---|
| 777 | This will create a new item with data coming from the arguments.
|
|---|
| 778 |
|
|---|
| 779 | =back
|
|---|
| 780 |
|
|---|
| 781 | =cut
|
|---|
| 782 |
|
|---|
| 783 | sub new {
|
|---|
| 784 | my $class = shift;
|
|---|
| 785 |
|
|---|
| 786 | if (ref($_[0]) eq $class) {
|
|---|
| 787 | return $class->new( map { $_ => $_[0]->{$_} } keys %{$_[0]} );
|
|---|
| 788 | }
|
|---|
| 789 |
|
|---|
| 790 | my %opts = @_;
|
|---|
| 791 |
|
|---|
| 792 | croak "No argument given" unless %opts;
|
|---|
| 793 |
|
|---|
| 794 | my $instance = undef;
|
|---|
| 795 | if ($opts{from}) {
|
|---|
| 796 | my @a = split /\s+/, $opts{from};
|
|---|
| 797 |
|
|---|
| 798 | croak "Badly formatted ordinals string: $opts{from}"
|
|---|
| 799 | unless ( scalar @a == 4
|
|---|
| 800 | && $a[0] =~ /^[A-Za-z_][A-Za-z_0-9]*$/
|
|---|
| 801 | && $a[1] =~ /^\d+|\?\+?$/
|
|---|
| 802 | && $a[2] =~ /^(?:\*|\d+_\d+_\d+[a-z]{0,2})$/
|
|---|
| 803 | && $a[3] =~ /^
|
|---|
| 804 | (?:NO)?EXIST:
|
|---|
| 805 | [^:]*:
|
|---|
| 806 | (?:FUNCTION|VARIABLE):
|
|---|
| 807 | [^:]*
|
|---|
| 808 | $
|
|---|
| 809 | /x );
|
|---|
| 810 |
|
|---|
| 811 | my @b = split /:/, $a[3];
|
|---|
| 812 | %opts = ( source => $opts{source},
|
|---|
| 813 | name => $a[0],
|
|---|
| 814 | number => $a[1],
|
|---|
| 815 | version => $a[2],
|
|---|
| 816 | exists => $b[0] eq 'EXIST',
|
|---|
| 817 | platforms => { map { m|^(!)?|; $' => !$1 }
|
|---|
| 818 | split /,/,$b[1] },
|
|---|
| 819 | type => $b[2],
|
|---|
| 820 | features => [ split /,/,$b[3] // '' ] );
|
|---|
| 821 | }
|
|---|
| 822 |
|
|---|
| 823 | if ($opts{name} && $opts{version} && defined $opts{exists} && $opts{type}
|
|---|
| 824 | && ref($opts{platforms} // {}) eq 'HASH'
|
|---|
| 825 | && ref($opts{features} // []) eq 'ARRAY') {
|
|---|
| 826 | my $version = $opts{version};
|
|---|
| 827 | $version =~ s|_|.|g;
|
|---|
| 828 |
|
|---|
| 829 | $instance = { source => $opts{source},
|
|---|
| 830 | name => $opts{name},
|
|---|
| 831 | type => $opts{type},
|
|---|
| 832 | number => $opts{number},
|
|---|
| 833 | intnum => $opts{intnum},
|
|---|
| 834 | version => $version,
|
|---|
| 835 | exists => !!$opts{exists},
|
|---|
| 836 | platforms => { %{$opts{platforms} // {}} },
|
|---|
| 837 | features => [ sort @{$opts{features} // []} ] };
|
|---|
| 838 | } else {
|
|---|
| 839 | croak __PACKAGE__."->new() called with bad arguments\n".
|
|---|
| 840 | join("", map { " $_\t=> ".$opts{$_}."\n" } sort keys %opts);
|
|---|
| 841 | }
|
|---|
| 842 |
|
|---|
| 843 | return bless $instance, $class;
|
|---|
| 844 | }
|
|---|
| 845 |
|
|---|
| 846 | sub DESTROY {
|
|---|
| 847 | }
|
|---|
| 848 |
|
|---|
| 849 | =item B<< $item->name >>
|
|---|
| 850 |
|
|---|
| 851 | The symbol name for this item.
|
|---|
| 852 |
|
|---|
| 853 | =item B<< $item->number >> (read-write)
|
|---|
| 854 |
|
|---|
| 855 | The positional number for this item.
|
|---|
| 856 |
|
|---|
| 857 | This may be '?' for an unassigned symbol, or '?+' for an unassigned symbol
|
|---|
| 858 | that's an alias for the previous symbol. '?' and '?+' must be properly
|
|---|
| 859 | handled by the caller. The caller may change this to an actual number.
|
|---|
| 860 |
|
|---|
| 861 | =item B<< $item->version >> (read-only)
|
|---|
| 862 |
|
|---|
| 863 | The version number for this item. Please note that these version numbers
|
|---|
| 864 | have underscore (C<_>) as a separator for the version parts.
|
|---|
| 865 |
|
|---|
| 866 | =item B<< $item->exists >> (read-only)
|
|---|
| 867 |
|
|---|
| 868 | A boolean that tells if this symbol exists in code or not.
|
|---|
| 869 |
|
|---|
| 870 | =item B<< $item->platforms >> (read-only)
|
|---|
| 871 |
|
|---|
| 872 | A hash table reference. The keys of the hash table are the names of
|
|---|
| 873 | the specified platforms, with a value of 0 to indicate that this symbol
|
|---|
| 874 | isn't available on that platform, and 1 to indicate that it is. Platforms
|
|---|
| 875 | that aren't mentioned default to 1.
|
|---|
| 876 |
|
|---|
| 877 | =item B<< $item->type >> (read-only)
|
|---|
| 878 |
|
|---|
| 879 | C<FUNCTION> or C<VARIABLE>, depending on what the symbol represents.
|
|---|
| 880 | Some platforms do not care about this, others do.
|
|---|
| 881 |
|
|---|
| 882 | =item B<< $item->features >> (read-only)
|
|---|
| 883 |
|
|---|
| 884 | An array reference, where every item indicates a feature where this symbol
|
|---|
| 885 | is available. If no features are mentioned, the symbol is always available.
|
|---|
| 886 | If any feature is mentioned, this symbol is I<only> available when those
|
|---|
| 887 | features are enabled.
|
|---|
| 888 |
|
|---|
| 889 | =cut
|
|---|
| 890 |
|
|---|
| 891 | our $AUTOLOAD;
|
|---|
| 892 |
|
|---|
| 893 | # Generic getter
|
|---|
| 894 | sub AUTOLOAD {
|
|---|
| 895 | my $self = shift;
|
|---|
| 896 | my $funcname = $AUTOLOAD;
|
|---|
| 897 | (my $item = $funcname) =~ s|.*::||g;
|
|---|
| 898 |
|
|---|
| 899 | croak "$funcname called as setter" if @_;
|
|---|
| 900 | croak "$funcname invalid" unless exists $self->{$item};
|
|---|
| 901 | return $self->{$item} if ref($self->{$item}) eq '';
|
|---|
| 902 | return @{$self->{$item}} if ref($self->{$item}) eq 'ARRAY';
|
|---|
| 903 | return %{$self->{$item}} if ref($self->{$item}) eq 'HASH';
|
|---|
| 904 | }
|
|---|
| 905 |
|
|---|
| 906 | =item B<< $item->intnum >> (read-write)
|
|---|
| 907 |
|
|---|
| 908 | Internal positional number. If I<< $item->number >> is '?' or '?+', the
|
|---|
| 909 | caller can use this to set a number for its purposes.
|
|---|
| 910 | If I<< $item->number >> is a number, I<< $item->intnum >> should be the
|
|---|
| 911 | same
|
|---|
| 912 |
|
|---|
| 913 | =cut
|
|---|
| 914 |
|
|---|
| 915 | # Getter/setters
|
|---|
| 916 | sub intnum {
|
|---|
| 917 | my $self = shift;
|
|---|
| 918 | my $value = shift;
|
|---|
| 919 | my $item = 'intnum';
|
|---|
| 920 |
|
|---|
| 921 | croak "$item called with extra arguments" if @_;
|
|---|
| 922 | $self->{$item} = "$value" if defined $value;
|
|---|
| 923 | return $self->{$item};
|
|---|
| 924 | }
|
|---|
| 925 |
|
|---|
| 926 | sub number {
|
|---|
| 927 | my $self = shift;
|
|---|
| 928 | my $value = shift;
|
|---|
| 929 | my $item = 'number';
|
|---|
| 930 |
|
|---|
| 931 | croak "$item called with extra arguments" if @_;
|
|---|
| 932 | $self->{$item} = "$value" if defined $value;
|
|---|
| 933 | return $self->{$item};
|
|---|
| 934 | }
|
|---|
| 935 |
|
|---|
| 936 | =item B<< $item->to_string >>
|
|---|
| 937 |
|
|---|
| 938 | Converts the item to a string that can be saved in an ordinals file.
|
|---|
| 939 |
|
|---|
| 940 | =cut
|
|---|
| 941 |
|
|---|
| 942 | sub to_string {
|
|---|
| 943 | my $self = shift;
|
|---|
| 944 |
|
|---|
| 945 | croak "Too many arguments" if @_;
|
|---|
| 946 | my %platforms = $self->platforms();
|
|---|
| 947 | my @features = $self->features();
|
|---|
| 948 | my $version = $self->version();
|
|---|
| 949 | $version =~ s|\.|_|g;
|
|---|
| 950 | return sprintf "%-39s %s\t%s\t%s:%s:%s:%s",
|
|---|
| 951 | $self->name(),
|
|---|
| 952 | $self->number(),
|
|---|
| 953 | $version,
|
|---|
| 954 | $self->exists() ? 'EXIST' : 'NOEXIST',
|
|---|
| 955 | join(',', (map { ($platforms{$_} ? '' : '!') . $_ }
|
|---|
| 956 | sort keys %platforms)),
|
|---|
| 957 | $self->type(),
|
|---|
| 958 | join(',', @features);
|
|---|
| 959 | }
|
|---|
| 960 |
|
|---|
| 961 | =back
|
|---|
| 962 |
|
|---|
| 963 | =head2 Comparators and filters
|
|---|
| 964 |
|
|---|
| 965 | For the B<< $ordinals->items >> method, there are a few functions to create
|
|---|
| 966 | comparators based on specific data:
|
|---|
| 967 |
|
|---|
| 968 | =over 4
|
|---|
| 969 |
|
|---|
| 970 | =cut
|
|---|
| 971 |
|
|---|
| 972 | # Go back to the main package to create comparators and filters
|
|---|
| 973 | package OpenSSL::Ordinals;
|
|---|
| 974 |
|
|---|
| 975 | # Comparators...
|
|---|
| 976 |
|
|---|
| 977 | =item B<by_name>
|
|---|
| 978 |
|
|---|
| 979 | Returns a comparator that will compare the names of two OpenSSL::Ordinals::Item
|
|---|
| 980 | objects.
|
|---|
| 981 |
|
|---|
| 982 | =cut
|
|---|
| 983 |
|
|---|
| 984 | sub by_name {
|
|---|
| 985 | return sub { $_[0]->name() cmp $_[1]->name() };
|
|---|
| 986 | }
|
|---|
| 987 |
|
|---|
| 988 | =item B<by_number>
|
|---|
| 989 |
|
|---|
| 990 | Returns a comparator that will compare the ordinal numbers of two
|
|---|
| 991 | OpenSSL::Ordinals::Item objects.
|
|---|
| 992 |
|
|---|
| 993 | =cut
|
|---|
| 994 |
|
|---|
| 995 | sub by_number {
|
|---|
| 996 | return sub { $_[0]->intnum() <=> $_[1]->intnum() };
|
|---|
| 997 | }
|
|---|
| 998 |
|
|---|
| 999 | =item B<by_version>
|
|---|
| 1000 |
|
|---|
| 1001 | Returns a comparator that will compare the version of two
|
|---|
| 1002 | OpenSSL::Ordinals::Item objects.
|
|---|
| 1003 |
|
|---|
| 1004 | =cut
|
|---|
| 1005 |
|
|---|
| 1006 | sub by_version {
|
|---|
| 1007 | return sub {
|
|---|
| 1008 | # cmp_versions comes from OpenSSL::Util
|
|---|
| 1009 | return cmp_versions($_[0]->version(), $_[1]->version());
|
|---|
| 1010 | }
|
|---|
| 1011 | }
|
|---|
| 1012 |
|
|---|
| 1013 | =back
|
|---|
| 1014 |
|
|---|
| 1015 | There are also the following filters:
|
|---|
| 1016 |
|
|---|
| 1017 | =over 4
|
|---|
| 1018 |
|
|---|
| 1019 | =cut
|
|---|
| 1020 |
|
|---|
| 1021 | # Filters... these are called by grep, the return sub must use $_ for
|
|---|
| 1022 | # the item to check
|
|---|
| 1023 |
|
|---|
| 1024 | =item B<f_version VERSION>
|
|---|
| 1025 |
|
|---|
| 1026 | Returns a filter that only lets through symbols with a version number
|
|---|
| 1027 | matching B<VERSION>.
|
|---|
| 1028 |
|
|---|
| 1029 | =cut
|
|---|
| 1030 |
|
|---|
| 1031 | sub f_version {
|
|---|
| 1032 | my $version = shift;
|
|---|
| 1033 |
|
|---|
| 1034 | croak "No version specified"
|
|---|
| 1035 | unless $version && $version =~ /^\d+\.\d+\.\d+[a-z]{0,2}$/;
|
|---|
| 1036 |
|
|---|
| 1037 | return sub { $_[0]->version() eq $version };
|
|---|
| 1038 | }
|
|---|
| 1039 |
|
|---|
| 1040 | =item B<f_number NUMBER>
|
|---|
| 1041 |
|
|---|
| 1042 | Returns a filter that only lets through symbols with the ordinal number
|
|---|
| 1043 | matching B<NUMBER>.
|
|---|
| 1044 |
|
|---|
| 1045 | NOTE that this returns a "magic" value that can not be used as a function.
|
|---|
| 1046 | It's only useful when passed directly as a filter to B<items>.
|
|---|
| 1047 |
|
|---|
| 1048 | =cut
|
|---|
| 1049 |
|
|---|
| 1050 | sub f_number {
|
|---|
| 1051 | my $number = shift;
|
|---|
| 1052 |
|
|---|
| 1053 | croak "No number specified"
|
|---|
| 1054 | unless $number && $number =~ /^\d+$/;
|
|---|
| 1055 |
|
|---|
| 1056 | return [ F_NUMBER, $number ];
|
|---|
| 1057 | }
|
|---|
| 1058 |
|
|---|
| 1059 |
|
|---|
| 1060 | =item B<f_name NAME>
|
|---|
| 1061 |
|
|---|
| 1062 | Returns a filter that only lets through symbols with the symbol name
|
|---|
| 1063 | matching B<NAME>.
|
|---|
| 1064 |
|
|---|
| 1065 | NOTE that this returns a "magic" value that can not be used as a function.
|
|---|
| 1066 | It's only useful when passed directly as a filter to B<items>.
|
|---|
| 1067 |
|
|---|
| 1068 | =cut
|
|---|
| 1069 |
|
|---|
| 1070 | sub f_name {
|
|---|
| 1071 | my $name = shift;
|
|---|
| 1072 |
|
|---|
| 1073 | croak "No name specified"
|
|---|
| 1074 | unless $name;
|
|---|
| 1075 |
|
|---|
| 1076 | return [ F_NAME, $name ];
|
|---|
| 1077 | }
|
|---|
| 1078 |
|
|---|
| 1079 | =back
|
|---|
| 1080 |
|
|---|
| 1081 | =head1 AUTHORS
|
|---|
| 1082 |
|
|---|
| 1083 | Richard Levitte E<lt>[email protected]<gt>.
|
|---|
| 1084 |
|
|---|
| 1085 | =cut
|
|---|
| 1086 |
|
|---|
| 1087 | 1;
|
|---|
