#! perl
# Copyright (C) 2004-2007, The Perl Foundation.
# $Id: nm.pl 21451 2007-09-21 09:33:44Z paultcochrane $

=head1 NAME

tools/dev/nm.pl - Display symbol table information

=head1 SYNOPSIS

    % perl tools/dev/nm.pl [options] file

To list all the symbols in Parrot:

    % perl tools/dev/nm.pl parrot

=head1 DESCRIPTION

Portable frontend for C<nm(1)>; by default lists all the code and data
symbols in the object or archive files.

=head2 Command-Line Options

The following options can be used to limit the symbols:

=over 4

=item C<--code>

=item C<-c>

List the code/text symbols.

=item C<--data>

=item C<-d>

List the data symbols.

=item C<--init>

=item C<-i>

List the initialised data symbols.

=item C<--uninit>

=item C<-u>

List the uninitialised data symbols.

=item C<--const>

=item C<-C>

List the constant (read-only) data symbols.

Not all platforms support this, a warning will be given if not. You can
try GNU C<nm> if you want this feature.

=item C<--undef>

=item C<-U>

List the undefined symbols.

=item C<--def>

=item C<-D>

List the defined symbols.

=item C<--file>

=item C<-f>

List the file(name) symbols.

=back

If more than one of all the above options are given, they are C<AND>ed.
They can also be negated with a "no", for example C<--noconst>.

=over 4

=item C<--objectname>

=item C<-o>

Prepend the object name before the symbol name.

=item C<--t>

Append the short BSD-style type to the symbol name.

    B - uninitialised data symbol
    D - initialised data symbol
    F - file name symbol
    R - read-only data symbol
    T - code/text symbol
    U - undefined symbol

Uppercase indicates that the symbol is global; lowercase indicates that
it is local.

=item C<--type=bsd>

=item C<-B>

The same as C<--t>.

=item C<--type=long>

=item C<-L>

Append a long type (e.g. "global_const_init_data" versus "R") to the
symbol name.

=item C<--help>

Show the help.

=item C<--version>

Show the version number.

=back

All the options can be shortened to their unique prefixes, and one
leading dash ("-") can be used instead of two ("--").

=cut

use strict;
use warnings;
use Getopt::Long;
use File::Basename;

use vars qw($VERSION);

require 5.005;

$VERSION = sprintf "%d.%d", q$Revision: 21451 $ =~ /(\d+)/g;    # jhi@iki.fi;

my $ME       = basename($0);
my $RCS_DATE = q$Date: 2007-09-21 10:33:44 +0100 (Fri, 21 Sep 2007) $;

my $nm_cmd = 'nm';
my $nm_opt = '';
my $nm_try = qx(nm -V 2>&1);
my $nm_gnu;
my $nm_ro;    # can tell apart read-only (const) data sections

my (
    $Code,   $Data,  $Init,  $Uninit, $Const, $Mutable,
    $Global, $Local, $Undef, $Def,    $File,  $ObjectName,
    $Type,   $BSD,   $Long,  $Help,   $Version
);

sub show_version {
    print "$ME: $VERSION ( $RCS_DATE)\n";
}

sub show_help {
    print <<__EOF__;
$ME: Usage: $ME [options] [ foo.o ... | bar.a | other_library_format ]
Portable frontend for nm(1); by default lists all the code and data symbols
in the object or archive files.  The options can be used to limit the symbols:
--code|-c       code/text symbols (Tt)
--data|-d       data symbols (Dd, Bb)
--init|-i       initialised data symbols (Dd)
--uninit|-u     uninitialised data symbols (Bb)
--local|-l      local symbols (tdbruf)
--global|-g     global symbols (TDBRUF)
--const|-C      const (read-only) data symbols (Rr) [1]
--undef|-U      undefined symbols (Uu)
--def|-D        defined symbols (not Uu)
--file|-f       file(name) symbols (Ff)
If more than one of all the above options are given, they are ANDed.
They can also be negated with a "no", for example --noconst.
[1] Not all platforms support this, a warning will be given if not.
    You can try GNU nm if you want this feature.
--objectname|-o prepend the object name before the symbol name
--t             append the short BSD-style type (in parentheses above)
--type=bsd|-B   same as --t
--type=long|-L  append a long type (e.g. "global_const_init_data" versus "R")
--help|-h       show this help
--version|-v    show version
All the options can be shortened to their unique prefixes,
and one leading dash ("-") can be used instead of two ("--").
__EOF__
}

if ( $^O eq 'solaris' && $nm_try =~ /Solaris/ ) {
    $nm_opt = '-p';
}
elsif ( $^O eq 'hpux' && $nm_try =~ /linker command|HP-UX/ ) {
    $nm_opt = '-p';
}
elsif ( $^O eq 'aix' && $nm_try =~ /illegal option/ ) {
    $nm_opt = '-B';
}
elsif ( $^O eq 'irix' && $nm_try =~ /C Development Set/ ) {
    $nm_opt = '-B';
    $nm_ro  = 1;
}
elsif ( $^O eq 'dec_osf' && $nm_try =~ /Alpha/ ) {    # aka Tru64 aka DEC OSF/1
    $nm_opt = '-B';
    $nm_ro  = 1;
}
elsif ( $^O eq 'darwin' && $nm_try =~ /invalid argument/ ) {
    $nm_opt = '';
}
elsif ( $nm_try =~ /GNU nm/ ) {
    $nm_opt = '';
    $nm_gnu = 1;
    $nm_ro  = 1;
}
else {

    # Hope for BSD-style nm output.
}

Getopt::Long::Configure("bundling");

unless (
    GetOptions(
        'code|c!'      => \$Code,
        'data|d!'      => \$Data,
        'init|i!'      => \$Init,
        'uninit|u!'    => \$Uninit,
        'const|C!'     => \$Const,
        'global|g!'    => \$Global,
        'local|l!'     => \$Local,
        'undef|U!'     => \$Undef,
        'def|D!'       => \$Def,
        'file|f!'      => \$File,
        'objectname|o' => \$ObjectName,
        't'            => \$Type,
        'bsd|B'        => \$BSD,
        'long|L'       => \$Long,
        'type:s'       => \$Type,
        'help|h'       => \$Help,
        'version|v'    => \$Version,
    )
    )
{
    show_help();
    exit(1);
}

if ( $Const && !$nm_ro ) {
    warn "$ME: the native nm cannot tell apart const data sections\n";
}

if ($Version) {
    show_version();
    exit(0);
}

if ($Help) {
    show_help();
    exit(0);
}

unless (@ARGV) {
    show_help();
    exit(1);
}

sub warn_if_both {
    my ( $a, $b, $sa, $sb ) = @_;
    if ( defined $a && defined $b && $a == $b ) {
        warn "$ME: both --$sa and --$sb used\n";
    }
}

warn_if_both( $Code,   $Data,   'code',   'data' );
warn_if_both( $Global, $Local,  'global', 'local' );
warn_if_both( $Init,   $Uninit, 'init',   'uninit' );
warn_if_both( $Def,    $Undef,  'def',    'undef' );

$Undef ||= !$Def if defined $Def && !defined $Undef;

my %Type;
@Type{qw(bsd long)} = ();
$Type = 'bsd'
    if $BSD
        || ( defined $Type && $Type eq '1' );    # So they used --t.
$Type = 'long' if $Long;
die "$ME: --type=$Type unknown\n"
    if defined $Type && $Type ne '' && !exists $Type{$Type};

my $TypeLong = defined $Type && $Type eq 'long';

for my $f (@ARGV) {
    unless ( -f $f ) {
        warn "$ME: No such file: $f\n";
        next;
    }
    if ( open( my $NM, '<', "$nm_cmd $nm_opt $f |" ) ) {
        my $o = '?';
        $o = $f if $f =~ /\.o$/;
        my $file;
        while (<$NM>) {
            chomp;
            if ( m/^(.+\.o):$/ || m/\[(.+\.o)\]:$/ || m/\((.+\.o)\):$/ ) {
                $o = $1;
            }
            elsif (/ ([A-Za-z]) \.?(\w+)$/) {

                # Especially text symbols are sometimes prefixed by a ".".
                my ( $type, $name ) = ( $1, $2 );

                # The following are assumed to work Everywhere.
                my $absolute = ( $type =~ /^[Aa]$/ )   ? 1 : 0;
                my $uninit   = ( $type =~ /^[BbCc]$/ ) ? 1 : 0;
                my $init     = ( $type =~ /^[DdGg]$/ ) ? 1 : 0;
                my $file     = ( $type =~ /^[Ff]$/ )   ? 1 : 0;
                my $small    = ( $type =~ /^[Gg]$/ )   ? 1 : 0;
                my $code     = ( $type =~ /^[Tt]$/ )   ? 1 : 0;
                my $undef    = ( $type =~ /^[Uu]$/ )   ? 1 : 0;
                my $zeroed   = 0;
                my $const    = 0;
                my $local = $type eq lc $type ? 1 : 0;
                my $other = 0;

                if ( ( $^O eq 'irix' || $^O eq 'dec_osf' )
                    && $type =~ /^[BbSs]$/ )
                {
                    if ( $type =~ /^[Ss]$/ ) {
                        $small  = 1;
                        $uninit = 1;
                    }
                    $zeroed = 1;
                }
                if ( $^O eq 'irix' && $type =~ /^[Rr]$/ ) {
                    $const = 1;
                    $init  = 1;
                }
                if ( $^O eq 'dec_osf' ) {
                    if ( $type eq 'E' ) {
                        $small = 1;
                    }
                    elsif ( $type =~ /^[RrQq]$/ ) {
                        $const = 1;
                        $init  = 1;
                    }
                }
                if ( $^O eq 'darwin' ) {
                    $other = 1;
                }
                if ($nm_gnu) {
                    if ( $type =~ /^[Rr]$/ ) {
                        $const = 1;
                        $init  = 1;
                    }
                    elsif ( $type =~ /^[Ss]$/ ) {
                        $small  = 1;
                        $uninit = 1;
                    }
                }
                if ( $type =~ /^[ABCDFGQRSTU]$/i ) {
                    unless ( $undef || $code || $other || $absolute ) {
                        if ( $init && $uninit ) {
                            warn "$.:$_: both init and uninit?\n";
                        }
                        elsif ( !$init && !$uninit ) {
                            warn "$.:$_: neither init and uninit?\n";
                        }
                    }
                }
                my $data   = ( $uninit || $init ) && !$code;
                my $global = !$local;
                my $show   = 1;

                sub want_show {
                    my ( $show, $Got, $got ) = @_;
                    if ( defined $Got ) {
                        if ( $Got == $got ) {
                            $$show++;
                        }
                        else {
                            $$show = 0;
                        }
                    }
                }
                want_show( \$show, $Code,   $code )   if $show;
                want_show( \$show, $Data,   $data )   if $show;
                want_show( \$show, $Init,   $init )   if $show;
                want_show( \$show, $Uninit, $uninit ) if $show;
                want_show( \$show, $Const,  $const )  if $show;
                want_show( \$show, $Global, $global ) if $show;
                want_show( \$show, $Local,  $local )  if $show;
                want_show( \$show, $Undef,  $undef )  if $show;
                want_show( \$show, $File,   $file )   if $show;

                if ($show) {
                    $show = $ObjectName ? "$o\t$name" : $name;
                    if ( defined $Type ) {
                        $show .= "\t";
                        my $symbol;
                        if ($code) {
                            $symbol = $TypeLong ? "code" : "T";
                        }
                        elsif ($data) {
                            if ($const) {
                                $symbol = $TypeLong ? "const_init" : "R";
                            }
                            elsif ($init) {
                                $symbol = $TypeLong ? "init" : "D";
                            }
                            elsif ($uninit) {
                                $symbol = $TypeLong ? "uninit" : "B";
                            }
                            else {
                                $symbol = $TypeLong ? "unknown" : "D?";
                            }
                            $symbol .= "_data" if $TypeLong;
                        }
                        elsif ($undef) {
                            $symbol = $TypeLong ? "undef" : "U";
                        }
                        else {
                            $symbol = $TypeLong ? "unknown" : "?";
                        }
                        if ($TypeLong) {
                            $show .= $global ? "global_$symbol" : "local_$symbol";
                        }
                        else {
                            $show .= $global ? $symbol : lc $symbol;
                        }
                    }
                    print $show, "\n";
                }
            }
        }
        close($NM);
    }
    else {
        warn "$ME: '$nm_cmd $nm_opt $f' failed: $!\n";
    }
}

exit(0);

=head1 HISTORY

Author: Jarkko Hietaniemi.

=cut

# Local Variables:
#   mode: cperl
#   cperl-indent-level: 4
#   fill-column: 100
# End:
# vim: expandtab shiftwidth=4: