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 9package OpenSSL::Ordinals; 10 11use strict; 12use warnings; 13use Carp; 14use Scalar::Util qw(blessed); 15use OpenSSL::Util; 16 17use 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 25OpenSSL::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 42This is a OpenSSL private module to load an ordinals (F<.num>) file and 43write out the data you want, sorted and filtered according to your rules. 44 45An ordinals file is a file that enumerates all the symbols that a shared 46library or loadable module must export. Each of them have a unique 47assigned number as well as other attributes to indicate if they only exist 48on a subset of the supported platforms, or if they are specific to certain 49features. 50 51The unique numbers each symbol gets assigned needs to be maintained for a 52shared library or module to stay compatible with previous versions on 53platforms that maintain a transfer vector indexed by position rather than 54by name. They also help keep information on certain symbols that are 55aliases for others for certain platforms, or that have different forms 56on different platforms. 57 58=head2 Main methods 59 60=over 4 61 62=cut 63 64=item B<new> I<%options> 65 66Creates a new instance of the C<OpenSSL::Ordinals> class. It takes options 67in keyed pair form, i.e. a series of C<< key => value >> pairs. Available 68options are: 69 70=over 4 71 72=item B<< from => FILENAME >> 73 74Not only create a new instance, but immediately load it with data from the 75ordinals file FILENAME. 76 77=back 78 79=cut 80 81sub 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 107Loads the data from FILENAME into the instance. Any previously loaded data 108is dropped. 109 110Two internal databases are created. One database is simply a copy of the file 111contents and is treated as read-only. The other database is an exact copy of 112the first, but is treated as a work database, i.e. it can be modified and added 113to. 114 115=cut 116 117sub 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 174Renumber any item that doesn't have an assigned number yet. 175 176=cut 177 178sub 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 195If an ordinals file has been loaded, it gets rewritten with the data from 196the current work database. 197 198If there are more arguments, they are used as I<%options> with the 199same semantics as for B<< $ordinals->items >> described below, apart 200from B<sort>, which is forbidden here. 201 202=cut 203 204sub 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 215Writes the current work database data to the ordinals file FILENAME. 216This also validates the data, see B<< $ordinals->validate >> below. 217 218If there are more arguments, they are used as I<%options> with the 219same semantics as for B<< $ordinals->items >> described next, apart 220from B<sort>, which is forbidden here. 221 222=cut 223 224sub 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 246Returns a list of items according to a set of criteria. The criteria is 247given in form keyed pair form, i.e. a series of C<< key => value >> pairs. 248Available options are: 249 250=over 4 251 252=item B<< sort => SORTFUNCTION >> 253 254SORTFUNCTION is a reference to a function that takes two arguments, which 255correspond to the classic C<$a> and C<$b> that are available in a C<sort> 256block. 257 258=item B<< filter => FILTERFUNCTION >> 259 260FILTERFUNCTION is a reference to a function that takes one argument, which 261is every OpenSSL::Ordinals::Item element available. 262 263=back 264 265=cut 266 267sub 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 308sub _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 384sub _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 406sub _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{^BROTLI$}) { $features{$&} = $op; } 418 if ($def =~ m{^ZSTD$}) { $features{$&} = $op; } 419 if ($def =~ m{^OPENSSL_USE_}) { $features{$'} = $op; } 420 if ($def =~ m{^OPENSSL_NO_}) { $features{$'} = !$op; } 421 } 422 423 return %features; 424} 425 426sub _adjust_version { 427 my $self = shift; 428 my $version = shift; 429 my $baseversion = $self->{baseversion}; 430 431 $version = $baseversion 432 if ($baseversion ne '*' && $version ne '*' 433 && cmp_versions($baseversion, $version) > 0); 434 435 return $version; 436} 437 438=item B<< $ordinals->add SOURCE, NAME, TYPE, LIST >> 439 440Adds a new item from file SOURCE named NAME with the type TYPE, 441and a set of C macros in 442LIST that are expected to be defined or undefined to use this symbol, if 443any. For undefined macros, they each must be prefixed with a C<!>. 444 445If this symbol already exists in loaded data, it will be rewritten using 446the new input data, but will keep the same ordinal number and version. 447If it's entirely new, it will get a '?' and the current default version. 448 449=cut 450 451sub add { 452 my $self = shift; 453 my $source = shift; # file where item was defined 454 my $name = shift; 455 my $type = shift; # FUNCTION or VARIABLE 456 my @defs = @_; # Macros from #ifdef and #ifndef 457 # (the latter prefixed with a '!') 458 459 # call signature for debug output 460 my $verbsig = "add('$name' , '$type' , [ " . join(', ', @defs) . " ])"; 461 462 croak __PACKAGE__."->add got a bad type '$type'" 463 unless $type eq 'FUNCTION' || $type eq 'VARIABLE'; 464 465 my %platforms = _parse_platforms(@defs); 466 my %features = _parse_features(@defs); 467 468 my @items = $self->items(filter => f_name($name)); 469 my $version = @items ? $items[0]->version() : $self->{currversion}; 470 my $intnum = @items ? $items[0]->intnum() : ++$self->{maxnum}; 471 my $number = @items ? $items[0]->number() : '?'; 472 print STDERR "DEBUG[",__PACKAGE__,":add] $verbsig\n", 473 @items ? map { "\t".$_->to_string()."\n" } @items : "No previous items\n", 474 if $self->{debug}; 475 @items = grep { $_->exists() } @items; 476 477 my $new_item = 478 OpenSSL::Ordinals::Item->new( source => $source, 479 name => $name, 480 type => $type, 481 number => $number, 482 intnum => $intnum, 483 version => 484 $self->_adjust_version($version), 485 exists => 1, 486 platforms => { %platforms }, 487 features => [ 488 grep { $features{$_} } keys %features 489 ] ); 490 491 push @items, $new_item; 492 print STDERR "DEBUG[",__PACKAGE__,"::add] $verbsig\n", map { "\t".$_->to_string()."\n" } @items 493 if $self->{debug}; 494 $self->_putback(@items); 495 496 # If an alias was defined beforehand, add an item for it now 497 my $alias = $self->{aliases}->{$name}; 498 delete $self->{aliases}->{$name}; 499 500 # For the caller to show 501 my @returns = ( $new_item ); 502 push @returns, $self->add_alias($source, $alias->{name}, $name, @{$alias->{defs}}) 503 if defined $alias; 504 return @returns; 505} 506 507=item B<< $ordinals->add_alias SOURCE, ALIAS, NAME, LIST >> 508 509Adds an alias ALIAS for the symbol NAME from file SOURCE, and a set of C macros 510in LIST that are expected to be defined or undefined to use this symbol, if any. 511For undefined macros, they each must be prefixed with a C<!>. 512 513If this symbol already exists in loaded data, it will be rewritten using 514the new input data. Otherwise, the data will just be store away, to wait 515that the symbol NAME shows up. 516 517=cut 518 519sub add_alias { 520 my $self = shift; 521 my $source = shift; 522 my $alias = shift; # This is the alias being added 523 my $name = shift; # For this name (assuming it exists) 524 my @defs = @_; # Platform attributes for the alias 525 526 # call signature for debug output 527 my $verbsig = 528 "add_alias('$source' , '$alias' , '$name' , [ " . join(', ', @defs) . " ])"; 529 530 croak "You're kidding me... $alias == $name" if $alias eq $name; 531 532 my %platforms = _parse_platforms(@defs); 533 my %features = _parse_features(@defs); 534 535 croak "Alias with associated features is forbidden\n" 536 if %features; 537 538 my $f_byalias = f_name($alias); 539 my $f_byname = f_name($name); 540 my @items = $self->items(filter => $f_byalias); 541 foreach my $item ($self->items(filter => $f_byname)) { 542 push @items, $item unless grep { $_ == $item } @items; 543 } 544 @items = grep { $_->exists() } @items; 545 546 croak "Alias already exists ($alias => $name)" 547 if scalar @items > 1; 548 if (scalar @items == 0) { 549 # The item we want to alias for doesn't exist yet, so we cache the 550 # alias and hope the item we're making an alias of shows up later 551 $self->{aliases}->{$name} = { source => $source, 552 name => $alias, defs => [ @defs ] }; 553 554 print STDERR "DEBUG[",__PACKAGE__,":add_alias] $verbsig\n", 555 "\tSet future alias $alias => $name\n" 556 if $self->{debug}; 557 return (); 558 } elsif (scalar @items == 1) { 559 # The rule is that an alias is more or less a copy of the original 560 # item, just with another name. Also, the platforms given here are 561 # given to the original item as well, with opposite values. 562 my %alias_platforms = $items[0]->platforms(); 563 foreach (keys %platforms) { 564 $alias_platforms{$_} = !$platforms{$_}; 565 } 566 # We supposedly do now know how to do this... *ahem* 567 $items[0]->{platforms} = { %alias_platforms }; 568 569 my $number = 570 $items[0]->number() =~ m|^\?| ? '?+' : $items[0]->number(); 571 my $alias_item = OpenSSL::Ordinals::Item->new( 572 source => $source, 573 name => $alias, 574 type => $items[0]->type(), 575 number => $number, 576 intnum => $items[0]->intnum(), 577 version => $self->_adjust_version($items[0]->version()), 578 exists => $items[0]->exists(), 579 platforms => { %platforms }, 580 features => [ $items[0]->features() ] 581 ); 582 push @items, $alias_item; 583 584 print STDERR "DEBUG[",__PACKAGE__,":add_alias] $verbsig\n", 585 map { "\t".$_->to_string()."\n" } @items 586 if $self->{debug}; 587 $self->_putback(@items); 588 589 # For the caller to show 590 return ( $alias_item->to_string() ); 591 } 592 croak "$name has an alias already (trying to add alias $alias)\n", 593 "\t", join(", ", map { $_->name() } @items), "\n"; 594} 595 596=item B<< $ordinals->set_version VERSION >> 597 598=item B<< $ordinals->set_version VERSION BASEVERSION >> 599 600Sets the default version for new symbol to VERSION. 601 602If given, BASEVERSION sets the base version, i.e. the minimum version 603for all symbols. If not given, it will be calculated as follows: 604 605=over 4 606 607If the given version is '*', then the base version will also be '*'. 608 609If the given version starts with '0.', the base version will be '0.0.0'. 610 611If the given version starts with '1.0.', the base version will be '1.0.0'. 612 613If the given version starts with '1.1.', the base version will be '1.1.0'. 614 615If the given version has a first number C<N> that's greater than 1, the 616base version will be formed from C<N>: 'N.0.0'. 617 618=back 619 620=cut 621 622sub set_version { 623 my $self = shift; 624 # '*' is for "we don't care" 625 my $version = shift // '*'; 626 my $baseversion = shift // '*'; 627 628 if ($baseversion eq '*') { 629 $baseversion = $version; 630 if ($baseversion ne '*') { 631 if ($baseversion =~ m|^(\d+)\.|, $1 > 1) { 632 $baseversion = "$1.0.0"; 633 } else { 634 $baseversion =~ s|^0\..*$|0.0.0|; 635 $baseversion =~ s|^1\.0\..*$|1.0.0|; 636 $baseversion =~ s|^1\.1\..*$|1.1.0|; 637 638 die 'Invalid version' 639 if ($baseversion ne '0.0.0' 640 && $baseversion !~ m|^1\.[01]\.0$|); 641 } 642 } 643 } 644 645 die 'Invalid base version' 646 if ($baseversion ne '*' && $version ne '*' 647 && cmp_versions($baseversion, $version) > 0); 648 649 $self->{currversion} = $version; 650 $self->{baseversion} = $baseversion; 651 foreach ($self->items(filter => sub { $_[0] eq '*' })) { 652 $_->{version} = $self->{currversion}; 653 } 654 return 1; 655} 656 657=item B<< $ordinals->invalidate >> 658 659Invalidates the whole working database. The practical effect is that all 660symbols are set to not exist, but are kept around in the database to retain 661ordinal numbers and versions. 662 663=cut 664 665sub invalidate { 666 my $self = shift; 667 668 foreach (@{$self->{contents}}) { 669 foreach (@{$_ // []}) { 670 $_->{exists} = 0; 671 } 672 } 673 $self->{stats} = {}; 674} 675 676=item B<< $ordinals->validate >> 677 678Validates the current working database by collection statistics on how many 679symbols were added and how many were changed. These numbers can be retrieved 680with B<< $ordinals->stats >>. 681 682=cut 683 684sub validate { 685 my $self = shift; 686 687 $self->{stats} = {}; 688 for my $i (1..$self->{maxnum}) { 689 if ($i > $self->{loaded_maxnum} 690 || (!@{$self->{loaded_contents}->[$i] // []} 691 && @{$self->{contents}->[$i] // []})) { 692 $self->{stats}->{new}++; 693 } 694 if ($i <= $self->{maxassigned}) { 695 $self->{stats}->{assigned}++; 696 } else { 697 $self->{stats}->{unassigned}++; 698 } 699 next if ($i > $self->{loaded_maxnum}); 700 701 my @loaded_strings = 702 map { $_->to_string() } @{$self->{loaded_contents}->[$i] // []}; 703 my @current_strings = 704 map { $_->to_string() } @{$self->{contents}->[$i] // []}; 705 706 foreach my $str (@current_strings) { 707 @loaded_strings = grep { $str ne $_ } @loaded_strings; 708 } 709 if (@loaded_strings) { 710 $self->{stats}->{modified}++; 711 } 712 } 713} 714 715=item B<< $ordinals->stats >> 716 717Returns the statistics that B<validate> calculate. 718 719=cut 720 721sub stats { 722 my $self = shift; 723 724 return %{$self->{stats}}; 725} 726 727=back 728 729=head2 Data elements 730 731Data elements, which is each line in an ordinals file, are instances 732of a separate class, OpenSSL::Ordinals::Item, with its own methods: 733 734=over 4 735 736=cut 737 738package OpenSSL::Ordinals::Item; 739 740use strict; 741use warnings; 742use Carp; 743 744=item B<new> I<%options> 745 746Creates a new instance of the C<OpenSSL::Ordinals::Item> class. It takes 747options in keyed pair form, i.e. a series of C<< key => value >> pairs. 748Available options are: 749 750=over 4 751 752=item B<< source => FILENAME >>, B<< from => STRING >> 753 754This will create a new item from FILENAME, filled with data coming from STRING. 755 756STRING must conform to the following EBNF description: 757 758 ordinal string = symbol, spaces, ordinal, spaces, version, spaces, 759 exist, ":", platforms, ":", type, ":", features; 760 spaces = space, { space }; 761 space = " " | "\t"; 762 symbol = ( letter | "_" ), { letter | digit | "_" }; 763 ordinal = number | "?" | "?+"; 764 version = number, "_", number, "_", number, [ letter, [ letter ] ]; 765 exist = "EXIST" | "NOEXIST"; 766 platforms = platform, { ",", platform }; 767 platform = ( letter | "_" ) { letter | digit | "_" }; 768 type = "FUNCTION" | "VARIABLE"; 769 features = feature, { ",", feature }; 770 feature = ( letter | "_" ) { letter | digit | "_" }; 771 number = digit, { digit }; 772 773(C<letter> and C<digit> are assumed self evident) 774 775=item B<< source => FILENAME >>, B<< name => STRING >>, B<< number => NUMBER >>, 776 B<< version => STRING >>, B<< exists => BOOLEAN >>, B<< type => STRING >>, 777 B<< platforms => HASHref >>, B<< features => LISTref >> 778 779This will create a new item with data coming from the arguments. 780 781=back 782 783=cut 784 785sub new { 786 my $class = shift; 787 788 if (ref($_[0]) eq $class) { 789 return $class->new( map { $_ => $_[0]->{$_} } keys %{$_[0]} ); 790 } 791 792 my %opts = @_; 793 794 croak "No argument given" unless %opts; 795 796 my $instance = undef; 797 if ($opts{from}) { 798 my @a = split /\s+/, $opts{from}; 799 800 croak "Badly formatted ordinals string: $opts{from}" 801 unless ( scalar @a == 4 802 && $a[0] =~ /^[A-Za-z_][A-Za-z_0-9]*$/ 803 && $a[1] =~ /^\d+|\?\+?$/ 804 && $a[2] =~ /^(?:\*|\d+_\d+_\d+[a-z]{0,2})$/ 805 && $a[3] =~ /^ 806 (?:NO)?EXIST: 807 [^:]*: 808 (?:FUNCTION|VARIABLE): 809 [^:]* 810 $ 811 /x ); 812 813 my @b = split /:/, $a[3]; 814 %opts = ( source => $opts{source}, 815 name => $a[0], 816 number => $a[1], 817 version => $a[2], 818 exists => $b[0] eq 'EXIST', 819 platforms => { map { m|^(!)?|; $' => !$1 } 820 split /,/,$b[1] }, 821 type => $b[2], 822 features => [ split /,/,$b[3] // '' ] ); 823 } 824 825 if ($opts{name} && $opts{version} && defined $opts{exists} && $opts{type} 826 && ref($opts{platforms} // {}) eq 'HASH' 827 && ref($opts{features} // []) eq 'ARRAY') { 828 my $version = $opts{version}; 829 $version =~ s|_|.|g; 830 831 $instance = { source => $opts{source}, 832 name => $opts{name}, 833 type => $opts{type}, 834 number => $opts{number}, 835 intnum => $opts{intnum}, 836 version => $version, 837 exists => !!$opts{exists}, 838 platforms => { %{$opts{platforms} // {}} }, 839 features => [ sort @{$opts{features} // []} ] }; 840 } else { 841 croak __PACKAGE__."->new() called with bad arguments\n". 842 join("", map { " $_\t=> ".$opts{$_}."\n" } sort keys %opts); 843 } 844 845 return bless $instance, $class; 846} 847 848sub DESTROY { 849} 850 851=item B<< $item->name >> 852 853The symbol name for this item. 854 855=item B<< $item->number >> (read-write) 856 857The positional number for this item. 858 859This may be '?' for an unassigned symbol, or '?+' for an unassigned symbol 860that's an alias for the previous symbol. '?' and '?+' must be properly 861handled by the caller. The caller may change this to an actual number. 862 863=item B<< $item->version >> (read-only) 864 865The version number for this item. Please note that these version numbers 866have underscore (C<_>) as a separator for the version parts. 867 868=item B<< $item->exists >> (read-only) 869 870A boolean that tells if this symbol exists in code or not. 871 872=item B<< $item->platforms >> (read-only) 873 874A hash table reference. The keys of the hash table are the names of 875the specified platforms, with a value of 0 to indicate that this symbol 876isn't available on that platform, and 1 to indicate that it is. Platforms 877that aren't mentioned default to 1. 878 879=item B<< $item->type >> (read-only) 880 881C<FUNCTION> or C<VARIABLE>, depending on what the symbol represents. 882Some platforms do not care about this, others do. 883 884=item B<< $item->features >> (read-only) 885 886An array reference, where every item indicates a feature where this symbol 887is available. If no features are mentioned, the symbol is always available. 888If any feature is mentioned, this symbol is I<only> available when those 889features are enabled. 890 891=cut 892 893our $AUTOLOAD; 894 895# Generic getter 896sub AUTOLOAD { 897 my $self = shift; 898 my $funcname = $AUTOLOAD; 899 (my $item = $funcname) =~ s|.*::||g; 900 901 croak "$funcname called as setter" if @_; 902 croak "$funcname invalid" unless exists $self->{$item}; 903 return $self->{$item} if ref($self->{$item}) eq ''; 904 return @{$self->{$item}} if ref($self->{$item}) eq 'ARRAY'; 905 return %{$self->{$item}} if ref($self->{$item}) eq 'HASH'; 906} 907 908=item B<< $item->intnum >> (read-write) 909 910Internal positional number. If I<< $item->number >> is '?' or '?+', the 911caller can use this to set a number for its purposes. 912If I<< $item->number >> is a number, I<< $item->intnum >> should be the 913same 914 915=cut 916 917# Getter/setters 918sub intnum { 919 my $self = shift; 920 my $value = shift; 921 my $item = 'intnum'; 922 923 croak "$item called with extra arguments" if @_; 924 $self->{$item} = "$value" if defined $value; 925 return $self->{$item}; 926} 927 928sub number { 929 my $self = shift; 930 my $value = shift; 931 my $item = 'number'; 932 933 croak "$item called with extra arguments" if @_; 934 $self->{$item} = "$value" if defined $value; 935 return $self->{$item}; 936} 937 938=item B<< $item->to_string >> 939 940Converts the item to a string that can be saved in an ordinals file. 941 942=cut 943 944sub to_string { 945 my $self = shift; 946 947 croak "Too many arguments" if @_; 948 my %platforms = $self->platforms(); 949 my @features = $self->features(); 950 my $version = $self->version(); 951 $version =~ s|\.|_|g; 952 return sprintf "%-39s %s\t%s\t%s:%s:%s:%s", 953 $self->name(), 954 $self->number(), 955 $version, 956 $self->exists() ? 'EXIST' : 'NOEXIST', 957 join(',', (map { ($platforms{$_} ? '' : '!') . $_ } 958 sort keys %platforms)), 959 $self->type(), 960 join(',', @features); 961} 962 963=back 964 965=head2 Comparators and filters 966 967For the B<< $ordinals->items >> method, there are a few functions to create 968comparators based on specific data: 969 970=over 4 971 972=cut 973 974# Go back to the main package to create comparators and filters 975package OpenSSL::Ordinals; 976 977# Comparators... 978 979=item B<by_name> 980 981Returns a comparator that will compare the names of two OpenSSL::Ordinals::Item 982objects. 983 984=cut 985 986sub by_name { 987 return sub { $_[0]->name() cmp $_[1]->name() }; 988} 989 990=item B<by_number> 991 992Returns a comparator that will compare the ordinal numbers of two 993OpenSSL::Ordinals::Item objects. 994 995=cut 996 997sub by_number { 998 return sub { $_[0]->intnum() <=> $_[1]->intnum() }; 999} 1000 1001=item B<by_version> 1002 1003Returns a comparator that will compare the version of two 1004OpenSSL::Ordinals::Item objects. 1005 1006=cut 1007 1008sub by_version { 1009 return sub { 1010 # cmp_versions comes from OpenSSL::Util 1011 return cmp_versions($_[0]->version(), $_[1]->version()); 1012 } 1013} 1014 1015=back 1016 1017There are also the following filters: 1018 1019=over 4 1020 1021=cut 1022 1023# Filters... these are called by grep, the return sub must use $_ for 1024# the item to check 1025 1026=item B<f_version VERSION> 1027 1028Returns a filter that only lets through symbols with a version number 1029matching B<VERSION>. 1030 1031=cut 1032 1033sub f_version { 1034 my $version = shift; 1035 1036 croak "No version specified" 1037 unless $version && $version =~ /^\d+\.\d+\.\d+[a-z]{0,2}$/; 1038 1039 return sub { $_[0]->version() eq $version }; 1040} 1041 1042=item B<f_number NUMBER> 1043 1044Returns a filter that only lets through symbols with the ordinal number 1045matching B<NUMBER>. 1046 1047NOTE that this returns a "magic" value that can not be used as a function. 1048It's only useful when passed directly as a filter to B<items>. 1049 1050=cut 1051 1052sub f_number { 1053 my $number = shift; 1054 1055 croak "No number specified" 1056 unless $number && $number =~ /^\d+$/; 1057 1058 return [ F_NUMBER, $number ]; 1059} 1060 1061 1062=item B<f_name NAME> 1063 1064Returns a filter that only lets through symbols with the symbol name 1065matching B<NAME>. 1066 1067NOTE that this returns a "magic" value that can not be used as a function. 1068It's only useful when passed directly as a filter to B<items>. 1069 1070=cut 1071 1072sub f_name { 1073 my $name = shift; 1074 1075 croak "No name specified" 1076 unless $name; 1077 1078 return [ F_NAME, $name ]; 1079} 1080 1081=back 1082 1083=head1 AUTHORS 1084 1085Richard Levitte E<lt>levitte@openssl.orgE<gt>. 1086 1087=cut 1088 10891; 1090
