summaryrefslogtreecommitdiffstats
path: root/scripts/Dpkg/Shlibs
diff options
context:
space:
mode:
authorDaniel Baumann <daniel.baumann@progress-linux.org>2024-05-06 00:45:20 +0000
committerDaniel Baumann <daniel.baumann@progress-linux.org>2024-05-06 00:45:20 +0000
commit9a08cbfcc1ef900a04580f35afe2a4592d7d6030 (patch)
tree004cc7027bca2f2c0bcb5806527c8e0c48df2d6e /scripts/Dpkg/Shlibs
parentInitial commit. (diff)
downloaddpkg-upstream.tar.xz
dpkg-upstream.zip
Adding upstream version 1.19.8.upstream/1.19.8upstream
Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>
Diffstat (limited to 'scripts/Dpkg/Shlibs')
-rw-r--r--scripts/Dpkg/Shlibs/Cppfilt.pm116
-rw-r--r--scripts/Dpkg/Shlibs/Objdump.pm555
-rw-r--r--scripts/Dpkg/Shlibs/Symbol.pm524
-rw-r--r--scripts/Dpkg/Shlibs/SymbolFile.pm678
4 files changed, 1873 insertions, 0 deletions
diff --git a/scripts/Dpkg/Shlibs/Cppfilt.pm b/scripts/Dpkg/Shlibs/Cppfilt.pm
new file mode 100644
index 0000000..d5a8bb2
--- /dev/null
+++ b/scripts/Dpkg/Shlibs/Cppfilt.pm
@@ -0,0 +1,116 @@
+# Copyright © 2009-2010 Modestas Vainius <modax@debian.org>
+# Copyright © 2010, 2012-2015 Guillem Jover <guillem@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+package Dpkg::Shlibs::Cppfilt;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+our @EXPORT = qw(
+ cppfilt_demangle_cpp
+);
+our @EXPORT_OK = qw(
+ cppfilt_demangle
+);
+
+use Exporter qw(import);
+
+use Dpkg::ErrorHandling;
+use Dpkg::IPC;
+
+# A hash of 'objects' referring to preforked c++filt processes for the distinct
+# demangling types.
+my %cppfilts;
+
+sub get_cppfilt {
+ my $type = shift || 'auto';
+
+ # Fork c++filt process for demangling $type unless it is forked already.
+ # Keeping c++filt running improves performance a lot.
+ my $filt;
+ if (exists $cppfilts{$type}) {
+ $filt = $cppfilts{$type};
+ } else {
+ $filt = { from => undef, to => undef,
+ last_symbol => '', last_result => '' };
+ $filt->{pid} = spawn(exec => [ 'c++filt', "--format=$type" ],
+ from_pipe => \$filt->{from},
+ to_pipe => \$filt->{to});
+ syserr(g_('unable to execute %s'), 'c++filt')
+ unless defined $filt->{from};
+ $filt->{from}->autoflush(1);
+
+ $cppfilts{$type} = $filt;
+ }
+ return $filt;
+}
+
+# Demangle the given $symbol using demangler for the specified $type (defaults
+# to 'auto') . Extraneous characters trailing after a mangled name are kept
+# intact. If neither whole $symbol nor portion of it could be demangled, undef
+# is returned.
+sub cppfilt_demangle {
+ my ($symbol, $type) = @_;
+
+ # Start or get c++filt 'object' for the requested type.
+ my $filt = get_cppfilt($type);
+
+ # Remember the last result. Such a local optimization is cheap and useful
+ # when sequential pattern matching is performed.
+ if ($filt->{last_symbol} ne $symbol) {
+ # This write/read operation should not deadlock because c++filt flushes
+ # output buffer on LF or each invalid character.
+ print { $filt->{from} } $symbol, "\n";
+ my $demangled = readline($filt->{to});
+ chop $demangled;
+
+ # If the symbol was not demangled, return undef
+ $demangled = undef if $symbol eq $demangled;
+
+ # Remember the last result
+ $filt->{last_symbol} = $symbol;
+ $filt->{last_result} = $demangled;
+ }
+ return $filt->{last_result};
+}
+
+sub cppfilt_demangle_cpp {
+ my $symbol = shift;
+ return cppfilt_demangle($symbol, 'auto');
+}
+
+sub terminate_cppfilts {
+ foreach my $type (keys %cppfilts) {
+ next if not defined $cppfilts{$type}{pid};
+ close $cppfilts{$type}{from};
+ close $cppfilts{$type}{to};
+ wait_child($cppfilts{$type}{pid}, cmdline => 'c++filt',
+ nocheck => 1,
+ timeout => 5);
+ delete $cppfilts{$type};
+ }
+}
+
+# Close/terminate running c++filt process(es)
+END {
+ # Make sure exitcode is not changed (by wait_child)
+ my $exitcode = $?;
+ terminate_cppfilts();
+ $? = $exitcode;
+}
+
+1;
diff --git a/scripts/Dpkg/Shlibs/Objdump.pm b/scripts/Dpkg/Shlibs/Objdump.pm
new file mode 100644
index 0000000..4cee866
--- /dev/null
+++ b/scripts/Dpkg/Shlibs/Objdump.pm
@@ -0,0 +1,555 @@
+# Copyright © 2007-2010 Raphaël Hertzog <hertzog@debian.org>
+# Copyright © 2007-2009,2012-2015,2017-2018 Guillem Jover <guillem@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+package Dpkg::Shlibs::Objdump;
+
+use strict;
+use warnings;
+use feature qw(state);
+
+our $VERSION = '0.01';
+
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling;
+
+sub new {
+ my $this = shift;
+ my $class = ref($this) || $this;
+ my $self = { objects => {} };
+ bless $self, $class;
+ return $self;
+}
+
+sub add_object {
+ my ($self, $obj) = @_;
+ my $id = $obj->get_id;
+ if ($id) {
+ $self->{objects}{$id} = $obj;
+ }
+ return $id;
+}
+
+sub analyze {
+ my ($self, $file) = @_;
+ my $obj = Dpkg::Shlibs::Objdump::Object->new($file);
+
+ return $self->add_object($obj);
+}
+
+sub locate_symbol {
+ my ($self, $name) = @_;
+ foreach my $obj (values %{$self->{objects}}) {
+ my $sym = $obj->get_symbol($name);
+ if (defined($sym) && $sym->{defined}) {
+ return $sym;
+ }
+ }
+ return;
+}
+
+sub get_object {
+ my ($self, $objid) = @_;
+ if ($self->has_object($objid)) {
+ return $self->{objects}{$objid};
+ }
+ return;
+}
+
+sub has_object {
+ my ($self, $objid) = @_;
+ return exists $self->{objects}{$objid};
+}
+
+use constant {
+ ELF_BITS_NONE => 0,
+ ELF_BITS_32 => 1,
+ ELF_BITS_64 => 2,
+
+ ELF_ORDER_NONE => 0,
+ ELF_ORDER_2LSB => 1,
+ ELF_ORDER_2MSB => 2,
+
+ ELF_MACH_SPARC => 2,
+ ELF_MACH_MIPS => 8,
+ ELF_MACH_SPARC64_OLD => 11,
+ ELF_MACH_SPARC32PLUS => 18,
+ ELF_MACH_PPC64 => 21,
+ ELF_MACH_S390 => 22,
+ ELF_MACH_ARM => 40,
+ ELF_MACH_ALPHA_OLD => 41,
+ ELF_MACH_SH => 42,
+ ELF_MACH_SPARC64 => 43,
+ ELF_MACH_IA64 => 50,
+ ELF_MACH_AVR => 83,
+ ELF_MACH_M32R => 88,
+ ELF_MACH_MN10300 => 89,
+ ELF_MACH_MN10200 => 90,
+ ELF_MACH_OR1K => 92,
+ ELF_MACH_XTENSA => 94,
+ ELF_MACH_MICROBLAZE => 189,
+ ELF_MACH_AVR_OLD => 0x1057,
+ ELF_MACH_OR1K_OLD => 0x8472,
+ ELF_MACH_ALPHA => 0x9026,
+ ELF_MACH_M32R_CYGNUS => 0x9041,
+ ELF_MACH_S390_OLD => 0xa390,
+ ELF_MACH_XTENSA_OLD => 0xabc7,
+ ELF_MACH_MICROBLAZE_OLD => 0xbaab,
+ ELF_MACH_MN10300_CYGNUS => 0xbeef,
+ ELF_MACH_MN10200_CYGNUS => 0xdead,
+
+ ELF_VERSION_NONE => 0,
+ ELF_VERSION_CURRENT => 1,
+
+ # List of processor flags that might influence the ABI.
+
+ ELF_FLAG_ARM_ALIGN8 => 0x00000040,
+ ELF_FLAG_ARM_NEW_ABI => 0x00000080,
+ ELF_FLAG_ARM_OLD_ABI => 0x00000100,
+ ELF_FLAG_ARM_SOFT_FLOAT => 0x00000200,
+ ELF_FLAG_ARM_HARD_FLOAT => 0x00000400,
+ ELF_FLAG_ARM_EABI_MASK => 0xff000000,
+
+ ELF_FLAG_IA64_ABI64 => 0x00000010,
+
+ ELF_FLAG_MIPS_ABI2 => 0x00000020,
+ ELF_FLAG_MIPS_32BIT => 0x00000100,
+ ELF_FLAG_MIPS_FP64 => 0x00000200,
+ ELF_FLAG_MIPS_NAN2008 => 0x00000400,
+ ELF_FLAG_MIPS_ABI_MASK => 0x0000f000,
+ ELF_FLAG_MIPS_ARCH_MASK => 0xf0000000,
+
+ ELF_FLAG_PPC64_ABI64 => 0x00000003,
+
+ ELF_FLAG_SH_MACH_MASK => 0x0000001f,
+};
+
+# These map alternative or old machine IDs to their canonical form.
+my %elf_mach_map = (
+ ELF_MACH_ALPHA_OLD() => ELF_MACH_ALPHA,
+ ELF_MACH_AVR_OLD() => ELF_MACH_AVR,
+ ELF_MACH_M32R_CYGNUS() => ELF_MACH_M32R,
+ ELF_MACH_MICROBLAZE_OLD() => ELF_MACH_MICROBLAZE,
+ ELF_MACH_MN10200_CYGNUS() => ELF_MACH_MN10200,
+ ELF_MACH_MN10300_CYGNUS() => ELF_MACH_MN10300,
+ ELF_MACH_OR1K_OLD() => ELF_MACH_OR1K,
+ ELF_MACH_S390_OLD() => ELF_MACH_S390,
+ ELF_MACH_SPARC32PLUS() => ELF_MACH_SPARC,
+ ELF_MACH_SPARC64_OLD() => ELF_MACH_SPARC64,
+ ELF_MACH_XTENSA_OLD() => ELF_MACH_XTENSA,
+);
+
+# These masks will try to expose processor flags that are ABI incompatible,
+# and as such are part of defining the architecture ABI. If uncertain it is
+# always better to not mask a flag, because that preserves the historical
+# behavior, and we do not drop dependencies.
+my %elf_flags_mask = (
+ ELF_MACH_IA64() => ELF_FLAG_IA64_ABI64,
+ ELF_MACH_MIPS() => ELF_FLAG_MIPS_ABI_MASK | ELF_FLAG_MIPS_ABI2,
+ ELF_MACH_PPC64() => ELF_FLAG_PPC64_ABI64,
+);
+
+sub get_format {
+ my ($file) = @_;
+ state %format;
+
+ return $format{$file} if exists $format{$file};
+
+ my $header;
+
+ open my $fh, '<', $file or syserr(g_('cannot read %s'), $file);
+ my $rc = read $fh, $header, 64;
+ if (not defined $rc) {
+ syserr(g_('cannot read %s'), $file);
+ } elsif ($rc != 64) {
+ return;
+ }
+ close $fh;
+
+ my %elf;
+
+ # Unpack the identifier field.
+ @elf{qw(magic bits endian vertype osabi verabi)} = unpack 'a4C5', $header;
+
+ return unless $elf{magic} eq "\x7fELF";
+ return unless $elf{vertype} == ELF_VERSION_CURRENT;
+
+ my ($elf_word, $elf_endian);
+ if ($elf{bits} == ELF_BITS_32) {
+ $elf_word = 'L';
+ } elsif ($elf{bits} == ELF_BITS_64) {
+ $elf_word = 'Q';
+ } else {
+ return;
+ }
+ if ($elf{endian} == ELF_ORDER_2LSB) {
+ $elf_endian = '<';
+ } elsif ($elf{endian} == ELF_ORDER_2MSB) {
+ $elf_endian = '>';
+ } else {
+ return;
+ }
+
+ # Unpack the endianness and size dependent fields.
+ my $tmpl = "x16(S2Lx[${elf_word}3]L)${elf_endian}";
+ @elf{qw(type mach version flags)} = unpack $tmpl, $header;
+
+ # Canonicalize the machine ID.
+ $elf{mach} = $elf_mach_map{$elf{mach}} // $elf{mach};
+
+ # Mask any processor flags that might not change the architecture ABI.
+ $elf{flags} &= $elf_flags_mask{$elf{mach}} // 0;
+
+ # Repack for easy comparison, as a big-endian byte stream, so that
+ # unpacking for output gives meaningful results.
+ $format{$file} = pack 'C2(SL)>', @elf{qw(bits endian mach flags)};
+
+ return $format{$file};
+}
+
+sub is_elf {
+ my $file = shift;
+ open(my $file_fh, '<', $file) or syserr(g_('cannot read %s'), $file);
+ my ($header, $result) = ('', 0);
+ if (read($file_fh, $header, 4) == 4) {
+ $result = 1 if ($header =~ /^\177ELF$/);
+ }
+ close($file_fh);
+ return $result;
+}
+
+package Dpkg::Shlibs::Objdump::Object;
+
+use strict;
+use warnings;
+use feature qw(state);
+
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling;
+use Dpkg::Path qw(find_command);
+use Dpkg::Arch qw(debarch_to_gnutriplet get_build_arch get_host_arch);
+
+sub new {
+ my $this = shift;
+ my $file = shift // '';
+ my $class = ref($this) || $this;
+ my $self = {};
+ bless $self, $class;
+
+ $self->reset;
+ if ($file) {
+ $self->analyze($file);
+ }
+
+ return $self;
+}
+
+sub reset {
+ my $self = shift;
+
+ $self->{file} = '';
+ $self->{id} = '';
+ $self->{HASH} = '';
+ $self->{GNU_HASH} = '';
+ $self->{INTERP} = 0;
+ $self->{SONAME} = '';
+ $self->{NEEDED} = [];
+ $self->{RPATH} = [];
+ $self->{dynsyms} = {};
+ $self->{flags} = {};
+ $self->{dynrelocs} = {};
+
+ return $self;
+}
+
+sub _select_objdump {
+ # Decide which objdump to call
+ if (get_build_arch() ne get_host_arch()) {
+ my $od = debarch_to_gnutriplet(get_host_arch()) . '-objdump';
+ return $od if find_command($od);
+ }
+ return 'objdump';
+}
+
+sub analyze {
+ my ($self, $file) = @_;
+
+ $file ||= $self->{file};
+ return unless $file;
+
+ $self->reset;
+ $self->{file} = $file;
+
+ $self->{exec_abi} = Dpkg::Shlibs::Objdump::get_format($file);
+
+ if (not defined $self->{exec_abi}) {
+ warning(g_("unknown executable format in file '%s'"), $file);
+ return;
+ }
+
+ state $OBJDUMP = _select_objdump();
+ local $ENV{LC_ALL} = 'C';
+ open(my $objdump, '-|', $OBJDUMP, '-w', '-f', '-p', '-T', '-R', $file)
+ or syserr(g_('cannot fork for %s'), $OBJDUMP);
+ my $ret = $self->parse_objdump_output($objdump);
+ close($objdump);
+ return $ret;
+}
+
+sub parse_objdump_output {
+ my ($self, $fh) = @_;
+
+ my $section = 'none';
+ while (<$fh>) {
+ s/\s*$//;
+ next if length == 0;
+
+ if (/^DYNAMIC SYMBOL TABLE:/) {
+ $section = 'dynsym';
+ next;
+ } elsif (/^DYNAMIC RELOCATION RECORDS/) {
+ $section = 'dynreloc';
+ $_ = <$fh>; # Skip header
+ next;
+ } elsif (/^Dynamic Section:/) {
+ $section = 'dyninfo';
+ next;
+ } elsif (/^Program Header:/) {
+ $section = 'program';
+ next;
+ } elsif (/^Version definitions:/) {
+ $section = 'verdef';
+ next;
+ } elsif (/^Version References:/) {
+ $section = 'verref';
+ next;
+ }
+
+ if ($section eq 'dynsym') {
+ $self->parse_dynamic_symbol($_);
+ } elsif ($section eq 'dynreloc') {
+ if (/^\S+\s+(\S+)\s+(.+)$/) {
+ $self->{dynrelocs}{$2} = $1;
+ } else {
+ warning(g_("couldn't parse dynamic relocation record: %s"), $_);
+ }
+ } elsif ($section eq 'dyninfo') {
+ if (/^\s*NEEDED\s+(\S+)/) {
+ push @{$self->{NEEDED}}, $1;
+ } elsif (/^\s*SONAME\s+(\S+)/) {
+ $self->{SONAME} = $1;
+ } elsif (/^\s*HASH\s+(\S+)/) {
+ $self->{HASH} = $1;
+ } elsif (/^\s*GNU_HASH\s+(\S+)/) {
+ $self->{GNU_HASH} = $1;
+ } elsif (/^\s*RUNPATH\s+(\S+)/) {
+ # RUNPATH takes precedence over RPATH but is
+ # considered after LD_LIBRARY_PATH while RPATH
+ # is considered before (if RUNPATH is not set).
+ my $runpath = $1;
+ $self->{RPATH} = [ split /:/, $runpath ];
+ } elsif (/^\s*RPATH\s+(\S+)/) {
+ my $rpath = $1;
+ unless (scalar(@{$self->{RPATH}})) {
+ $self->{RPATH} = [ split /:/, $rpath ];
+ }
+ }
+ } elsif ($section eq 'program') {
+ if (/^\s*INTERP\s+/) {
+ $self->{INTERP} = 1;
+ }
+ } elsif ($section eq 'none') {
+ if (/^\s*.+:\s*file\s+format\s+(\S+)$/) {
+ $self->{format} = $1;
+ } elsif (/^architecture:\s*\S+,\s*flags\s*\S+:$/) {
+ # Parse 2 lines of "-f"
+ # architecture: i386, flags 0x00000112:
+ # EXEC_P, HAS_SYMS, D_PAGED
+ # start address 0x08049b50
+ $_ = <$fh>;
+ chomp;
+ $self->{flags}{$_} = 1 foreach (split(/,\s*/));
+ }
+ }
+ }
+ # Update status of dynamic symbols given the relocations that have
+ # been parsed after the symbols...
+ $self->apply_relocations();
+
+ return $section ne 'none';
+}
+
+# Output format of objdump -w -T
+#
+# /lib/libc.so.6: file format elf32-i386
+#
+# DYNAMIC SYMBOL TABLE:
+# 00056ef0 g DF .text 000000db GLIBC_2.2 getwchar
+# 00000000 g DO *ABS* 00000000 GCC_3.0 GCC_3.0
+# 00069960 w DF .text 0000001e GLIBC_2.0 bcmp
+# 00000000 w D *UND* 00000000 _pthread_cleanup_pop_restore
+# 0000b788 g DF .text 0000008e Base .protected xine_close
+# 0000b788 g DF .text 0000008e .hidden IA__g_free
+# | ||||||| | | | |
+# | ||||||| | | Version str (.visibility) + Symbol name
+# | ||||||| | Alignment
+# | ||||||| Section name (or *UND* for an undefined symbol)
+# | ||||||F=Function,f=file,O=object
+# | |||||d=debugging,D=dynamic
+# | ||||I=Indirect
+# | |||W=warning
+# | ||C=constructor
+# | |w=weak
+# | g=global,l=local,!=both global/local
+# Size of the symbol
+#
+# GLIBC_2.2 is the version string associated to the symbol
+# (GLIBC_2.2) is the same but the symbol is hidden, a newer version of the
+# symbol exist
+
+my $vis_re = qr/(\.protected|\.hidden|\.internal|0x\S+)/;
+my $dynsym_re = qr<
+ ^
+ [0-9a-f]+ # Symbol size
+ \ (.{7}) # Flags
+ \s+(\S+) # Section name
+ \s+[0-9a-f]+ # Alignment
+ (?:\s+(\S+))? # Version string
+ (?:\s+$vis_re)? # Visibility
+ \s+(.+) # Symbol name
+>x;
+
+sub parse_dynamic_symbol {
+ my ($self, $line) = @_;
+ if ($line =~ $dynsym_re) {
+
+ my ($flags, $sect, $ver, $vis, $name) = ($1, $2, $3, $4, $5);
+
+ # Special case if version is missing but extra visibility
+ # attribute replaces it in the match
+ if (defined($ver) and $ver =~ /^$vis_re$/) {
+ $vis = $ver;
+ $ver = '';
+ }
+
+ # Cleanup visibility field
+ $vis =~ s/^\.// if defined($vis);
+
+ my $symbol = {
+ name => $name,
+ version => $ver // '',
+ section => $sect,
+ dynamic => substr($flags, 5, 1) eq 'D',
+ debug => substr($flags, 5, 1) eq 'd',
+ type => substr($flags, 6, 1),
+ weak => substr($flags, 1, 1) eq 'w',
+ local => substr($flags, 0, 1) eq 'l',
+ global => substr($flags, 0, 1) eq 'g',
+ visibility => $vis // '',
+ hidden => '',
+ defined => $sect ne '*UND*'
+ };
+
+ # Handle hidden symbols
+ if (defined($ver) and $ver =~ /^\((.*)\)$/) {
+ $ver = $1;
+ $symbol->{version} = $1;
+ $symbol->{hidden} = 1;
+ }
+
+ # Register symbol
+ $self->add_dynamic_symbol($symbol);
+ } elsif ($line =~ /^[0-9a-f]+ (.{7})\s+(\S+)\s+[0-9a-f]+/) {
+ # Same start but no version and no symbol ... just ignore
+ } elsif ($line =~ /^REG_G\d+\s+/) {
+ # Ignore some s390-specific output like
+ # REG_G6 g R *UND* 0000000000000000 #scratch
+ } else {
+ warning(g_("couldn't parse dynamic symbol definition: %s"), $line);
+ }
+}
+
+sub apply_relocations {
+ my $self = shift;
+ foreach my $sym (values %{$self->{dynsyms}}) {
+ # We want to mark as undefined symbols those which are currently
+ # defined but that depend on a copy relocation
+ next if not $sym->{defined};
+ next if not exists $self->{dynrelocs}{$sym->{name}};
+ if ($self->{dynrelocs}{$sym->{name}} =~ /^R_.*_COPY$/) {
+ $sym->{defined} = 0;
+ }
+ }
+}
+
+sub add_dynamic_symbol {
+ my ($self, $symbol) = @_;
+ $symbol->{objid} = $symbol->{soname} = $self->get_id();
+ $symbol->{soname} =~ s{^.*/}{} unless $self->{SONAME};
+ if ($symbol->{version}) {
+ $self->{dynsyms}{$symbol->{name} . '@' . $symbol->{version}} = $symbol;
+ } else {
+ $self->{dynsyms}{$symbol->{name} . '@Base'} = $symbol;
+ }
+}
+
+sub get_id {
+ my $self = shift;
+ return $self->{SONAME} || $self->{file};
+}
+
+sub get_symbol {
+ my ($self, $name) = @_;
+ if (exists $self->{dynsyms}{$name}) {
+ return $self->{dynsyms}{$name};
+ }
+ if ($name !~ /@/) {
+ if (exists $self->{dynsyms}{$name . '@Base'}) {
+ return $self->{dynsyms}{$name . '@Base'};
+ }
+ }
+ return;
+}
+
+sub get_exported_dynamic_symbols {
+ my $self = shift;
+ return grep { $_->{defined} && $_->{dynamic} && !$_->{local} }
+ values %{$self->{dynsyms}};
+}
+
+sub get_undefined_dynamic_symbols {
+ my $self = shift;
+ return grep { (!$_->{defined}) && $_->{dynamic} }
+ values %{$self->{dynsyms}};
+}
+
+sub get_needed_libraries {
+ my $self = shift;
+ return @{$self->{NEEDED}};
+}
+
+sub is_executable {
+ my $self = shift;
+ return (exists $self->{flags}{EXEC_P} && $self->{flags}{EXEC_P}) ||
+ (exists $self->{INTERP} && $self->{INTERP});
+}
+
+sub is_public_library {
+ my $self = shift;
+ return exists $self->{flags}{DYNAMIC} && $self->{flags}{DYNAMIC}
+ && exists $self->{SONAME} && $self->{SONAME};
+}
+
+1;
diff --git a/scripts/Dpkg/Shlibs/Symbol.pm b/scripts/Dpkg/Shlibs/Symbol.pm
new file mode 100644
index 0000000..142992b
--- /dev/null
+++ b/scripts/Dpkg/Shlibs/Symbol.pm
@@ -0,0 +1,524 @@
+# Copyright © 2007 Raphaël Hertzog <hertzog@debian.org>
+# Copyright © 2009-2010 Modestas Vainius <modax@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+package Dpkg::Shlibs::Symbol;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+use Storable ();
+use List::Util qw(any);
+
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling;
+use Dpkg::Arch qw(debarch_is_concerned debarch_to_abiattrs);
+use Dpkg::Version;
+use Dpkg::Shlibs::Cppfilt;
+
+# Supported alias types in the order of matching preference
+use constant ALIAS_TYPES => qw(c++ symver);
+
+# Needed by the deprecated key, which is a correct use.
+no if $Dpkg::Version::VERSION ge '1.02',
+ warnings => qw(Dpkg::Version::semantic_change::overload::bool);
+
+sub new {
+ my ($this, %args) = @_;
+ my $class = ref($this) || $this;
+ my $self = bless {
+ symbol => undef,
+ symbol_templ => undef,
+ minver => undef,
+ dep_id => 0,
+ deprecated => 0,
+ tags => {},
+ tagorder => [],
+ }, $class;
+ $self->{$_} = $args{$_} foreach keys %args;
+ return $self;
+}
+
+# Deep clone
+sub clone {
+ my ($self, %args) = @_;
+ my $clone = Storable::dclone($self);
+ $clone->{$_} = $args{$_} foreach keys %args;
+ return $clone;
+}
+
+sub parse_tagspec {
+ my ($self, $tagspec) = @_;
+
+ if ($tagspec =~ /^\s*\((.*?)\)(.*)$/ && $1) {
+ # (tag1=t1 value|tag2|...|tagN=tNp)
+ # Symbols ()|= cannot appear in the tag names and values
+ my $tagspec = $1;
+ my $rest = ($2) ? $2 : '';
+ my @tags = split(/\|/, $tagspec);
+
+ # Parse each tag
+ for my $tag (@tags) {
+ if ($tag =~ /^(.*)=(.*)$/) {
+ # Tag with value
+ $self->add_tag($1, $2);
+ } else {
+ # Tag without value
+ $self->add_tag($tag, undef);
+ }
+ }
+ return $rest;
+ }
+ return;
+}
+
+sub parse_symbolspec {
+ my ($self, $symbolspec, %opts) = @_;
+ my $symbol;
+ my $symbol_templ;
+ my $symbol_quoted;
+ my $rest;
+
+ if (defined($symbol = $self->parse_tagspec($symbolspec))) {
+ # (tag1=t1 value|tag2|...|tagN=tNp)"Foo::Bar::foobar()"@Base 1.0 1
+ # Symbols ()|= cannot appear in the tag names and values
+
+ # If the tag specification exists symbol name template might be quoted too
+ if ($symbol =~ /^(['"])/ && $symbol =~ /^($1)(.*?)$1(.*)$/) {
+ $symbol_quoted = $1;
+ $symbol_templ = $2;
+ $symbol = $2;
+ $rest = $3;
+ } else {
+ if ($symbol =~ m/^(\S+)(.*)$/) {
+ $symbol_templ = $1;
+ $symbol = $1;
+ $rest = $2;
+ }
+ }
+ error(g_('symbol name unspecified: %s'), $symbolspec) if (!$symbol);
+ } else {
+ # No tag specification. Symbol name is up to the first space
+ # foobarsymbol@Base 1.0 1
+ if ($symbolspec =~ m/^(\S+)(.*)$/) {
+ $symbol = $1;
+ $rest = $2;
+ } else {
+ return 0;
+ }
+ }
+ $self->{symbol} = $symbol;
+ $self->{symbol_templ} = $symbol_templ;
+ $self->{symbol_quoted} = $symbol_quoted if ($symbol_quoted);
+
+ # Now parse "the rest" (minver and dep_id)
+ if ($rest =~ /^\s(\S+)(?:\s(\d+))?/) {
+ $self->{minver} = $1;
+ $self->{dep_id} = $2 // 0;
+ } elsif (defined $opts{default_minver}) {
+ $self->{minver} = $opts{default_minver};
+ $self->{dep_id} = 0;
+ } else {
+ return 0;
+ }
+ return 1;
+}
+
+# A hook for symbol initialization (typically processing of tags). The code
+# here may even change symbol name. Called from
+# Dpkg::Shlibs::SymbolFile::create_symbol().
+sub initialize {
+ my $self = shift;
+
+ # Look for tags marking symbol patterns. The pattern may match multiple
+ # real symbols.
+ my $type;
+ if ($self->has_tag('c++')) {
+ # Raw symbol name is always demangled to the same alias while demangled
+ # symbol name cannot be reliably converted back to raw symbol name.
+ # Therefore, we can use hash for mapping.
+ $type = 'alias-c++';
+ }
+
+ # Support old style wildcard syntax. That's basically a symver
+ # with an optional tag.
+ if ($self->get_symbolname() =~ /^\*@(.*)$/) {
+ $self->add_tag('symver') unless $self->has_tag('symver');
+ $self->add_tag('optional') unless $self->has_tag('optional');
+ $self->{symbol} = $1;
+ }
+
+ if ($self->has_tag('symver')) {
+ # Each symbol is matched against its version rather than full
+ # name@version string.
+ $type = (defined $type) ? 'generic' : 'alias-symver';
+ if ($self->get_symbolname() eq 'Base') {
+ error(g_("you can't use symver tag to catch unversioned symbols: %s"),
+ $self->get_symbolspec(1));
+ }
+ }
+
+ # As soon as regex is involved, we need to match each real
+ # symbol against each pattern (aka 'generic' pattern).
+ if ($self->has_tag('regex')) {
+ $type = 'generic';
+ # Pre-compile regular expression for better performance.
+ my $regex = $self->get_symbolname();
+ $self->{pattern}{regex} = qr/$regex/;
+ }
+ if (defined $type) {
+ $self->init_pattern($type);
+ }
+}
+
+sub get_symbolname {
+ my $self = shift;
+
+ return $self->{symbol};
+}
+
+sub get_symboltempl {
+ my $self = shift;
+
+ return $self->{symbol_templ} || $self->{symbol};
+}
+
+sub set_symbolname {
+ my ($self, $name, $templ, $quoted) = @_;
+
+ $name //= $self->{symbol};
+ if (!defined $templ && $name =~ /\s/) {
+ $templ = $name;
+ }
+ if (!defined $quoted && defined $templ && $templ =~ /\s/) {
+ $quoted = '"';
+ }
+ $self->{symbol} = $name;
+ $self->{symbol_templ} = $templ;
+ if ($quoted) {
+ $self->{symbol_quoted} = $quoted;
+ } else {
+ delete $self->{symbol_quoted};
+ }
+}
+
+sub has_tags {
+ my $self = shift;
+ return scalar (@{$self->{tagorder}});
+}
+
+sub add_tag {
+ my ($self, $tagname, $tagval) = @_;
+ if (exists $self->{tags}{$tagname}) {
+ $self->{tags}{$tagname} = $tagval;
+ return 0;
+ } else {
+ $self->{tags}{$tagname} = $tagval;
+ push @{$self->{tagorder}}, $tagname;
+ }
+ return 1;
+}
+
+sub delete_tag {
+ my ($self, $tagname) = @_;
+ if (exists $self->{tags}{$tagname}) {
+ delete $self->{tags}{$tagname};
+ $self->{tagorder} = [ grep { $_ ne $tagname } @{$self->{tagorder}} ];
+ return 1;
+ }
+ return 0;
+}
+
+sub has_tag {
+ my ($self, $tag) = @_;
+ return exists $self->{tags}{$tag};
+}
+
+sub get_tag_value {
+ my ($self, $tag) = @_;
+ return $self->{tags}{$tag};
+}
+
+# Checks if the symbol is equal to another one (by name and optionally,
+# tag sets, versioning info (minver and depid))
+sub equals {
+ my ($self, $other, %opts) = @_;
+ $opts{versioning} //= 1;
+ $opts{tags} //= 1;
+
+ return 0 if $self->{symbol} ne $other->{symbol};
+
+ if ($opts{versioning}) {
+ return 0 if $self->{minver} ne $other->{minver};
+ return 0 if $self->{dep_id} ne $other->{dep_id};
+ }
+
+ if ($opts{tags}) {
+ return 0 if scalar(@{$self->{tagorder}}) != scalar(@{$other->{tagorder}});
+
+ for my $i (0 .. scalar(@{$self->{tagorder}}) - 1) {
+ my $tag = $self->{tagorder}->[$i];
+ return 0 if $tag ne $other->{tagorder}->[$i];
+ if (defined $self->{tags}{$tag} && defined $other->{tags}{$tag}) {
+ return 0 if $self->{tags}{$tag} ne $other->{tags}{$tag};
+ } elsif (defined $self->{tags}{$tag} || defined $other->{tags}{$tag}) {
+ return 0;
+ }
+ }
+ }
+
+ return 1;
+}
+
+
+sub is_optional {
+ my $self = shift;
+ return $self->has_tag('optional');
+}
+
+sub is_arch_specific {
+ my $self = shift;
+ return $self->has_tag('arch');
+}
+
+sub arch_is_concerned {
+ my ($self, $arch) = @_;
+ my $arches = $self->{tags}{arch};
+
+ return 0 if defined $arch && defined $arches &&
+ !debarch_is_concerned($arch, split /[\s,]+/, $arches);
+
+ my ($bits, $endian) = debarch_to_abiattrs($arch);
+ return 0 if defined $bits && defined $self->{tags}{'arch-bits'} &&
+ $bits ne $self->{tags}{'arch-bits'};
+ return 0 if defined $endian && defined $self->{tags}{'arch-endian'} &&
+ $endian ne $self->{tags}{'arch-endian'};
+
+ return 1;
+}
+
+# Get reference to the pattern the symbol matches (if any)
+sub get_pattern {
+ my $self = shift;
+
+ return $self->{matching_pattern};
+}
+
+### NOTE: subroutines below require (or initialize) $self to be a pattern ###
+
+# Initializes this symbol as a pattern of the specified type.
+sub init_pattern {
+ my ($self, $type) = @_;
+
+ $self->{pattern}{type} = $type;
+ # To be filled with references to symbols matching this pattern.
+ $self->{pattern}{matches} = [];
+}
+
+# Is this symbol a pattern or not?
+sub is_pattern {
+ my $self = shift;
+
+ return exists $self->{pattern};
+}
+
+# Get pattern type if this symbol is a pattern.
+sub get_pattern_type {
+ my $self = shift;
+
+ return $self->{pattern}{type} // '';
+}
+
+# Get (sub)type of the alias pattern. Returns empty string if current
+# pattern is not alias.
+sub get_alias_type {
+ my $self = shift;
+
+ return ($self->get_pattern_type() =~ /^alias-(.+)/ && $1) || '';
+}
+
+# Get a list of symbols matching this pattern if this symbol is a pattern
+sub get_pattern_matches {
+ my $self = shift;
+
+ return @{$self->{pattern}{matches}};
+}
+
+# Create a new symbol based on the pattern (i.e. $self)
+# and add it to the pattern matches list.
+sub create_pattern_match {
+ my $self = shift;
+ return unless $self->is_pattern();
+
+ # Leave out 'pattern' subfield while deep-cloning
+ my $pattern_stuff = $self->{pattern};
+ delete $self->{pattern};
+ my $newsym = $self->clone(@_);
+ $self->{pattern} = $pattern_stuff;
+
+ # Clean up symbol name related internal fields
+ $newsym->set_symbolname();
+
+ # Set newsym pattern reference, add to pattern matches list
+ $newsym->{matching_pattern} = $self;
+ push @{$self->{pattern}{matches}}, $newsym;
+ return $newsym;
+}
+
+### END of pattern subroutines ###
+
+# Given a raw symbol name the call returns its alias according to the rules of
+# the current pattern ($self). Returns undef if the supplied raw name is not
+# transformable to alias.
+sub convert_to_alias {
+ my ($self, $rawname, $type) = @_;
+ $type = $self->get_alias_type() unless $type;
+
+ if ($type) {
+ if ($type eq 'symver') {
+ # In case of symver, alias is symbol version. Extract it from the
+ # rawname.
+ return "$1" if ($rawname =~ /\@([^@]+)$/);
+ } elsif ($rawname =~ /^_Z/ && $type eq 'c++') {
+ return cppfilt_demangle_cpp($rawname);
+ }
+ }
+ return;
+}
+
+sub get_tagspec {
+ my $self = shift;
+ if ($self->has_tags()) {
+ my @tags;
+ for my $tagname (@{$self->{tagorder}}) {
+ my $tagval = $self->{tags}{$tagname};
+ if (defined $tagval) {
+ push @tags, $tagname . '=' . $tagval;
+ } else {
+ push @tags, $tagname;
+ }
+ }
+ return '(' . join('|', @tags) . ')';
+ }
+ return '';
+}
+
+sub get_symbolspec {
+ my $self = shift;
+ my $template_mode = shift;
+ my $spec = '';
+ $spec .= "#MISSING: $self->{deprecated}#" if $self->{deprecated};
+ $spec .= ' ';
+ if ($template_mode) {
+ if ($self->has_tags()) {
+ $spec .= sprintf('%s%3$s%s%3$s', $self->get_tagspec(),
+ $self->get_symboltempl(), $self->{symbol_quoted} // '');
+ } else {
+ $spec .= $self->get_symboltempl();
+ }
+ } else {
+ $spec .= $self->get_symbolname();
+ }
+ $spec .= " $self->{minver}";
+ $spec .= " $self->{dep_id}" if $self->{dep_id};
+ return $spec;
+}
+
+# Sanitize the symbol when it is confirmed to be found in
+# the respective library.
+sub mark_found_in_library {
+ my ($self, $minver, $arch) = @_;
+
+ if ($self->{deprecated}) {
+ # Symbol reappeared somehow
+ $self->{deprecated} = 0;
+ $self->{minver} = $minver if (not $self->is_optional());
+ } else {
+ # We assume that the right dependency information is already
+ # there.
+ if (version_compare($minver, $self->{minver}) < 0) {
+ $self->{minver} = $minver;
+ }
+ }
+ # Never remove arch tags from patterns
+ if (not $self->is_pattern()) {
+ if (not $self->arch_is_concerned($arch)) {
+ # Remove arch tags because they are incorrect.
+ $self->delete_tag('arch');
+ $self->delete_tag('arch-bits');
+ $self->delete_tag('arch-endian');
+ }
+ }
+}
+
+# Sanitize the symbol when it is confirmed to be NOT found in
+# the respective library.
+# Mark as deprecated those that are no more provided (only if the
+# minver is later than the version where the symbol was introduced)
+sub mark_not_found_in_library {
+ my ($self, $minver, $arch) = @_;
+
+ # Ignore symbols from foreign arch
+ return if not $self->arch_is_concerned($arch);
+
+ if ($self->{deprecated}) {
+ # Bump deprecated if the symbol is optional so that it
+ # keeps reappearing in the diff while it's missing
+ $self->{deprecated} = $minver if $self->is_optional();
+ } elsif (version_compare($minver, $self->{minver}) > 0) {
+ $self->{deprecated} = $minver;
+ }
+}
+
+# Checks if the symbol (or pattern) is legitimate as a real symbol for the
+# specified architecture.
+sub is_legitimate {
+ my ($self, $arch) = @_;
+ return ! $self->{deprecated} &&
+ $self->arch_is_concerned($arch);
+}
+
+# Determine whether a supplied raw symbol name matches against current ($self)
+# symbol or pattern.
+sub matches_rawname {
+ my ($self, $rawname) = @_;
+ my $target = $rawname;
+ my $ok = 1;
+ my $do_eq_match = 1;
+
+ if ($self->is_pattern()) {
+ # Process pattern tags in the order they were specified.
+ for my $tag (@{$self->{tagorder}}) {
+ if (any { $tag eq $_ } ALIAS_TYPES) {
+ $ok = not not ($target = $self->convert_to_alias($target, $tag));
+ } elsif ($tag eq 'regex') {
+ # Symbol name is a regex. Match it against the target
+ $do_eq_match = 0;
+ $ok = ($target =~ $self->{pattern}{regex});
+ }
+ last if not $ok;
+ }
+ }
+
+ # Equality match by default
+ if ($ok && $do_eq_match) {
+ $ok = $target eq $self->get_symbolname();
+ }
+ return $ok;
+}
+
+1;
diff --git a/scripts/Dpkg/Shlibs/SymbolFile.pm b/scripts/Dpkg/Shlibs/SymbolFile.pm
new file mode 100644
index 0000000..4b1c7ef
--- /dev/null
+++ b/scripts/Dpkg/Shlibs/SymbolFile.pm
@@ -0,0 +1,678 @@
+# Copyright © 2007 Raphaël Hertzog <hertzog@debian.org>
+# Copyright © 2009-2010 Modestas Vainius <modax@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+package Dpkg::Shlibs::SymbolFile;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling;
+use Dpkg::Version;
+use Dpkg::Control::Fields;
+use Dpkg::Shlibs::Symbol;
+use Dpkg::Arch qw(get_host_arch);
+
+use parent qw(Dpkg::Interface::Storable);
+
+# Needed by the deprecated key, which is a correct use.
+no if $Dpkg::Version::VERSION ge '1.02',
+ warnings => qw(Dpkg::Version::semantic_change::overload::bool);
+
+my %blacklist = (
+ __bss_end__ => 1, # arm
+ __bss_end => 1, # arm
+ _bss_end__ => 1, # arm
+ __bss_start => 1, # ALL
+ __bss_start__ => 1, # arm
+ __data_start => 1, # arm
+ __do_global_ctors_aux => 1, # ia64
+ __do_global_dtors_aux => 1, # ia64
+ __do_jv_register_classes => 1, # ia64
+ _DYNAMIC => 1, # ALL
+ _edata => 1, # ALL
+ _end => 1, # ALL
+ __end__ => 1, # arm
+ __exidx_end => 1, # armel
+ __exidx_start => 1, # armel
+ _fbss => 1, # mips, mipsel
+ _fdata => 1, # mips, mipsel
+ _fini => 1, # ALL
+ _ftext => 1, # mips, mipsel
+ _GLOBAL_OFFSET_TABLE_ => 1, # hppa, mips, mipsel
+ __gmon_start__ => 1, # hppa
+ __gnu_local_gp => 1, # mips, mipsel
+ _gp => 1, # mips, mipsel
+ _init => 1, # ALL
+ _PROCEDURE_LINKAGE_TABLE_ => 1, # sparc, alpha
+ _SDA2_BASE_ => 1, # powerpc
+ _SDA_BASE_ => 1, # powerpc
+);
+
+for my $i (14 .. 31) {
+ # Many powerpc specific symbols
+ $blacklist{"_restfpr_$i"} = 1;
+ $blacklist{"_restfpr_$i\_x"} = 1;
+ $blacklist{"_restgpr_$i"} = 1;
+ $blacklist{"_restgpr_$i\_x"} = 1;
+ $blacklist{"_savefpr_$i"} = 1;
+ $blacklist{"_savegpr_$i"} = 1;
+}
+
+sub symbol_is_blacklisted {
+ my ($symbol, $include_groups) = @_;
+
+ return 1 if exists $blacklist{$symbol};
+
+ # The ARM Embedded ABI spec states symbols under this namespace as
+ # possibly appearing in output objects.
+ return 1 if not ${$include_groups}{aeabi} and $symbol =~ /^__aeabi_/;
+
+ # The GNU implementation of the OpenMP spec, specifies symbols under
+ # this namespace as possibly appearing in output objects.
+ return 1 if not ${$include_groups}{gomp}
+ and $symbol =~ /^\.gomp_critical_user_/;
+
+ return 0;
+}
+
+sub new {
+ my ($this, %opts) = @_;
+ my $class = ref($this) || $this;
+ my $self = \%opts;
+ bless $self, $class;
+ $self->{arch} //= get_host_arch();
+ $self->clear();
+ if (exists $self->{file}) {
+ $self->load($self->{file}) if -e $self->{file};
+ }
+ return $self;
+}
+
+sub get_arch {
+ my $self = shift;
+ return $self->{arch};
+}
+
+sub clear {
+ my $self = shift;
+ $self->{objects} = {};
+}
+
+sub clear_except {
+ my ($self, @ids) = @_;
+
+ my %has = map { $_ => 1 } @ids;
+ foreach my $objid (keys %{$self->{objects}}) {
+ delete $self->{objects}{$objid} unless exists $has{$objid};
+ }
+}
+
+sub get_sonames {
+ my $self = shift;
+ return keys %{$self->{objects}};
+}
+
+sub get_symbols {
+ my ($self, $soname) = @_;
+ if (defined $soname) {
+ my $obj = $self->get_object($soname);
+ return (defined $obj) ? values %{$obj->{syms}} : ();
+ } else {
+ my @syms;
+ foreach my $soname ($self->get_sonames()) {
+ push @syms, $self->get_symbols($soname);
+ }
+ return @syms;
+ }
+}
+
+sub get_patterns {
+ my ($self, $soname) = @_;
+ my @patterns;
+ if (defined $soname) {
+ my $obj = $self->get_object($soname);
+ foreach my $alias (values %{$obj->{patterns}{aliases}}) {
+ push @patterns, values %$alias;
+ }
+ return (@patterns, @{$obj->{patterns}{generic}});
+ } else {
+ foreach my $soname ($self->get_sonames()) {
+ push @patterns, $self->get_patterns($soname);
+ }
+ return @patterns;
+ }
+}
+
+# Create a symbol from the supplied string specification.
+sub create_symbol {
+ my ($self, $spec, %opts) = @_;
+ my $symbol = (exists $opts{base}) ? $opts{base} :
+ Dpkg::Shlibs::Symbol->new();
+
+ my $ret = $opts{dummy} ? $symbol->parse_symbolspec($spec, default_minver => 0) :
+ $symbol->parse_symbolspec($spec);
+ if ($ret) {
+ $symbol->initialize(arch => $self->get_arch());
+ return $symbol;
+ }
+ return;
+}
+
+sub add_symbol {
+ my ($self, $symbol, $soname) = @_;
+ my $object = $self->get_object($soname);
+
+ if ($symbol->is_pattern()) {
+ if (my $alias_type = $symbol->get_alias_type()) {
+ $object->{patterns}{aliases}{$alias_type} //= {};
+ # Alias hash for matching.
+ my $aliases = $object->{patterns}{aliases}{$alias_type};
+ $aliases->{$symbol->get_symbolname()} = $symbol;
+ } else {
+ # Otherwise assume this is a generic sequential pattern. This
+ # should be always safe.
+ push @{$object->{patterns}{generic}}, $symbol;
+ }
+ return 'pattern';
+ } else {
+ # invalidate the minimum version cache
+ $object->{minver_cache} = [];
+ $object->{syms}{$symbol->get_symbolname()} = $symbol;
+ return 'sym';
+ }
+}
+
+sub _new_symbol {
+ my $base = shift || 'Dpkg::Shlibs::Symbol';
+ return (ref $base) ? $base->clone(@_) : $base->new(@_);
+}
+
+# Option state is only used for recursive calls.
+sub parse {
+ my ($self, $fh, $file, %opts) = @_;
+ my $state = $opts{state} //= {};
+
+ if (exists $state->{seen}) {
+ return if exists $state->{seen}{$file}; # Avoid include loops
+ } else {
+ $self->{file} = $file;
+ $state->{seen} = {};
+ }
+ $state->{seen}{$file} = 1;
+
+ if (not ref $state->{obj_ref}) { # Init ref to name of current object/lib
+ ${$state->{obj_ref}} = undef;
+ }
+
+ while (<$fh>) {
+ chomp;
+
+ if (/^(?:\s+|#(?:DEPRECATED|MISSING): ([^#]+)#\s*)(.*)/) {
+ if (not defined ${$state->{obj_ref}}) {
+ error(g_('symbol information must be preceded by a header (file %s, line %s)'), $file, $.);
+ }
+ # Symbol specification
+ my $deprecated = ($1) ? Dpkg::Version->new($1) : 0;
+ my $sym = _new_symbol($state->{base_symbol}, deprecated => $deprecated);
+ if ($self->create_symbol($2, base => $sym)) {
+ $self->add_symbol($sym, ${$state->{obj_ref}});
+ } else {
+ warning(g_('failed to parse line in %s: %s'), $file, $_);
+ }
+ } elsif (/^(\(.*\))?#include\s+"([^"]+)"/) {
+ my $tagspec = $1;
+ my $filename = $2;
+ my $dir = $file;
+ my $old_base_symbol = $state->{base_symbol};
+ my $new_base_symbol;
+ if (defined $tagspec) {
+ $new_base_symbol = _new_symbol($old_base_symbol);
+ $new_base_symbol->parse_tagspec($tagspec);
+ }
+ $state->{base_symbol} = $new_base_symbol;
+ $dir =~ s{[^/]+$}{}; # Strip filename
+ $self->load("$dir$filename", %opts);
+ $state->{base_symbol} = $old_base_symbol;
+ } elsif (/^#|^$/) {
+ # Skip possible comments and empty lines
+ } elsif (/^\|\s*(.*)$/) {
+ # Alternative dependency template
+ push @{$self->{objects}{${$state->{obj_ref}}}{deps}}, "$1";
+ } elsif (/^\*\s*([^:]+):\s*(.*\S)\s*$/) {
+ # Add meta-fields
+ $self->{objects}{${$state->{obj_ref}}}{fields}{field_capitalize($1)} = $2;
+ } elsif (/^(\S+)\s+(.*)$/) {
+ # New object and dependency template
+ ${$state->{obj_ref}} = $1;
+ if (exists $self->{objects}{${$state->{obj_ref}}}) {
+ # Update/override infos only
+ $self->{objects}{${$state->{obj_ref}}}{deps} = [ "$2" ];
+ } else {
+ # Create a new object
+ $self->create_object(${$state->{obj_ref}}, "$2");
+ }
+ } else {
+ warning(g_('failed to parse a line in %s: %s'), $file, $_);
+ }
+ }
+ delete $state->{seen}{$file};
+}
+
+# Beware: we reuse the data structure of the provided symfile so make
+# sure to not modify them after having called this function
+sub merge_object_from_symfile {
+ my ($self, $src, $objid) = @_;
+ if (not $self->has_object($objid)) {
+ $self->{objects}{$objid} = $src->get_object($objid);
+ } else {
+ warning(g_('tried to merge the same object (%s) twice in a symfile'), $objid);
+ }
+}
+
+sub output {
+ my ($self, $fh, %opts) = @_;
+ $opts{template_mode} //= 0;
+ $opts{with_deprecated} //= 1;
+ $opts{with_pattern_matches} //= 0;
+ my $res = '';
+ foreach my $soname (sort $self->get_sonames()) {
+ my @deps = $self->get_dependencies($soname);
+ my $dep_first = shift @deps;
+ if (exists $opts{package} and not $opts{template_mode}) {
+ $dep_first =~ s/#PACKAGE#/$opts{package}/g;
+ }
+ print { $fh } "$soname $dep_first\n" if defined $fh;
+ $res .= "$soname $dep_first\n" if defined wantarray;
+
+ foreach my $dep_next (@deps) {
+ if (exists $opts{package} and not $opts{template_mode}) {
+ $dep_next =~ s/#PACKAGE#/$opts{package}/g;
+ }
+ print { $fh } "| $dep_next\n" if defined $fh;
+ $res .= "| $dep_next\n" if defined wantarray;
+ }
+ my $f = $self->{objects}{$soname}{fields};
+ foreach my $field (sort keys %{$f}) {
+ my $value = $f->{$field};
+ if (exists $opts{package} and not $opts{template_mode}) {
+ $value =~ s/#PACKAGE#/$opts{package}/g;
+ }
+ print { $fh } "* $field: $value\n" if defined $fh;
+ $res .= "* $field: $value\n" if defined wantarray;
+ }
+
+ my @symbols;
+ if ($opts{template_mode}) {
+ # Exclude symbols matching a pattern, but include patterns themselves
+ @symbols = grep { not $_->get_pattern() } $self->get_symbols($soname);
+ push @symbols, $self->get_patterns($soname);
+ } else {
+ @symbols = $self->get_symbols($soname);
+ }
+ foreach my $sym (sort { $a->get_symboltempl() cmp
+ $b->get_symboltempl() } @symbols) {
+ next if $sym->{deprecated} and not $opts{with_deprecated};
+ # Do not dump symbols from foreign arch unless dumping a template.
+ next if not $opts{template_mode} and
+ not $sym->arch_is_concerned($self->get_arch());
+ # Dump symbol specification. Dump symbol tags only in template mode.
+ print { $fh } $sym->get_symbolspec($opts{template_mode}), "\n" if defined $fh;
+ $res .= $sym->get_symbolspec($opts{template_mode}) . "\n" if defined wantarray;
+ # Dump pattern matches as comments (if requested)
+ if ($opts{with_pattern_matches} && $sym->is_pattern()) {
+ for my $match (sort { $a->get_symboltempl() cmp
+ $b->get_symboltempl() } $sym->get_pattern_matches())
+ {
+ print { $fh } '#MATCH:', $match->get_symbolspec(0), "\n" if defined $fh;
+ $res .= '#MATCH:' . $match->get_symbolspec(0) . "\n" if defined wantarray;
+ }
+ }
+ }
+ }
+ return $res;
+}
+
+# Tries to match a symbol name and/or version against the patterns defined.
+# Returns a pattern which matches (if any).
+sub find_matching_pattern {
+ my ($self, $refsym, $sonames, $inc_deprecated) = @_;
+ $inc_deprecated //= 0;
+ my $name = (ref $refsym) ? $refsym->get_symbolname() : $refsym;
+
+ my $pattern_ok = sub {
+ my $p = shift;
+ return defined $p && ($inc_deprecated || !$p->{deprecated}) &&
+ $p->arch_is_concerned($self->get_arch());
+ };
+
+ foreach my $soname ((ref($sonames) eq 'ARRAY') ? @$sonames : $sonames) {
+ my $obj = $self->get_object($soname);
+ my ($type, $pattern);
+ next unless defined $obj;
+
+ my $all_aliases = $obj->{patterns}{aliases};
+ for my $type (Dpkg::Shlibs::Symbol::ALIAS_TYPES) {
+ if (exists $all_aliases->{$type} && keys(%{$all_aliases->{$type}})) {
+ my $aliases = $all_aliases->{$type};
+ my $converter = $aliases->{(keys %$aliases)[0]};
+ if (my $alias = $converter->convert_to_alias($name)) {
+ if ($alias && exists $aliases->{$alias}) {
+ $pattern = $aliases->{$alias};
+ last if $pattern_ok->($pattern);
+ $pattern = undef; # otherwise not found yet
+ }
+ }
+ }
+ }
+
+ # Now try generic patterns and use the first that matches
+ if (not defined $pattern) {
+ for my $p (@{$obj->{patterns}{generic}}) {
+ if ($pattern_ok->($p) && $p->matches_rawname($name)) {
+ $pattern = $p;
+ last;
+ }
+ }
+ }
+ if (defined $pattern) {
+ return (wantarray) ?
+ ( symbol => $pattern, soname => $soname ) : $pattern;
+ }
+ }
+ return;
+}
+
+# merge_symbols($object, $minver)
+# Needs $Objdump->get_object($soname) as parameter
+# Don't merge blacklisted symbols related to the internal (arch-specific)
+# machinery
+sub merge_symbols {
+ my ($self, $object, $minver) = @_;
+
+ my $soname = $object->{SONAME};
+ error(g_('cannot merge symbols from objects without SONAME'))
+ unless $soname;
+
+ my %include_groups = ();
+ my $groups = $self->get_field($soname, 'Ignore-Blacklist-Groups');
+ if (defined $groups) {
+ $include_groups{$_} = 1 foreach (split ' ', $groups);
+ }
+
+ my %dynsyms;
+ foreach my $sym ($object->get_exported_dynamic_symbols()) {
+ my $name = $sym->{name} . '@' .
+ ($sym->{version} ? $sym->{version} : 'Base');
+ my $symobj = $self->lookup_symbol($name, $soname);
+ if (symbol_is_blacklisted($sym->{name}, \%include_groups)) {
+ next unless (defined $symobj and $symobj->has_tag('ignore-blacklist'));
+ }
+ $dynsyms{$name} = $sym;
+ }
+
+ unless ($self->has_object($soname)) {
+ $self->create_object($soname, '');
+ }
+ # Scan all symbols provided by the objects
+ my $obj = $self->get_object($soname);
+ # invalidate the minimum version cache - it is not sufficient to
+ # invalidate in add_symbol, since we might change a minimum
+ # version for a particular symbol without adding it
+ $obj->{minver_cache} = [];
+ foreach my $name (keys %dynsyms) {
+ my $sym;
+ if ($sym = $self->lookup_symbol($name, $obj, 1)) {
+ # If the symbol is already listed in the file
+ $sym->mark_found_in_library($minver, $self->get_arch());
+ } else {
+ # The exact symbol is not present in the file, but it might match a
+ # pattern.
+ my $pattern = $self->find_matching_pattern($name, $obj, 1);
+ if (defined $pattern) {
+ $pattern->mark_found_in_library($minver, $self->get_arch());
+ $sym = $pattern->create_pattern_match(symbol => $name);
+ } else {
+ # Symbol without any special info as no pattern matched
+ $sym = Dpkg::Shlibs::Symbol->new(symbol => $name,
+ minver => $minver);
+ }
+ $self->add_symbol($sym, $obj);
+ }
+ }
+
+ # Process all symbols which could not be found in the library.
+ foreach my $sym ($self->get_symbols($soname)) {
+ if (not exists $dynsyms{$sym->get_symbolname()}) {
+ $sym->mark_not_found_in_library($minver, $self->get_arch());
+ }
+ }
+
+ # Deprecate patterns which didn't match anything
+ for my $pattern (grep { $_->get_pattern_matches() == 0 }
+ $self->get_patterns($soname)) {
+ $pattern->mark_not_found_in_library($minver, $self->get_arch());
+ }
+}
+
+sub is_empty {
+ my $self = shift;
+ return scalar(keys %{$self->{objects}}) ? 0 : 1;
+}
+
+sub has_object {
+ my ($self, $soname) = @_;
+ return exists $self->{objects}{$soname};
+}
+
+sub get_object {
+ my ($self, $soname) = @_;
+ return ref($soname) ? $soname : $self->{objects}{$soname};
+}
+
+sub create_object {
+ my ($self, $soname, @deps) = @_;
+ $self->{objects}{$soname} = {
+ syms => {},
+ fields => {},
+ patterns => {
+ aliases => {},
+ generic => [],
+ },
+ deps => [ @deps ],
+ minver_cache => []
+ };
+}
+
+sub get_dependency {
+ my ($self, $soname, $dep_id) = @_;
+ $dep_id //= 0;
+ return $self->get_object($soname)->{deps}[$dep_id];
+}
+
+sub get_smallest_version {
+ my ($self, $soname, $dep_id) = @_;
+ $dep_id //= 0;
+ my $so_object = $self->get_object($soname);
+ return $so_object->{minver_cache}[$dep_id]
+ if defined $so_object->{minver_cache}[$dep_id];
+ my $minver;
+ foreach my $sym ($self->get_symbols($so_object)) {
+ next if $dep_id != $sym->{dep_id};
+ $minver //= $sym->{minver};
+ if (version_compare($minver, $sym->{minver}) > 0) {
+ $minver = $sym->{minver};
+ }
+ }
+ $so_object->{minver_cache}[$dep_id] = $minver;
+ return $minver;
+}
+
+sub get_dependencies {
+ my ($self, $soname) = @_;
+ return @{$self->get_object($soname)->{deps}};
+}
+
+sub get_field {
+ my ($self, $soname, $name) = @_;
+ if (my $obj = $self->get_object($soname)) {
+ if (exists $obj->{fields}{$name}) {
+ return $obj->{fields}{$name};
+ }
+ }
+ return;
+}
+
+# Tries to find a symbol like the $refsym and returns its descriptor.
+# $refsym may also be a symbol name.
+sub lookup_symbol {
+ my ($self, $refsym, $sonames, $inc_deprecated) = @_;
+ $inc_deprecated //= 0;
+ my $name = (ref $refsym) ? $refsym->get_symbolname() : $refsym;
+
+ foreach my $so ((ref($sonames) eq 'ARRAY') ? @$sonames : $sonames) {
+ if (my $obj = $self->get_object($so)) {
+ my $sym = $obj->{syms}{$name};
+ if ($sym and ($inc_deprecated or not $sym->{deprecated}))
+ {
+ return (wantarray) ?
+ ( symbol => $sym, soname => $so ) : $sym;
+ }
+ }
+ }
+ return;
+}
+
+# Tries to find a pattern like the $refpat and returns its descriptor.
+# $refpat may also be a pattern spec.
+sub lookup_pattern {
+ my ($self, $refpat, $sonames, $inc_deprecated) = @_;
+ $inc_deprecated //= 0;
+ # If $refsym is a string, we need to create a dummy ref symbol.
+ $refpat = $self->create_symbol($refpat, dummy => 1) if ! ref($refpat);
+
+ if ($refpat && $refpat->is_pattern()) {
+ foreach my $soname ((ref($sonames) eq 'ARRAY') ? @$sonames : $sonames) {
+ if (my $obj = $self->get_object($soname)) {
+ my $pat;
+ if (my $type = $refpat->get_alias_type()) {
+ if (exists $obj->{patterns}{aliases}{$type}) {
+ $pat = $obj->{patterns}{aliases}{$type}{$refpat->get_symbolname()};
+ }
+ } elsif ($refpat->get_pattern_type() eq 'generic') {
+ for my $p (@{$obj->{patterns}{generic}}) {
+ if (($inc_deprecated || !$p->{deprecated}) &&
+ $p->equals($refpat, versioning => 0))
+ {
+ $pat = $p;
+ last;
+ }
+ }
+ }
+ if ($pat && ($inc_deprecated || !$pat->{deprecated})) {
+ return (wantarray) ?
+ (symbol => $pat, soname => $soname) : $pat;
+ }
+ }
+ }
+ }
+ return;
+}
+
+# Get symbol object reference either by symbol name or by a reference object.
+sub get_symbol_object {
+ my ($self, $refsym, $soname) = @_;
+ my $sym = $self->lookup_symbol($refsym, $soname, 1);
+ if (! defined $sym) {
+ $sym = $self->lookup_pattern($refsym, $soname, 1);
+ }
+ return $sym;
+}
+
+sub get_new_symbols {
+ my ($self, $ref, %opts) = @_;
+ my $with_optional = (exists $opts{with_optional}) ?
+ $opts{with_optional} : 0;
+ my @res;
+ foreach my $soname ($self->get_sonames()) {
+ next if not $ref->has_object($soname);
+
+ # Scan raw symbols first.
+ foreach my $sym (grep { ($with_optional || ! $_->is_optional())
+ && $_->is_legitimate($self->get_arch()) }
+ $self->get_symbols($soname))
+ {
+ my $refsym = $ref->lookup_symbol($sym, $soname, 1);
+ my $isnew;
+ if (defined $refsym) {
+ # If the symbol exists in the $ref symbol file, it might
+ # still be new if $refsym is not legitimate.
+ $isnew = not $refsym->is_legitimate($self->get_arch());
+ } else {
+ # If the symbol does not exist in the $ref symbol file, it does
+ # not mean that it's new. It might still match a pattern in the
+ # symbol file. However, due to performance reasons, first check
+ # if the pattern that the symbol matches (if any) exists in the
+ # ref symbol file as well.
+ $isnew = not (
+ ($sym->get_pattern() and $ref->lookup_pattern($sym->get_pattern(), $soname, 1)) or
+ $ref->find_matching_pattern($sym, $soname, 1)
+ );
+ }
+ push @res, { symbol => $sym, soname => $soname } if $isnew;
+ }
+
+ # Now scan patterns
+ foreach my $p (grep { ($with_optional || ! $_->is_optional())
+ && $_->is_legitimate($self->get_arch()) }
+ $self->get_patterns($soname))
+ {
+ my $refpat = $ref->lookup_pattern($p, $soname, 0);
+ # If reference pattern was not found or it is not legitimate,
+ # considering current one as new.
+ if (not defined $refpat or
+ not $refpat->is_legitimate($self->get_arch()))
+ {
+ push @res, { symbol => $p , soname => $soname };
+ }
+ }
+ }
+ return @res;
+}
+
+sub get_lost_symbols {
+ my ($self, $ref, %opts) = @_;
+ return $ref->get_new_symbols($self, %opts);
+}
+
+
+sub get_new_libs {
+ my ($self, $ref) = @_;
+ my @res;
+ foreach my $soname ($self->get_sonames()) {
+ push @res, $soname if not $ref->get_object($soname);
+ }
+ return @res;
+}
+
+sub get_lost_libs {
+ my ($self, $ref) = @_;
+ return $ref->get_new_libs($self);
+}
+
+1;