File Coverage

blib/lib/Dpkg/Shlibs/Symbol.pm
Criterion Covered Total %
statement 243 258 94.1
branch 99 128 77.3
condition 45 69 65.2
subroutine 41 43 95.3
pod 0 31 0.0
total 428 529 80.9


line stmt bran cond sub pod time code
1             # Copyright © 2007 Raphaël Hertzog
2             # Copyright © 2009-2010 Modestas Vainius
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 .
16              
17             package Dpkg::Shlibs::Symbol;
18              
19 2     2   12 use strict;
  2         196  
  2         68  
20 2     2   12 use warnings;
  2         4  
  2         80  
21              
22             our $VERSION = '0.01';
23              
24 2     2   1674 use Storable ();
  2         7658  
  2         94  
25 2     2   22 use List::Util qw(any);
  2         146  
  2         214  
26              
27 2     2   20 use Dpkg::Gettext;
  2         4  
  2         108  
28 2     2   12 use Dpkg::ErrorHandling;
  2         2  
  2         136  
29 2     2   12 use Dpkg::Arch qw(debarch_is_concerned debarch_to_abiattrs);
  2         4  
  2         146  
30 2     2   16 use Dpkg::Version;
  2         4  
  2         138  
31 2     2   1680 use Dpkg::Shlibs::Cppfilt;
  2         10  
  2         112  
32              
33             # Supported alias types in the order of matching preference
34 2     2   14 use constant ALIAS_TYPES => qw(c++ symver);
  2         4  
  2         156  
35              
36             # Needed by the deprecated key, which is a correct use.
37 2         12 no if $Dpkg::Version::VERSION ge '1.02',
38 2     2   1614 warnings => qw(Dpkg::Version::semantic_change::overload::bool);
  2         28  
39              
40             sub new {
41 14271     14271 0 36357 my ($this, %args) = @_;
42 14271   33     38452 my $class = ref($this) || $this;
43 14271         72655 my $self = bless {
44             symbol => undef,
45             symbol_templ => undef,
46             minver => undef,
47             dep_id => 0,
48             deprecated => 0,
49             tags => {},
50             tagorder => [],
51             }, $class;
52 14271         49315 $self->{$_} = $args{$_} foreach keys %args;
53 14271         39236 return $self;
54             }
55              
56             # Deep clone
57             sub clone {
58 237     237 0 728 my ($self, %args) = @_;
59 237         13486 my $clone = Storable::dclone($self);
60 237         1197 $clone->{$_} = $args{$_} foreach keys %args;
61 237         677 return $clone;
62             }
63              
64             sub parse_tagspec {
65 5251     5251 0 8457 my ($self, $tagspec) = @_;
66              
67 5251 50 66     13904 if ($tagspec =~ /^\s*\((.*?)\)(.*)$/ && $1) {
68             # (tag1=t1 value|tag2|...|tagN=tNp)
69             # Symbols ()|= cannot appear in the tag names and values
70 233         503 my $tagspec = $1;
71 233 100       676 my $rest = ($2) ? $2 : '';
72 233         665 my @tags = split(/\|/, $tagspec);
73              
74             # Parse each tag
75 233         486 for my $tag (@tags) {
76 334 100       920 if ($tag =~ /^(.*)=(.*)$/) {
77             # Tag with value
78 174         402 $self->add_tag($1, $2);
79             } else {
80             # Tag without value
81 160         338 $self->add_tag($tag, undef);
82             }
83             }
84 233         836 return $rest;
85             }
86 5018         11072 return;
87             }
88              
89             sub parse_symbolspec {
90 5245     5245 0 8685 my ($self, $symbolspec, %opts) = @_;
91 5245         15402 my $symbol;
92             my $symbol_templ;
93 5245         0 my $symbol_quoted;
94 5245         0 my $rest;
95              
96 5245 100       9330 if (defined($symbol = $self->parse_tagspec($symbolspec))) {
97             # (tag1=t1 value|tag2|...|tagN=tNp)"Foo::Bar::foobar()"@Base 1.0 1
98             # Symbols ()|= cannot appear in the tag names and values
99              
100             # If the tag specification exists symbol name template might be quoted too
101 227 100 66     1645 if ($symbol =~ /^(['"])/ && $symbol =~ /^($1)(.*?)$1(.*)$/) {
102 59         200 $symbol_quoted = $1;
103 59         149 $symbol_templ = $2;
104 59         110 $symbol = $2;
105 59         125 $rest = $3;
106             } else {
107 168 50       614 if ($symbol =~ m/^(\S+)(.*)$/) {
108 168         390 $symbol_templ = $1;
109 168         276 $symbol = $1;
110 168         361 $rest = $2;
111             }
112             }
113 227 50       505 error(g_('symbol name unspecified: %s'), $symbolspec) if (!$symbol);
114             } else {
115             # No tag specification. Symbol name is up to the first space
116             # foobarsymbol@Base 1.0 1
117 5018 50       17549 if ($symbolspec =~ m/^(\S+)(.*)$/) {
118 5018         10033 $symbol = $1;
119 5018         8269 $rest = $2;
120             } else {
121 0         0 return 0;
122             }
123             }
124 5245         9811 $self->{symbol} = $symbol;
125 5245         7668 $self->{symbol_templ} = $symbol_templ;
126 5245 100       9544 $self->{symbol_quoted} = $symbol_quoted if ($symbol_quoted);
127              
128             # Now parse "the rest" (minver and dep_id)
129 5245 100       16108 if ($rest =~ /^\s(\S+)(?:\s(\d+))?/) {
    50          
130 5244         10758 $self->{minver} = $1;
131 5244   100     16557 $self->{dep_id} = $2 // 0;
132             } elsif (defined $opts{default_minver}) {
133 1         2 $self->{minver} = $opts{default_minver};
134 1         10 $self->{dep_id} = 0;
135             } else {
136 0         0 return 0;
137             }
138 5245         11333 return 1;
139             }
140              
141             # A hook for symbol initialization (typically processing of tags). The code
142             # here may even change symbol name. Called from
143             # Dpkg::Shlibs::SymbolFile::create_symbol().
144             sub initialize {
145 5245     5245 0 7770 my $self = shift;
146              
147             # Look for tags marking symbol patterns. The pattern may match multiple
148             # real symbols.
149 5245         6725 my $type;
150 5245 100       9867 if ($self->has_tag('c++')) {
151             # Raw symbol name is always demangled to the same alias while demangled
152             # symbol name cannot be reliably converted back to raw symbol name.
153             # Therefore, we can use hash for mapping.
154 71         123 $type = 'alias-c++';
155             }
156              
157             # Support old style wildcard syntax. That's basically a symver
158             # with an optional tag.
159 5245 100       10071 if ($self->get_symbolname() =~ /^\*@(.*)$/) {
160 3 50       13 $self->add_tag('symver') unless $self->has_tag('symver');
161 3 50       9 $self->add_tag('optional') unless $self->has_tag('optional');
162 3         14 $self->{symbol} = $1;
163             }
164              
165 5245 100       9165 if ($self->has_tag('symver')) {
166             # Each symbol is matched against its version rather than full
167             # name@version string.
168 27 100       169 $type = (defined $type) ? 'generic' : 'alias-symver';
169 27 50       95 if ($self->get_symbolname() eq 'Base') {
170 0         0 error(g_("you can't use symver tag to catch unversioned symbols: %s"),
171             $self->get_symbolspec(1));
172             }
173             }
174              
175             # As soon as regex is involved, we need to match each real
176             # symbol against each pattern (aka 'generic' pattern).
177 5245 100       8995 if ($self->has_tag('regex')) {
178 25         88 $type = 'generic';
179             # Pre-compile regular expression for better performance.
180 25         54 my $regex = $self->get_symbolname();
181 25         831 $self->{pattern}{regex} = qr/$regex/;
182             }
183 5245 100       13115 if (defined $type) {
184 86         215 $self->init_pattern($type);
185             }
186             }
187              
188             sub get_symbolname {
189 61691     61691 0 81929 my $self = shift;
190              
191 61691         176739 return $self->{symbol};
192             }
193              
194             sub get_symboltempl {
195 271550     271550 0 327668 my $self = shift;
196              
197 271550   66     644879 return $self->{symbol_templ} || $self->{symbol};
198             }
199              
200             sub set_symbolname {
201 195     195 0 420 my ($self, $name, $templ, $quoted) = @_;
202              
203 195   33     926 $name //= $self->{symbol};
204 195 50 33     858 if (!defined $templ && $name =~ /\s/) {
205 0         0 $templ = $name;
206             }
207 195 50 33     722 if (!defined $quoted && defined $templ && $templ =~ /\s/) {
      33        
208 0         0 $quoted = '"';
209             }
210 195         349 $self->{symbol} = $name;
211 195         316 $self->{symbol_templ} = $templ;
212 195 50       357 if ($quoted) {
213 0         0 $self->{symbol_quoted} = $quoted;
214             } else {
215 195         367 delete $self->{symbol_quoted};
216             }
217             }
218              
219             sub has_tags {
220 162     162 0 199 my $self = shift;
221 162         199 return scalar (@{$self->{tagorder}});
  162         339  
222             }
223              
224             sub add_tag {
225 340     340 0 966 my ($self, $tagname, $tagval) = @_;
226 340 100       830 if (exists $self->{tags}{$tagname}) {
227 6         30 $self->{tags}{$tagname} = $tagval;
228 6         26 return 0;
229             } else {
230 334         837 $self->{tags}{$tagname} = $tagval;
231 334         573 push @{$self->{tagorder}}, $tagname;
  334         797  
232             }
233 334         752 return 1;
234             }
235              
236             sub delete_tag {
237 6     6 0 76 my ($self, $tagname) = @_;
238 6 100       48 if (exists $self->{tags}{$tagname}) {
239 2         18 delete $self->{tags}{$tagname};
240 2         18 $self->{tagorder} = [ grep { $_ ne $tagname } @{$self->{tagorder}} ];
  2         16  
  2         20  
241 2         6 return 1;
242             }
243 4         20 return 0;
244             }
245              
246             sub has_tag {
247 25306     25306 0 39970 my ($self, $tag) = @_;
248 25306         78733 return exists $self->{tags}{$tag};
249             }
250              
251             sub get_tag_value {
252 0     0 0 0 my ($self, $tag) = @_;
253 0         0 return $self->{tags}{$tag};
254             }
255              
256             # Checks if the symbol is equal to another one (by name and optionally,
257             # tag sets, versioning info (minver and depid))
258             sub equals {
259 116     116 0 265 my ($self, $other, %opts) = @_;
260 116   100     225 $opts{versioning} //= 1;
261 116   50     417 $opts{tags} //= 1;
262              
263 116 100       427 return 0 if $self->{symbol} ne $other->{symbol};
264              
265 48 100       109 if ($opts{versioning}) {
266 1 50       15 return 0 if $self->{minver} ne $other->{minver};
267 1 50       7 return 0 if $self->{dep_id} ne $other->{dep_id};
268             }
269              
270 48 50       121 if ($opts{tags}) {
271 48 50       89 return 0 if scalar(@{$self->{tagorder}}) != scalar(@{$other->{tagorder}});
  48         85  
  48         122  
272              
273 48         81 for my $i (0 .. scalar(@{$self->{tagorder}}) - 1) {
  48         133  
274 99         170 my $tag = $self->{tagorder}->[$i];
275 99 50       214 return 0 if $tag ne $other->{tagorder}->[$i];
276 99 50 33     520 if (defined $self->{tags}{$tag} && defined $other->{tags}{$tag}) {
    50 33        
277 0 0       0 return 0 if $self->{tags}{$tag} ne $other->{tags}{$tag};
278             } elsif (defined $self->{tags}{$tag} || defined $other->{tags}{$tag}) {
279 0         0 return 0;
280             }
281             }
282             }
283              
284 48         184 return 1;
285             }
286              
287              
288             sub is_optional {
289 9541     9541 0 13195 my $self = shift;
290 9541         15363 return $self->has_tag('optional');
291             }
292              
293             sub is_arch_specific {
294 0     0 0 0 my $self = shift;
295 0         0 return $self->has_tag('arch');
296             }
297              
298             sub arch_is_concerned {
299 41423     41423 0 67306 my ($self, $arch) = @_;
300 41423         64359 my $arches = $self->{tags}{arch};
301              
302 41423 100 66     124710 return 0 if defined $arch && defined $arches &&
      100        
303             !debarch_is_concerned($arch, split /[\s,]+/, $arches);
304              
305 41321         85049 my ($bits, $endian) = debarch_to_abiattrs($arch);
306             return 0 if defined $bits && defined $self->{tags}{'arch-bits'} &&
307 41321 100 66     144151 $bits ne $self->{tags}{'arch-bits'};
      100        
308             return 0 if defined $endian && defined $self->{tags}{'arch-endian'} &&
309 41279 100 66     126362 $endian ne $self->{tags}{'arch-endian'};
      100        
310              
311 41241         139521 return 1;
312             }
313              
314             # Get reference to the pattern the symbol matches (if any)
315             sub get_pattern {
316 626     626 0 2081 my $self = shift;
317              
318 626         2151 return $self->{matching_pattern};
319             }
320              
321             ### NOTE: subroutines below require (or initialize) $self to be a pattern ###
322              
323             # Initializes this symbol as a pattern of the specified type.
324             sub init_pattern {
325 86     86 0 173 my ($self, $type) = @_;
326              
327 86         324 $self->{pattern}{type} = $type;
328             # To be filled with references to symbols matching this pattern.
329 86         328 $self->{pattern}{matches} = [];
330             }
331              
332             # Is this symbol a pattern or not?
333             sub is_pattern {
334 24008     24008 0 34536 my $self = shift;
335              
336 24008         59729 return exists $self->{pattern};
337             }
338              
339             # Get pattern type if this symbol is a pattern.
340             sub get_pattern_type {
341 760     760 0 1045 my $self = shift;
342              
343 760   50     7405 return $self->{pattern}{type} // '';
344             }
345              
346             # Get (sub)type of the alias pattern. Returns empty string if current
347             # pattern is not alias.
348             sub get_alias_type {
349 713     713 0 1164 my $self = shift;
350              
351 713   100     1393 return ($self->get_pattern_type() =~ /^alias-(.+)/ && $1) || '';
352             }
353              
354             # Get a list of symbols matching this pattern if this symbol is a pattern
355             sub get_pattern_matches {
356 53     53 0 950 my $self = shift;
357              
358 53         69 return @{$self->{pattern}{matches}};
  53         1601  
359             }
360              
361             # Create a new symbol based on the pattern (i.e. $self)
362             # and add it to the pattern matches list.
363             sub create_pattern_match {
364 195     195 0 293 my $self = shift;
365 195 50       349 return unless $self->is_pattern();
366              
367             # Leave out 'pattern' subfield while deep-cloning
368 195         388 my $pattern_stuff = $self->{pattern};
369 195         469 delete $self->{pattern};
370 195         618 my $newsym = $self->clone(@_);
371 195         444 $self->{pattern} = $pattern_stuff;
372              
373             # Clean up symbol name related internal fields
374 195         538 $newsym->set_symbolname();
375              
376             # Set newsym pattern reference, add to pattern matches list
377 195         573 $newsym->{matching_pattern} = $self;
378 195         297 push @{$self->{pattern}{matches}}, $newsym;
  195         535  
379 195         603 return $newsym;
380             }
381              
382             ### END of pattern subroutines ###
383              
384             # Given a raw symbol name the call returns its alias according to the rules of
385             # the current pattern ($self). Returns undef if the supplied raw name is not
386             # transformable to alias.
387             sub convert_to_alias {
388 896     896 0 1867 my ($self, $rawname, $type) = @_;
389 896 100       2161 $type = $self->get_alias_type() unless $type;
390              
391 896 50       1836 if ($type) {
392 896 100 33     3303 if ($type eq 'symver') {
    50          
393             # In case of symver, alias is symbol version. Extract it from the
394             # rawname.
395 445 50       2908 return "$1" if ($rawname =~ /\@([^@]+)$/);
396             } elsif ($rawname =~ /^_Z/ && $type eq 'c++') {
397 451         1387 return cppfilt_demangle_cpp($rawname);
398             }
399             }
400 0         0 return;
401             }
402              
403             sub get_tagspec {
404 40     40 0 54 my $self = shift;
405 40 50       76 if ($self->has_tags()) {
406 40         50 my @tags;
407 40         67 for my $tagname (@{$self->{tagorder}}) {
  40         86  
408 56         110 my $tagval = $self->{tags}{$tagname};
409 56 100       119 if (defined $tagval) {
410 28         72 push @tags, $tagname . '=' . $tagval;
411             } else {
412 28         87 push @tags, $tagname;
413             }
414             }
415 40         196 return '(' . join('|', @tags) . ')';
416             }
417 0         0 return '';
418             }
419              
420             sub get_symbolspec {
421 13900     13900 0 20643 my $self = shift;
422 13900         17001 my $template_mode = shift;
423 13900         17428 my $spec = '';
424 13900 100       25705 $spec .= "#MISSING: $self->{deprecated}#" if $self->{deprecated};
425 13900         22121 $spec .= ' ';
426 13900 100       22242 if ($template_mode) {
427 122 100       248 if ($self->has_tags()) {
428             $spec .= sprintf('%s%3$s%s%3$s', $self->get_tagspec(),
429 40   100     95 $self->get_symboltempl(), $self->{symbol_quoted} // '');
430             } else {
431 82         148 $spec .= $self->get_symboltempl();
432             }
433             } else {
434 13778         22376 $spec .= $self->get_symbolname();
435             }
436 13900         29265 $spec .= " $self->{minver}";
437 13900 100       24807 $spec .= " $self->{dep_id}" if $self->{dep_id};
438 13900         32386 return $spec;
439             }
440              
441             # Sanitize the symbol when it is confirmed to be found in
442             # the respective library.
443             sub mark_found_in_library {
444 9025     9025 0 16597 my ($self, $minver, $arch) = @_;
445              
446 9025 100       20915 if ($self->{deprecated}) {
447             # Symbol reappeared somehow
448 3         25 $self->{deprecated} = 0;
449 3 100       38 $self->{minver} = $minver if (not $self->is_optional());
450             } else {
451             # We assume that the right dependency information is already
452             # there.
453 9022 50       21914 if (version_compare($minver, $self->{minver}) < 0) {
454 0         0 $self->{minver} = $minver;
455             }
456             }
457             # Never remove arch tags from patterns
458 9025 100       20271 if (not $self->is_pattern()) {
459 8830 100       18197 if (not $self->arch_is_concerned($arch)) {
460             # Remove arch tags because they are incorrect.
461 2         28 $self->delete_tag('arch');
462 2         28 $self->delete_tag('arch-bits');
463 2         32 $self->delete_tag('arch-endian');
464             }
465             }
466             }
467              
468             # Sanitize the symbol when it is confirmed to be NOT found in
469             # the respective library.
470             # Mark as deprecated those that are no more provided (only if the
471             # minver is later than the version where the symbol was introduced)
472             sub mark_not_found_in_library {
473 170     170 0 339 my ($self, $minver, $arch) = @_;
474              
475             # Ignore symbols from foreign arch
476 170 100       333 return if not $self->arch_is_concerned($arch);
477              
478 114 100       420 if ($self->{deprecated}) {
    50          
479             # Bump deprecated if the symbol is optional so that it
480             # keeps reappearing in the diff while it's missing
481 2 50       36 $self->{deprecated} = $minver if $self->is_optional();
482             } elsif (version_compare($minver, $self->{minver}) > 0) {
483 112         533 $self->{deprecated} = $minver;
484             }
485             }
486              
487             # Checks if the symbol (or pattern) is legitimate as a real symbol for the
488             # specified architecture.
489             sub is_legitimate {
490 18318     18318 0 28637 my ($self, $arch) = @_;
491             return ! $self->{deprecated} &&
492 18318   100     50372 $self->arch_is_concerned($arch);
493             }
494              
495             # Determine whether a supplied raw symbol name matches against current ($self)
496             # symbol or pattern.
497             sub matches_rawname {
498 267     267 0 580 my ($self, $rawname) = @_;
499 267         410 my $target = $rawname;
500 267         405 my $ok = 1;
501 267         392 my $do_eq_match = 1;
502              
503 267 50       561 if ($self->is_pattern()) {
504             # Process pattern tags in the order they were specified.
505 267         378 for my $tag (@{$self->{tagorder}}) {
  267         603  
506 573 100   879   2295 if (any { $tag eq $_ } ALIAS_TYPES) {
  879 100       1834  
507 351         743 $ok = not not ($target = $self->convert_to_alias($target, $tag));
508             } elsif ($tag eq 'regex') {
509             # Symbol name is a regex. Match it against the target
510 183         273 $do_eq_match = 0;
511 183         1641 $ok = ($target =~ $self->{pattern}{regex});
512             }
513 573 100       1922 last if not $ok;
514             }
515             }
516              
517             # Equality match by default
518 267 100 100     893 if ($ok && $do_eq_match) {
519 84         181 $ok = $target eq $self->get_symbolname();
520             }
521 267         1162 return $ok;
522             }
523              
524             1;