| OLD | NEW |
| (Empty) |
| 1 # Copyright © 2007 Raphaël Hertzog <hertzog@debian.org> | |
| 2 # Copyright © 2009-2010 Modestas Vainius <modax@debian.org> | |
| 3 # | |
| 4 # This program is free software; you can redistribute it and/or modify | |
| 5 # it under the terms of the GNU General Public License as published by | |
| 6 # the Free Software Foundation; either version 2 of the License, or | |
| 7 # (at your option) any later version. | |
| 8 # | |
| 9 # This program is distributed in the hope that it will be useful, | |
| 10 # but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
| 12 # GNU General Public License for more details. | |
| 13 # | |
| 14 # You should have received a copy of the GNU General Public License | |
| 15 # along with this program. If not, see <https://www.gnu.org/licenses/>. | |
| 16 | |
| 17 package Dpkg::Shlibs::Symbol; | |
| 18 | |
| 19 use strict; | |
| 20 use warnings; | |
| 21 | |
| 22 our $VERSION = '0.01'; | |
| 23 | |
| 24 use Dpkg::Gettext; | |
| 25 use Dpkg::Deps; | |
| 26 use Dpkg::ErrorHandling; | |
| 27 use Dpkg::Util qw(:list); | |
| 28 use Dpkg::Version; | |
| 29 use Storable (); | |
| 30 use Dpkg::Shlibs::Cppfilt; | |
| 31 | |
| 32 # Supported alias types in the order of matching preference | |
| 33 use constant ALIAS_TYPES => qw(c++ symver); | |
| 34 | |
| 35 sub new { | |
| 36 my $this = shift; | |
| 37 my $class = ref($this) || $this; | |
| 38 my %args = @_; | |
| 39 my $self = bless { | |
| 40 symbol => undef, | |
| 41 symbol_templ => undef, | |
| 42 minver => undef, | |
| 43 dep_id => 0, | |
| 44 deprecated => 0, | |
| 45 tags => {}, | |
| 46 tagorder => [], | |
| 47 }, $class; | |
| 48 $self->{$_} = $args{$_} foreach keys %args; | |
| 49 return $self; | |
| 50 } | |
| 51 | |
| 52 # Deep clone | |
| 53 sub clone { | |
| 54 my $self = shift; | |
| 55 my $clone = Storable::dclone($self); | |
| 56 if (@_) { | |
| 57 my %args=@_; | |
| 58 $clone->{$_} = $args{$_} foreach keys %args; | |
| 59 } | |
| 60 return $clone; | |
| 61 } | |
| 62 | |
| 63 sub parse_tagspec { | |
| 64 my ($self, $tagspec) = @_; | |
| 65 | |
| 66 if ($tagspec =~ /^\s*\((.*?)\)(.*)$/ && $1) { | |
| 67 # (tag1=t1 value|tag2|...|tagN=tNp) | |
| 68 # Symbols ()|= cannot appear in the tag names and values | |
| 69 my $tagspec = $1; | |
| 70 my $rest = ($2) ? $2 : ''; | |
| 71 my @tags = split(/\|/, $tagspec); | |
| 72 | |
| 73 # Parse each tag | |
| 74 for my $tag (@tags) { | |
| 75 if ($tag =~ /^(.*)=(.*)$/) { | |
| 76 # Tag with value | |
| 77 $self->add_tag($1, $2); | |
| 78 } else { | |
| 79 # Tag without value | |
| 80 $self->add_tag($tag, undef); | |
| 81 } | |
| 82 } | |
| 83 return $rest; | |
| 84 } | |
| 85 return; | |
| 86 } | |
| 87 | |
| 88 sub parse_symbolspec { | |
| 89 my ($self, $symbolspec, %opts) = @_; | |
| 90 my $symbol; | |
| 91 my $symbol_templ; | |
| 92 my $symbol_quoted; | |
| 93 my $rest; | |
| 94 | |
| 95 if (defined($symbol = $self->parse_tagspec($symbolspec))) { | |
| 96 # (tag1=t1 value|tag2|...|tagN=tNp)"Foo::Bar::foobar()"@Base 1.0 1 | |
| 97 # Symbols ()|= cannot appear in the tag names and values | |
| 98 | |
| 99 # If the tag specification exists symbol name template might be quoted t
oo | |
| 100 if ($symbol =~ /^(['"])/ && $symbol =~ /^($1)(.*?)$1(.*)$/) { | |
| 101 $symbol_quoted = $1; | |
| 102 $symbol_templ = $2; | |
| 103 $symbol = $2; | |
| 104 $rest = $3; | |
| 105 } else { | |
| 106 if ($symbol =~ m/^(\S+)(.*)$/) { | |
| 107 $symbol_templ = $1; | |
| 108 $symbol = $1; | |
| 109 $rest = $2; | |
| 110 } | |
| 111 } | |
| 112 error(_g('symbol name unspecified: %s'), $symbolspec) if (!$symbol); | |
| 113 } else { | |
| 114 # No tag specification. Symbol name is up to the first space | |
| 115 # foobarsymbol@Base 1.0 1 | |
| 116 if ($symbolspec =~ m/^(\S+)(.*)$/) { | |
| 117 $symbol = $1; | |
| 118 $rest = $2; | |
| 119 } else { | |
| 120 return 0; | |
| 121 } | |
| 122 } | |
| 123 $self->{symbol} = $symbol; | |
| 124 $self->{symbol_templ} = $symbol_templ; | |
| 125 $self->{symbol_quoted} = $symbol_quoted if ($symbol_quoted); | |
| 126 | |
| 127 # Now parse "the rest" (minver and dep_id) | |
| 128 if ($rest =~ /^\s(\S+)(?:\s(\d+))?/) { | |
| 129 $self->{minver} = $1; | |
| 130 $self->{dep_id} = defined($2) ? $2 : 0; | |
| 131 } elsif (defined $opts{default_minver}) { | |
| 132 $self->{minver} = $opts{default_minver}; | |
| 133 $self->{dep_id} = 0; | |
| 134 } else { | |
| 135 return 0; | |
| 136 } | |
| 137 return 1; | |
| 138 } | |
| 139 | |
| 140 # A hook for symbol initialization (typically processing of tags). The code | |
| 141 # here may even change symbol name. Called from | |
| 142 # Dpkg::Shlibs::SymbolFile::create_symbol(). | |
| 143 sub initialize { | |
| 144 my $self = shift; | |
| 145 | |
| 146 # Look for tags marking symbol patterns. The pattern may match multiple | |
| 147 # real symbols. | |
| 148 my $type; | |
| 149 if ($self->has_tag('c++')) { | |
| 150 # Raw symbol name is always demangled to the same alias while demangled | |
| 151 # symbol name cannot be reliably converted back to raw symbol name. | |
| 152 # Therefore, we can use hash for mapping. | |
| 153 $type = 'alias-c++'; | |
| 154 } | |
| 155 | |
| 156 # Support old style wildcard syntax. That's basically a symver | |
| 157 # with an optional tag. | |
| 158 if ($self->get_symbolname() =~ /^\*@(.*)$/) { | |
| 159 $self->add_tag('symver') unless $self->has_tag('symver'); | |
| 160 $self->add_tag('optional') unless $self->has_tag('optional'); | |
| 161 $self->{symbol} = $1; | |
| 162 } | |
| 163 | |
| 164 if ($self->has_tag('symver')) { | |
| 165 # Each symbol is matched against its version rather than full | |
| 166 # name@version string. | |
| 167 $type = (defined $type) ? 'generic' : 'alias-symver'; | |
| 168 if ($self->get_symbolname() eq 'Base') { | |
| 169 error(_g("you can't use symver tag to catch unversioned symbols: %s"
), | |
| 170 $self->get_symbolspec(1)); | |
| 171 } | |
| 172 } | |
| 173 | |
| 174 # As soon as regex is involved, we need to match each real | |
| 175 # symbol against each pattern (aka 'generic' pattern). | |
| 176 if ($self->has_tag('regex')) { | |
| 177 $type = 'generic'; | |
| 178 # Pre-compile regular expression for better performance. | |
| 179 my $regex = $self->get_symbolname(); | |
| 180 $self->{pattern}{regex} = qr/$regex/; | |
| 181 } | |
| 182 if (defined $type) { | |
| 183 $self->init_pattern($type); | |
| 184 } | |
| 185 } | |
| 186 | |
| 187 sub get_symbolname { | |
| 188 return $_[0]->{symbol}; | |
| 189 } | |
| 190 | |
| 191 sub get_symboltempl { | |
| 192 return $_[0]->{symbol_templ} || $_[0]->{symbol}; | |
| 193 } | |
| 194 | |
| 195 sub set_symbolname { | |
| 196 my ($self, $name, $templ, $quoted) = @_; | |
| 197 unless (defined $name) { | |
| 198 $name = $self->{symbol}; | |
| 199 } | |
| 200 if (!defined $templ && $name =~ /\s/) { | |
| 201 $templ = $name; | |
| 202 } | |
| 203 if (!defined $quoted && defined $templ && $templ =~ /\s/) { | |
| 204 $quoted = '"'; | |
| 205 } | |
| 206 $self->{symbol} = $name; | |
| 207 $self->{symbol_templ} = $templ; | |
| 208 if ($quoted) { | |
| 209 $self->{symbol_quoted} = $quoted; | |
| 210 } else { | |
| 211 delete $self->{symbol_quoted}; | |
| 212 } | |
| 213 } | |
| 214 | |
| 215 sub has_tags { | |
| 216 my $self = shift; | |
| 217 return scalar (@{$self->{tagorder}}); | |
| 218 } | |
| 219 | |
| 220 sub add_tag { | |
| 221 my ($self, $tagname, $tagval) = @_; | |
| 222 if (exists $self->{tags}{$tagname}) { | |
| 223 $self->{tags}{$tagname} = $tagval; | |
| 224 return 0; | |
| 225 } else { | |
| 226 $self->{tags}{$tagname} = $tagval; | |
| 227 push @{$self->{tagorder}}, $tagname; | |
| 228 } | |
| 229 return 1; | |
| 230 } | |
| 231 | |
| 232 sub delete_tag { | |
| 233 my ($self, $tagname) = @_; | |
| 234 if (exists $self->{tags}{$tagname}) { | |
| 235 delete $self->{tags}{$tagname}; | |
| 236 $self->{tagorder} = [ grep { $_ ne $tagname } @{$self->{tagorder}} ]; | |
| 237 return 1; | |
| 238 } | |
| 239 return 0; | |
| 240 } | |
| 241 | |
| 242 sub has_tag { | |
| 243 my ($self, $tag) = @_; | |
| 244 return exists $self->{tags}{$tag}; | |
| 245 } | |
| 246 | |
| 247 sub get_tag_value { | |
| 248 my ($self, $tag) = @_; | |
| 249 return $self->{tags}{$tag}; | |
| 250 } | |
| 251 | |
| 252 # Checks if the symbol is equal to another one (by name and optionally, | |
| 253 # tag sets, versioning info (minver and depid)) | |
| 254 sub equals { | |
| 255 my ($self, $other, %opts) = @_; | |
| 256 $opts{versioning} = 1 unless exists $opts{versioning}; | |
| 257 $opts{tags} = 1 unless exists $opts{tags}; | |
| 258 | |
| 259 return 0 if $self->{symbol} ne $other->{symbol}; | |
| 260 | |
| 261 if ($opts{versioning}) { | |
| 262 return 0 if $self->{minver} ne $other->{minver}; | |
| 263 return 0 if $self->{dep_id} ne $other->{dep_id}; | |
| 264 } | |
| 265 | |
| 266 if ($opts{tags}) { | |
| 267 return 0 if scalar(@{$self->{tagorder}}) != scalar(@{$other->{tagorder}}
); | |
| 268 | |
| 269 for my $i (0 .. scalar(@{$self->{tagorder}}) - 1) { | |
| 270 my $tag = $self->{tagorder}->[$i]; | |
| 271 return 0 if $tag ne $other->{tagorder}->[$i]; | |
| 272 if (defined $self->{tags}{$tag} && defined $other->{tags}{$tag}) { | |
| 273 return 0 if $self->{tags}{$tag} ne $other->{tags}{$tag}; | |
| 274 } elsif (defined $self->{tags}{$tag} || defined $other->{tags}{$tag}
) { | |
| 275 return 0; | |
| 276 } | |
| 277 } | |
| 278 } | |
| 279 | |
| 280 return 1; | |
| 281 } | |
| 282 | |
| 283 | |
| 284 sub is_optional { | |
| 285 my $self = shift; | |
| 286 return $self->has_tag('optional'); | |
| 287 } | |
| 288 | |
| 289 sub is_arch_specific { | |
| 290 my $self = shift; | |
| 291 return $self->has_tag('arch'); | |
| 292 } | |
| 293 | |
| 294 sub arch_is_concerned { | |
| 295 my ($self, $arch) = @_; | |
| 296 my $arches = $self->{tags}{arch}; | |
| 297 | |
| 298 if (defined $arch && defined $arches) { | |
| 299 my $dep = Dpkg::Deps::Simple->new(); | |
| 300 my @arches = split(/[\s,]+/, $arches); | |
| 301 $dep->{package} = 'dummy'; | |
| 302 $dep->{arches} = \@arches; | |
| 303 return $dep->arch_is_concerned($arch); | |
| 304 } | |
| 305 | |
| 306 return 1; | |
| 307 } | |
| 308 | |
| 309 # Get reference to the pattern the symbol matches (if any) | |
| 310 sub get_pattern { | |
| 311 return $_[0]->{matching_pattern}; | |
| 312 } | |
| 313 | |
| 314 ### NOTE: subroutines below require (or initialize) $self to be a pattern ### | |
| 315 | |
| 316 # Initializes this symbol as a pattern of the specified type. | |
| 317 sub init_pattern { | |
| 318 my ($self, $type) = @_; | |
| 319 | |
| 320 $self->{pattern}{type} = $type; | |
| 321 # To be filled with references to symbols matching this pattern. | |
| 322 $self->{pattern}{matches} = []; | |
| 323 } | |
| 324 | |
| 325 # Is this symbol a pattern or not? | |
| 326 sub is_pattern { | |
| 327 return exists $_[0]->{pattern}; | |
| 328 } | |
| 329 | |
| 330 # Get pattern type if this symbol is a pattern. | |
| 331 sub get_pattern_type { | |
| 332 return $_[0]->{pattern}{type} || ''; | |
| 333 } | |
| 334 | |
| 335 # Get (sub)type of the alias pattern. Returns empty string if current | |
| 336 # pattern is not alias. | |
| 337 sub get_alias_type { | |
| 338 return ($_[0]->get_pattern_type() =~ /^alias-(.+)/ && $1) || ''; | |
| 339 } | |
| 340 | |
| 341 # Get a list of symbols matching this pattern if this symbol is a pattern | |
| 342 sub get_pattern_matches { | |
| 343 return @{$_[0]->{pattern}{matches}}; | |
| 344 } | |
| 345 | |
| 346 # Create a new symbol based on the pattern (i.e. $self) | |
| 347 # and add it to the pattern matches list. | |
| 348 sub create_pattern_match { | |
| 349 my $self = shift; | |
| 350 return unless $self->is_pattern(); | |
| 351 | |
| 352 # Leave out 'pattern' subfield while deep-cloning | |
| 353 my $pattern_stuff = $self->{pattern}; | |
| 354 delete $self->{pattern}; | |
| 355 my $newsym = $self->clone(@_); | |
| 356 $self->{pattern} = $pattern_stuff; | |
| 357 | |
| 358 # Clean up symbol name related internal fields | |
| 359 $newsym->set_symbolname(); | |
| 360 | |
| 361 # Set newsym pattern reference, add to pattern matches list | |
| 362 $newsym->{matching_pattern} = $self; | |
| 363 push @{$self->{pattern}{matches}}, $newsym; | |
| 364 return $newsym; | |
| 365 } | |
| 366 | |
| 367 ### END of pattern subroutines ### | |
| 368 | |
| 369 # Given a raw symbol name the call returns its alias according to the rules of | |
| 370 # the current pattern ($self). Returns undef if the supplied raw name is not | |
| 371 # transformable to alias. | |
| 372 sub convert_to_alias { | |
| 373 my ($self, $rawname, $type) = @_; | |
| 374 $type = $self->get_alias_type() unless $type; | |
| 375 | |
| 376 if ($type) { | |
| 377 if ($type eq 'symver') { | |
| 378 # In case of symver, alias is symbol version. Extract it from the | |
| 379 # rawname. | |
| 380 return "$1" if ($rawname =~ /\@([^@]+)$/); | |
| 381 } elsif ($rawname =~ /^_Z/ && $type eq 'c++') { | |
| 382 return cppfilt_demangle_cpp($rawname); | |
| 383 } | |
| 384 } | |
| 385 return; | |
| 386 } | |
| 387 | |
| 388 sub get_tagspec { | |
| 389 my ($self) = @_; | |
| 390 if ($self->has_tags()) { | |
| 391 my @tags; | |
| 392 for my $tagname (@{$self->{tagorder}}) { | |
| 393 my $tagval = $self->{tags}{$tagname}; | |
| 394 if (defined $tagval) { | |
| 395 push @tags, $tagname . '=' . $tagval; | |
| 396 } else { | |
| 397 push @tags, $tagname; | |
| 398 } | |
| 399 } | |
| 400 return '(' . join('|', @tags) . ')'; | |
| 401 } | |
| 402 return ''; | |
| 403 } | |
| 404 | |
| 405 sub get_symbolspec { | |
| 406 my $self = shift; | |
| 407 my $template_mode = shift; | |
| 408 my $spec = ''; | |
| 409 $spec .= "#MISSING: $self->{deprecated}#" if $self->{deprecated}; | |
| 410 $spec .= ' '; | |
| 411 if ($template_mode) { | |
| 412 if ($self->has_tags()) { | |
| 413 $spec .= sprintf('%s%3$s%s%3$s', $self->get_tagspec(), | |
| 414 $self->get_symboltempl(), $self->{symbol_quoted} || ''); | |
| 415 } else { | |
| 416 $spec .= $self->get_symboltempl(); | |
| 417 } | |
| 418 } else { | |
| 419 $spec .= $self->get_symbolname(); | |
| 420 } | |
| 421 $spec .= " $self->{minver}"; | |
| 422 $spec .= " $self->{dep_id}" if $self->{dep_id}; | |
| 423 return $spec; | |
| 424 } | |
| 425 | |
| 426 # Sanitize the symbol when it is confirmed to be found in | |
| 427 # the respective library. | |
| 428 sub mark_found_in_library { | |
| 429 my ($self, $minver, $arch) = @_; | |
| 430 | |
| 431 if ($self->{deprecated}) { | |
| 432 # Symbol reappeared somehow | |
| 433 $self->{deprecated} = 0; | |
| 434 $self->{minver} = $minver if (not $self->is_optional()); | |
| 435 } else { | |
| 436 # We assume that the right dependency information is already | |
| 437 # there. | |
| 438 if (version_compare($minver, $self->{minver}) < 0) { | |
| 439 $self->{minver} = $minver; | |
| 440 } | |
| 441 } | |
| 442 # Never remove arch tags from patterns | |
| 443 if (not $self->is_pattern()) { | |
| 444 if (not $self->arch_is_concerned($arch)) { | |
| 445 # Remove arch tag because it is incorrect. | |
| 446 $self->delete_tag('arch'); | |
| 447 } | |
| 448 } | |
| 449 } | |
| 450 | |
| 451 # Sanitize the symbol when it is confirmed to be NOT found in | |
| 452 # the respective library. | |
| 453 # Mark as deprecated those that are no more provided (only if the | |
| 454 # minver is later than the version where the symbol was introduced) | |
| 455 sub mark_not_found_in_library { | |
| 456 my ($self, $minver, $arch) = @_; | |
| 457 | |
| 458 # Ignore symbols from foreign arch | |
| 459 return if not $self->arch_is_concerned($arch); | |
| 460 | |
| 461 if ($self->{deprecated}) { | |
| 462 # Bump deprecated if the symbol is optional so that it | |
| 463 # keeps reappering in the diff while it's missing | |
| 464 $self->{deprecated} = $minver if $self->is_optional(); | |
| 465 } elsif (version_compare($minver, $self->{minver}) > 0) { | |
| 466 $self->{deprecated} = $minver; | |
| 467 } | |
| 468 } | |
| 469 | |
| 470 # Checks if the symbol (or pattern) is legitimate as a real symbol for the | |
| 471 # specified architecture. | |
| 472 sub is_legitimate { | |
| 473 my ($self, $arch) = @_; | |
| 474 return ! $self->{deprecated} && | |
| 475 $self->arch_is_concerned($arch); | |
| 476 } | |
| 477 | |
| 478 # Determine whether a supplied raw symbol name matches against current ($self) | |
| 479 # symbol or pattern. | |
| 480 sub matches_rawname { | |
| 481 my ($self, $rawname) = @_; | |
| 482 my $target = $rawname; | |
| 483 my $ok = 1; | |
| 484 my $do_eq_match = 1; | |
| 485 | |
| 486 if ($self->is_pattern()) { | |
| 487 # Process pattern tags in the order they were specified. | |
| 488 for my $tag (@{$self->{tagorder}}) { | |
| 489 if (any { $tag eq $_ } ALIAS_TYPES) { | |
| 490 $ok = not not ($target = $self->convert_to_alias($target, $tag))
; | |
| 491 } elsif ($tag eq 'regex') { | |
| 492 # Symbol name is a regex. Match it against the target | |
| 493 $do_eq_match = 0; | |
| 494 $ok = ($target =~ $self->{pattern}{regex}); | |
| 495 } | |
| 496 last if not $ok; | |
| 497 } | |
| 498 } | |
| 499 | |
| 500 # Equality match by default | |
| 501 if ($ok && $do_eq_match) { | |
| 502 $ok = $target eq $self->get_symbolname(); | |
| 503 } | |
| 504 return $ok; | |
| 505 } | |
| 506 | |
| 507 1; | |
| OLD | NEW |