]>
Commit | Line | Data |
---|---|---|
91a99748 | 1 | #! /usr/bin/env perl |
a28d06f3 | 2 | # Copyright 2018-2021 The OpenSSL Project Authors. All Rights Reserved. |
91a99748 | 3 | # |
9059ab42 | 4 | # Licensed under the Apache License 2.0 (the "License"). You may not use |
91a99748 RL |
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); | |
bfc3b4ff | 15 | use OpenSSL::Util; |
91a99748 | 16 | |
15ba1096 RL |
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 | ||
91a99748 RL |
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 | |
3da95f3c | 67 | in keyed pair form, i.e. a series of C<< key => value >> pairs. Available |
91a99748 RL |
68 | options are: |
69 | ||
70 | =over 4 | |
71 | ||
3da95f3c | 72 | =item B<< from => FILENAME >> |
91a99748 RL |
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 = { | |
15ba1096 RL |
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 | |
3da95f3c | 89 | maxassigned => 0, # Current highest assigned item number |
15ba1096 RL |
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' | |
15ba1096 | 95 | debug => $opts{debug}, |
91a99748 RL |
96 | }; |
97 | bless $instance, $class; | |
98 | ||
bfc3b4ff | 99 | $instance->set_version($opts{version}); |
91a99748 RL |
100 | $instance->load($opts{from}) if defined($opts{from}); |
101 | ||
102 | return $instance; | |
103 | } | |
104 | ||
3da95f3c | 105 | =item B<< $ordinals->load FILENAME >> |
91a99748 RL |
106 | |
107 | Loads the data from FILENAME into the instance. Any previously loaded data | |
108 | is dropped. | |
109 | ||
15ba1096 RL |
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 | ||
91a99748 RL |
115 | =cut |
116 | ||
117 | sub load { | |
118 | my $self = shift; | |
119 | my $filename = shift; | |
120 | ||
91a99748 RL |
121 | croak "Undefined filename" unless defined($filename); |
122 | ||
15ba1096 RL |
123 | my @tmp_contents = (); |
124 | my %tmp_name2num = (); | |
3da95f3c | 125 | my $max_assigned = 0; |
91a99748 RL |
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 | ||
50ccc176 | 133 | my $item = OpenSSL::Ordinals::Item->new(source => $filename, from => $_); |
91a99748 | 134 | |
15ba1096 | 135 | my $num = $item->number(); |
3da95f3c RL |
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 | } | |
91a99748 | 147 | |
3da95f3c RL |
148 | $item->intnum($num); |
149 | push @{$tmp_contents[$num]}, $item; | |
150 | $tmp_name2num{$item->name()} = $num; | |
91a99748 RL |
151 | } |
152 | close F; | |
153 | ||
154 | $self->{contents} = [ @tmp_contents ]; | |
15ba1096 | 155 | $self->{name2num} = { %tmp_name2num }; |
3da95f3c | 156 | $self->{maxassigned} = $max_assigned; |
15ba1096 RL |
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 | ||
81ddd952 RL |
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; | |
0c12ca72 | 182 | foreach ($self->items(sort => by_number())) { |
81ddd952 RL |
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 >> | |
15ba1096 | 192 | |
0c12ca72 RL |
193 | =item B<< $ordinals->rewrite >>, I<%options> |
194 | ||
15ba1096 RL |
195 | If an ordinals file has been loaded, it gets rewritten with the data from |
196 | the current work database. | |
197 | ||
0c12ca72 RL |
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 | ||
15ba1096 RL |
202 | =cut |
203 | ||
204 | sub rewrite { | |
205 | my $self = shift; | |
0c12ca72 | 206 | my %opts = @_; |
15ba1096 | 207 | |
0c12ca72 | 208 | $self->write($self->{filename}, %opts); |
15ba1096 RL |
209 | } |
210 | ||
3da95f3c | 211 | =item B<< $ordinals->write FILENAME >> |
15ba1096 | 212 | |
0c12ca72 RL |
213 | =item B<< $ordinals->write FILENAME >>, I<%options> |
214 | ||
15ba1096 | 215 | Writes the current work database data to the ordinals file FILENAME. |
3da95f3c | 216 | This also validates the data, see B<< $ordinals->validate >> below. |
15ba1096 | 217 | |
0c12ca72 RL |
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 | ||
15ba1096 RL |
222 | =cut |
223 | ||
224 | sub write { | |
225 | my $self = shift; | |
226 | my $filename = shift; | |
0c12ca72 | 227 | my %opts = @_; |
15ba1096 RL |
228 | |
229 | croak "Undefined filename" unless defined($filename); | |
0c12ca72 | 230 | croak "The 'sort' option is not allowed" if $opts{sort}; |
15ba1096 RL |
231 | |
232 | $self->validate(); | |
233 | ||
234 | open F, '>', $filename or croak "Unable to open $filename"; | |
0c12ca72 | 235 | foreach ($self->items(%opts, sort => by_number())) { |
15ba1096 RL |
236 | print F $_->to_string(),"\n"; |
237 | } | |
238 | close F; | |
239 | $self->{filename} = $filename; | |
240 | $self->{loaded_maxnum} = $self->{maxnum}; | |
91a99748 RL |
241 | return 1; |
242 | } | |
243 | ||
3da95f3c | 244 | =item B<< $ordinals->items >> I<%options> |
91a99748 RL |
245 | |
246 | Returns a list of items according to a set of criteria. The criteria is | |
3da95f3c | 247 | given in form keyed pair form, i.e. a series of C<< key => value >> pairs. |
91a99748 RL |
248 | Available options are: |
249 | ||
250 | =over 4 | |
251 | ||
3da95f3c | 252 | =item B<< sort => SORTFUNCTION >> |
91a99748 RL |
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 | ||
3da95f3c | 258 | =item B<< filter => FILTERFUNCTION >> |
91a99748 | 259 | |
79c44b4e | 260 | FILTERFUNCTION is a reference to a function that takes one argument, which |
91a99748 RL |
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 | ||
15ba1096 RL |
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 | ||
91a99748 RL |
294 | return sort { $comparator->($a, $b); } @l |
295 | if (defined $comparator); | |
296 | return @l; | |
297 | } | |
298 | ||
15ba1096 RL |
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 | |
50ccc176 | 302 | # - They MUST have the same version |
15ba1096 RL |
303 | # - For platforms, both MUST hold the same ones, but with opposite values |
304 | # - For features, both MUST hold the same ones. | |
50ccc176 | 305 | # - They MUST NOT have identical name, type, numeral, version, platforms, and features |
15ba1096 RL |
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) { | |
50ccc176 DDO |
313 | croak "Wrong number of items: ", scalar @items, "\n ", |
314 | join("\n ", map { $_->{source}.": ".$_->name() } @items), "\n"; | |
15ba1096 RL |
315 | } |
316 | if (scalar @items == 2) { | |
317 | # Collect some data | |
318 | my %numbers = (); | |
319 | my %versions = (); | |
320 | my %features = (); | |
321 | foreach (@items) { | |
3da95f3c | 322 | $numbers{$_->intnum()} = 1; |
15ba1096 RL |
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: ", | |
3da95f3c | 331 | join(", ", map { $_->name()." => ".$_->intnum() } @items), "\n" |
15ba1096 RL |
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 | ||
50ccc176 DDO |
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 | ||
15ba1096 RL |
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 | } | |
3da95f3c | 381 | $self->{contents}->[$items[0]->intnum()] = [ @items ]; |
15ba1096 RL |
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; } | |
15ba1096 RL |
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; } | |
12e96a23 | 417 | if ($def =~ m{^BROTLI$}) { $features{$&} = $op; } |
caf9317d | 418 | if ($def =~ m{^ZSTD$}) { $features{$&} = $op; } |
15ba1096 RL |
419 | if ($def =~ m{^OPENSSL_USE_}) { $features{$'} = $op; } |
420 | if ($def =~ m{^OPENSSL_NO_}) { $features{$'} = !$op; } | |
15ba1096 RL |
421 | } |
422 | ||
423 | return %features; | |
424 | } | |
425 | ||
bfc3b4ff RL |
426 | sub _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 | ||
50ccc176 | 438 | =item B<< $ordinals->add SOURCE, NAME, TYPE, LIST >> |
15ba1096 | 439 | |
50ccc176 DDO |
440 | Adds a new item from file SOURCE named NAME with the type TYPE, |
441 | and a set of C macros in | |
15ba1096 RL |
442 | LIST that are expected to be defined or undefined to use this symbol, if |
443 | any. For undefined macros, they each must be prefixed with a C<!>. | |
444 | ||
445 | If this symbol already exists in loaded data, it will be rewritten using | |
446 | the new input data, but will keep the same ordinal number and version. | |
3da95f3c | 447 | If it's entirely new, it will get a '?' and the current default version. |
15ba1096 RL |
448 | |
449 | =cut | |
450 | ||
451 | sub add { | |
452 | my $self = shift; | |
50ccc176 | 453 | my $source = shift; # file where item was defined |
15ba1096 RL |
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}; | |
3da95f3c RL |
470 | my $intnum = @items ? $items[0]->intnum() : ++$self->{maxnum}; |
471 | my $number = @items ? $items[0]->number() : '?'; | |
15ba1096 RL |
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 = | |
50ccc176 DDO |
478 | OpenSSL::Ordinals::Item->new( source => $source, |
479 | name => $name, | |
15ba1096 RL |
480 | type => $type, |
481 | number => $number, | |
3da95f3c | 482 | intnum => $intnum, |
bfc3b4ff RL |
483 | version => |
484 | $self->_adjust_version($version), | |
15ba1096 RL |
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 ); | |
50ccc176 | 502 | push @returns, $self->add_alias($source, $alias->{name}, $name, @{$alias->{defs}}) |
15ba1096 RL |
503 | if defined $alias; |
504 | return @returns; | |
505 | } | |
506 | ||
50ccc176 | 507 | =item B<< $ordinals->add_alias SOURCE, ALIAS, NAME, LIST >> |
15ba1096 | 508 | |
50ccc176 DDO |
509 | Adds an alias ALIAS for the symbol NAME from file SOURCE, and a set of C macros |
510 | in LIST that are expected to be defined or undefined to use this symbol, if any. | |
15ba1096 RL |
511 | For undefined macros, they each must be prefixed with a C<!>. |
512 | ||
513 | If this symbol already exists in loaded data, it will be rewritten using | |
514 | the new input data. Otherwise, the data will just be store away, to wait | |
515 | that the symbol NAME shows up. | |
516 | ||
517 | =cut | |
518 | ||
519 | sub add_alias { | |
520 | my $self = shift; | |
50ccc176 | 521 | my $source = shift; |
15ba1096 RL |
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 = | |
50ccc176 | 528 | "add_alias('$source' , '$alias' , '$name' , [ " . join(', ', @defs) . " ])"; |
15ba1096 | 529 | |
50ccc176 | 530 | croak "You're kidding me... $alias == $name" if $alias eq $name; |
15ba1096 RL |
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 | |
50ccc176 DDO |
551 | $self->{aliases}->{$name} = { source => $source, |
552 | name => $alias, defs => [ @defs ] }; | |
15ba1096 RL |
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 | ||
3da95f3c RL |
569 | my $number = |
570 | $items[0]->number() =~ m|^\?| ? '?+' : $items[0]->number(); | |
15ba1096 | 571 | my $alias_item = OpenSSL::Ordinals::Item->new( |
50ccc176 | 572 | source => $source, |
15ba1096 RL |
573 | name => $alias, |
574 | type => $items[0]->type(), | |
3da95f3c RL |
575 | number => $number, |
576 | intnum => $items[0]->intnum(), | |
bfc3b4ff | 577 | version => $self->_adjust_version($items[0]->version()), |
15ba1096 RL |
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 | ||
3da95f3c | 596 | =item B<< $ordinals->set_version VERSION >> |
15ba1096 | 597 | |
3da95f3c | 598 | =item B<< $ordinals->set_version VERSION BASEVERSION >> |
bfc3b4ff | 599 | |
15ba1096 RL |
600 | Sets the default version for new symbol to VERSION. |
601 | ||
bfc3b4ff RL |
602 | If given, BASEVERSION sets the base version, i.e. the minimum version |
603 | for all symbols. If not given, it will be calculated as follows: | |
604 | ||
605 | =over 4 | |
606 | ||
607 | If the given version is '*', then the base version will also be '*'. | |
608 | ||
609 | If the given version starts with '0.', the base version will be '0.0.0'. | |
610 | ||
611 | If the given version starts with '1.0.', the base version will be '1.0.0'. | |
612 | ||
613 | If the given version starts with '1.1.', the base version will be '1.1.0'. | |
614 | ||
615 | If the given version has a first number C<N> that's greater than 1, the | |
616 | base version will be formed from C<N>: 'N.0.0'. | |
617 | ||
618 | =back | |
619 | ||
15ba1096 RL |
620 | =cut |
621 | ||
622 | sub set_version { | |
623 | my $self = shift; | |
bfc3b4ff RL |
624 | # '*' is for "we don't care" |
625 | my $version = shift // '*'; | |
626 | my $baseversion = shift // '*'; | |
15ba1096 | 627 | |
bfc3b4ff RL |
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 | ||
15ba1096 | 649 | $self->{currversion} = $version; |
bfc3b4ff | 650 | $self->{baseversion} = $baseversion; |
15ba1096 RL |
651 | foreach ($self->items(filter => sub { $_[0] eq '*' })) { |
652 | $_->{version} = $self->{currversion}; | |
653 | } | |
654 | return 1; | |
655 | } | |
656 | ||
3da95f3c | 657 | =item B<< $ordinals->invalidate >> |
15ba1096 RL |
658 | |
659 | Invalidates the whole working database. The practical effect is that all | |
660 | symbols are set to not exist, but are kept around in the database to retain | |
661 | ordinal numbers and versions. | |
662 | ||
663 | =cut | |
664 | ||
665 | sub invalidate { | |
666 | my $self = shift; | |
667 | ||
668 | foreach (@{$self->{contents}}) { | |
669 | foreach (@{$_ // []}) { | |
670 | $_->{exists} = 0; | |
671 | } | |
672 | } | |
673 | $self->{stats} = {}; | |
674 | } | |
675 | ||
3da95f3c | 676 | =item B<< $ordinals->validate >> |
15ba1096 RL |
677 | |
678 | Validates the current working database by collection statistics on how many | |
679 | symbols were added and how many were changed. These numbers can be retrieved | |
3da95f3c | 680 | with B<< $ordinals->stats >>. |
15ba1096 RL |
681 | |
682 | =cut | |
683 | ||
684 | sub 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 | } | |
a4aab787 RL |
694 | if ($i <= $self->{maxassigned}) { |
695 | $self->{stats}->{assigned}++; | |
696 | } else { | |
697 | $self->{stats}->{unassigned}++; | |
698 | } | |
15ba1096 RL |
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 | ||
3da95f3c | 715 | =item B<< $ordinals->stats >> |
15ba1096 RL |
716 | |
717 | Returns the statistics that B<validate> calculate. | |
718 | ||
719 | =cut | |
720 | ||
721 | sub stats { | |
722 | my $self = shift; | |
723 | ||
724 | return %{$self->{stats}}; | |
725 | } | |
726 | ||
91a99748 RL |
727 | =back |
728 | ||
729 | =head2 Data elements | |
730 | ||
731 | Data elements, which is each line in an ordinals file, are instances | |
732 | of a separate class, OpenSSL::Ordinals::Item, with its own methods: | |
733 | ||
734 | =over 4 | |
735 | ||
736 | =cut | |
737 | ||
738 | package OpenSSL::Ordinals::Item; | |
739 | ||
740 | use strict; | |
741 | use warnings; | |
742 | use Carp; | |
743 | ||
744 | =item B<new> I<%options> | |
745 | ||
746 | Creates a new instance of the C<OpenSSL::Ordinals::Item> class. It takes | |
3da95f3c | 747 | options in keyed pair form, i.e. a series of C<< key => value >> pairs. |
91a99748 RL |
748 | Available options are: |
749 | ||
750 | =over 4 | |
751 | ||
50ccc176 | 752 | =item B<< source => FILENAME >>, B<< from => STRING >> |
91a99748 | 753 | |
50ccc176 | 754 | This will create a new item from FILENAME, filled with data coming from STRING. |
91a99748 RL |
755 | |
756 | STRING 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"; | |
3da95f3c RL |
762 | symbol = ( letter | "_" ), { letter | digit | "_" }; |
763 | ordinal = number | "?" | "?+"; | |
3a63dbef | 764 | version = number, "_", number, "_", number, [ letter, [ letter ] ]; |
91a99748 RL |
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 | ||
50ccc176 DDO |
775 | =item B<< source => FILENAME >>, B<< name => STRING >>, B<< number => NUMBER >>, |
776 | B<< version => STRING >>, B<< exists => BOOLEAN >>, B<< type => STRING >>, | |
3da95f3c | 777 | B<< platforms => HASHref >>, B<< features => LISTref >> |
15ba1096 RL |
778 | |
779 | This will create a new item with data coming from the arguments. | |
780 | ||
91a99748 RL |
781 | =back |
782 | ||
783 | =cut | |
784 | ||
785 | sub new { | |
786 | my $class = shift; | |
15ba1096 RL |
787 | |
788 | if (ref($_[0]) eq $class) { | |
789 | return $class->new( map { $_ => $_[0]->{$_} } keys %{$_[0]} ); | |
790 | } | |
791 | ||
91a99748 RL |
792 | my %opts = @_; |
793 | ||
15ba1096 RL |
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]*$/ | |
3da95f3c | 803 | && $a[1] =~ /^\d+|\?\+?$/ |
3a63dbef | 804 | && $a[2] =~ /^(?:\*|\d+_\d+_\d+[a-z]{0,2})$/ |
15ba1096 RL |
805 | && $a[3] =~ /^ |
806 | (?:NO)?EXIST: | |
807 | [^:]*: | |
808 | (?:FUNCTION|VARIABLE): | |
809 | [^:]* | |
810 | $ | |
811 | /x ); | |
812 | ||
813 | my @b = split /:/, $a[3]; | |
50ccc176 DDO |
814 | %opts = ( source => $opts{source}, |
815 | name => $a[0], | |
15ba1096 RL |
816 | number => $a[1], |
817 | version => $a[2], | |
818 | exists => $b[0] eq 'EXIST', | |
819 | platforms => { map { m|^(!)?|; $' => !$1 } | |
91a99748 | 820 | split /,/,$b[1] }, |
15ba1096 RL |
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') { | |
257ab867 RL |
828 | my $version = $opts{version}; |
829 | $version =~ s|_|.|g; | |
830 | ||
50ccc176 DDO |
831 | $instance = { source => $opts{source}, |
832 | name => $opts{name}, | |
15ba1096 RL |
833 | type => $opts{type}, |
834 | number => $opts{number}, | |
3da95f3c | 835 | intnum => $opts{intnum}, |
257ab867 | 836 | version => $version, |
15ba1096 RL |
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 | } | |
91a99748 RL |
844 | |
845 | return bless $instance, $class; | |
846 | } | |
847 | ||
848 | sub DESTROY { | |
849 | } | |
850 | ||
3da95f3c | 851 | =item B<< $item->name >> |
91a99748 RL |
852 | |
853 | The symbol name for this item. | |
854 | ||
3da95f3c | 855 | =item B<< $item->number >> (read-write) |
91a99748 RL |
856 | |
857 | The positional number for this item. | |
858 | ||
3da95f3c RL |
859 | This may be '?' for an unassigned symbol, or '?+' for an unassigned symbol |
860 | that's an alias for the previous symbol. '?' and '?+' must be properly | |
861 | handled by the caller. The caller may change this to an actual number. | |
862 | ||
863 | =item B<< $item->version >> (read-only) | |
91a99748 RL |
864 | |
865 | The version number for this item. Please note that these version numbers | |
3e6a0d57 | 866 | have underscore (C<_>) as a separator for the version parts. |
91a99748 | 867 | |
3da95f3c | 868 | =item B<< $item->exists >> (read-only) |
91a99748 RL |
869 | |
870 | A boolean that tells if this symbol exists in code or not. | |
871 | ||
3da95f3c | 872 | =item B<< $item->platforms >> (read-only) |
91a99748 RL |
873 | |
874 | A hash table reference. The keys of the hash table are the names of | |
875 | the specified platforms, with a value of 0 to indicate that this symbol | |
876 | isn't available on that platform, and 1 to indicate that it is. Platforms | |
877 | that aren't mentioned default to 1. | |
878 | ||
3da95f3c | 879 | =item B<< $item->type >> (read-only) |
91a99748 RL |
880 | |
881 | C<FUNCTION> or C<VARIABLE>, depending on what the symbol represents. | |
882 | Some platforms do not care about this, others do. | |
883 | ||
3da95f3c | 884 | =item B<< $item->features >> (read-only) |
91a99748 RL |
885 | |
886 | An array reference, where every item indicates a feature where this symbol | |
887 | is available. If no features are mentioned, the symbol is always available. | |
888 | If any feature is mentioned, this symbol is I<only> available when those | |
889 | features are enabled. | |
890 | ||
891 | =cut | |
892 | ||
893 | our $AUTOLOAD; | |
894 | ||
895 | # Generic getter | |
896 | sub 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 | ||
3da95f3c RL |
908 | =item B<< $item->intnum >> (read-write) |
909 | ||
910 | Internal positional number. If I<< $item->number >> is '?' or '?+', the | |
911 | caller can use this to set a number for its purposes. | |
912 | If I<< $item->number >> is a number, I<< $item->intnum >> should be the | |
913 | same | |
914 | ||
915 | =cut | |
916 | ||
917 | # Getter/setters | |
918 | sub 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 | ||
928 | sub 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 >> | |
91a99748 RL |
939 | |
940 | Converts the item to a string that can be saved in an ordinals file. | |
941 | ||
942 | =cut | |
943 | ||
944 | sub to_string { | |
945 | my $self = shift; | |
946 | ||
947 | croak "Too many arguments" if @_; | |
948 | my %platforms = $self->platforms(); | |
949 | my @features = $self->features(); | |
257ab867 RL |
950 | my $version = $self->version(); |
951 | $version =~ s|\.|_|g; | |
3da95f3c | 952 | return sprintf "%-39s %s\t%s\t%s:%s:%s:%s", |
91a99748 RL |
953 | $self->name(), |
954 | $self->number(), | |
257ab867 | 955 | $version, |
91a99748 RL |
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 | ||
3da95f3c | 967 | For the B<< $ordinals->items >> method, there are a few functions to create |
91a99748 RL |
968 | comparators based on specific data: |
969 | ||
970 | =over 4 | |
971 | ||
972 | =cut | |
973 | ||
974 | # Go back to the main package to create comparators and filters | |
975 | package OpenSSL::Ordinals; | |
976 | ||
977 | # Comparators... | |
978 | ||
979 | =item B<by_name> | |
980 | ||
981 | Returns a comparator that will compare the names of two OpenSSL::Ordinals::Item | |
982 | objects. | |
983 | ||
984 | =cut | |
985 | ||
986 | sub by_name { | |
987 | return sub { $_[0]->name() cmp $_[1]->name() }; | |
988 | } | |
989 | ||
990 | =item B<by_number> | |
991 | ||
992 | Returns a comparator that will compare the ordinal numbers of two | |
993 | OpenSSL::Ordinals::Item objects. | |
994 | ||
995 | =cut | |
996 | ||
997 | sub by_number { | |
3da95f3c | 998 | return sub { $_[0]->intnum() <=> $_[1]->intnum() }; |
91a99748 RL |
999 | } |
1000 | ||
1001 | =item B<by_version> | |
1002 | ||
1003 | Returns a comparator that will compare the version of two | |
1004 | OpenSSL::Ordinals::Item objects. | |
1005 | ||
1006 | =cut | |
1007 | ||
1008 | sub by_version { | |
91a99748 | 1009 | return sub { |
ad0b144b RL |
1010 | # cmp_versions comes from OpenSSL::Util |
1011 | return cmp_versions($_[0]->version(), $_[1]->version()); | |
1012 | } | |
91a99748 RL |
1013 | } |
1014 | ||
1015 | =back | |
1016 | ||
1017 | There 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 | ||
1028 | Returns a filter that only lets through symbols with a version number | |
1029 | matching B<VERSION>. | |
1030 | ||
1031 | =cut | |
1032 | ||
1033 | sub f_version { | |
1034 | my $version = shift; | |
1035 | ||
91a99748 | 1036 | croak "No version specified" |
257ab867 | 1037 | unless $version && $version =~ /^\d+\.\d+\.\d+[a-z]{0,2}$/; |
91a99748 RL |
1038 | |
1039 | return sub { $_[0]->version() eq $version }; | |
1040 | } | |
1041 | ||
15ba1096 RL |
1042 | =item B<f_number NUMBER> |
1043 | ||
1044 | Returns a filter that only lets through symbols with the ordinal number | |
1045 | matching B<NUMBER>. | |
1046 | ||
1047 | NOTE that this returns a "magic" value that can not be used as a function. | |
1048 | It's only useful when passed directly as a filter to B<items>. | |
1049 | ||
1050 | =cut | |
1051 | ||
1052 | sub 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 | ||
1064 | Returns a filter that only lets through symbols with the symbol name | |
1065 | matching B<NAME>. | |
1066 | ||
1067 | NOTE that this returns a "magic" value that can not be used as a function. | |
1068 | It's only useful when passed directly as a filter to B<items>. | |
1069 | ||
1070 | =cut | |
1071 | ||
1072 | sub f_name { | |
1073 | my $name = shift; | |
1074 | ||
1075 | croak "No name specified" | |
1076 | unless $name; | |
1077 | ||
1078 | return [ F_NAME, $name ]; | |
1079 | } | |
1080 | ||
91a99748 RL |
1081 | =back |
1082 | ||
1083 | =head1 AUTHORS | |
1084 | ||
1085 | Richard Levitte E<lt>levitte@openssl.orgE<gt>. | |
1086 | ||
1087 | =cut | |
1088 | ||
1089 | 1; |