1#! /usr/bin/env perl 2# Copyright 2018-2021 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[2]->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{^OPENSSL_USE_}) { $features{$'} = $op; } 418 if ($def =~ m{^OPENSSL_NO_}) { $features{$'} = !$op; } 419 } 420 421 return %features; 422} 423 424sub _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 438Adds a new item from file SOURCE named NAME with the type TYPE, 439and a set of C macros in 440LIST that are expected to be defined or undefined to use this symbol, if 441any. For undefined macros, they each must be prefixed with a C<!>. 442 443If this symbol already exists in loaded data, it will be rewritten using 444the new input data, but will keep the same ordinal number and version. 445If it's entirely new, it will get a '?' and the current default version. 446 447=cut 448 449sub 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 507Adds an alias ALIAS for the symbol NAME from file SOURCE, and a set of C macros 508in LIST that are expected to be defined or undefined to use this symbol, if any. 509For undefined macros, they each must be prefixed with a C<!>. 510 511If this symbol already exists in loaded data, it will be rewritten using 512the new input data. Otherwise, the data will just be store away, to wait 513that the symbol NAME shows up. 514 515=cut 516 517sub 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 598Sets the default version for new symbol to VERSION. 599 600If given, BASEVERSION sets the base version, i.e. the minimum version 601for all symbols. If not given, it will be calculated as follows: 602 603=over 4 604 605If the given version is '*', then the base version will also be '*'. 606 607If the given version starts with '0.', the base version will be '0.0.0'. 608 609If the given version starts with '1.0.', the base version will be '1.0.0'. 610 611If the given version starts with '1.1.', the base version will be '1.1.0'. 612 613If the given version has a first number C<N> that's greater than 1, the 614base version will be formed from C<N>: 'N.0.0'. 615 616=back 617 618=cut 619 620sub 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 657Invalidates the whole working database. The practical effect is that all 658symbols are set to not exist, but are kept around in the database to retain 659ordinal numbers and versions. 660 661=cut 662 663sub 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 676Validates the current working database by collection statistics on how many 677symbols were added and how many were changed. These numbers can be retrieved 678with B<< $ordinals->stats >>. 679 680=cut 681 682sub 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 715Returns the statistics that B<validate> calculate. 716 717=cut 718 719sub stats { 720 my $self = shift; 721 722 return %{$self->{stats}}; 723} 724 725=back 726 727=head2 Data elements 728 729Data elements, which is each line in an ordinals file, are instances 730of a separate class, OpenSSL::Ordinals::Item, with its own methods: 731 732=over 4 733 734=cut 735 736package OpenSSL::Ordinals::Item; 737 738use strict; 739use warnings; 740use Carp; 741 742=item B<new> I<%options> 743 744Creates a new instance of the C<OpenSSL::Ordinals::Item> class. It takes 745options in keyed pair form, i.e. a series of C<< key => value >> pairs. 746Available options are: 747 748=over 4 749 750=item B<< source => FILENAME >>, B<< from => STRING >> 751 752This will create a new item from FILENAME, filled with data coming from STRING. 753 754STRING 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 777This will create a new item with data coming from the arguments. 778 779=back 780 781=cut 782 783sub 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 846sub DESTROY { 847} 848 849=item B<< $item->name >> 850 851The symbol name for this item. 852 853=item B<< $item->number >> (read-write) 854 855The positional number for this item. 856 857This may be '?' for an unassigned symbol, or '?+' for an unassigned symbol 858that's an alias for the previous symbol. '?' and '?+' must be properly 859handled by the caller. The caller may change this to an actual number. 860 861=item B<< $item->version >> (read-only) 862 863The version number for this item. Please note that these version numbers 864have underscore (C<_>) as a separator for the version parts. 865 866=item B<< $item->exists >> (read-only) 867 868A boolean that tells if this symbol exists in code or not. 869 870=item B<< $item->platforms >> (read-only) 871 872A hash table reference. The keys of the hash table are the names of 873the specified platforms, with a value of 0 to indicate that this symbol 874isn't available on that platform, and 1 to indicate that it is. Platforms 875that aren't mentioned default to 1. 876 877=item B<< $item->type >> (read-only) 878 879C<FUNCTION> or C<VARIABLE>, depending on what the symbol represents. 880Some platforms do not care about this, others do. 881 882=item B<< $item->features >> (read-only) 883 884An array reference, where every item indicates a feature where this symbol 885is available. If no features are mentioned, the symbol is always available. 886If any feature is mentioned, this symbol is I<only> available when those 887features are enabled. 888 889=cut 890 891our $AUTOLOAD; 892 893# Generic getter 894sub 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 908Internal positional number. If I<< $item->number >> is '?' or '?+', the 909caller can use this to set a number for its purposes. 910If I<< $item->number >> is a number, I<< $item->intnum >> should be the 911same 912 913=cut 914 915# Getter/setters 916sub 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 926sub 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 938Converts the item to a string that can be saved in an ordinals file. 939 940=cut 941 942sub 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 965For the B<< $ordinals->items >> method, there are a few functions to create 966comparators based on specific data: 967 968=over 4 969 970=cut 971 972# Go back to the main package to create comparators and filters 973package OpenSSL::Ordinals; 974 975# Comparators... 976 977=item B<by_name> 978 979Returns a comparator that will compare the names of two OpenSSL::Ordinals::Item 980objects. 981 982=cut 983 984sub by_name { 985 return sub { $_[0]->name() cmp $_[1]->name() }; 986} 987 988=item B<by_number> 989 990Returns a comparator that will compare the ordinal numbers of two 991OpenSSL::Ordinals::Item objects. 992 993=cut 994 995sub by_number { 996 return sub { $_[0]->intnum() <=> $_[1]->intnum() }; 997} 998 999=item B<by_version> 1000 1001Returns a comparator that will compare the version of two 1002OpenSSL::Ordinals::Item objects. 1003 1004=cut 1005 1006sub 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 1015There 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 1026Returns a filter that only lets through symbols with a version number 1027matching B<VERSION>. 1028 1029=cut 1030 1031sub 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 1042Returns a filter that only lets through symbols with the ordinal number 1043matching B<NUMBER>. 1044 1045NOTE that this returns a "magic" value that can not be used as a function. 1046It's only useful when passed directly as a filter to B<items>. 1047 1048=cut 1049 1050sub 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 1062Returns a filter that only lets through symbols with the symbol name 1063matching B<NAME>. 1064 1065NOTE that this returns a "magic" value that can not be used as a function. 1066It's only useful when passed directly as a filter to B<items>. 1067 1068=cut 1069 1070sub 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 1083Richard Levitte E<lt>levitte@openssl.orgE<gt>. 1084 1085=cut 1086 10871; 1088
