#!/usr/bin/perl -w

# Copyright (C) 2008 Modestas Vainius <modestas@vainius.eu>
#
# 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 3 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 <http://www.gnu.org/licenses/>

use strict;
use warnings;
use File::Spec;
use Getopt::Long;
use Dpkg::Arch qw(get_host_arch);
use Debian::PkgKde::SymHelper qw(info error warning);
use Dpkg::Shlibs::SymbolFile;

my $handlers;

######## Option processing ##################
my $opt_out;
my $opt_in;
my $opt_package;
my $opt_arch = get_host_arch();
my $opt_version;

sub verify_opt_in {
    my ($opt, $input) = @_;

    error("input file ($input) does not exit") unless (-f $input);
    $opt_in = $input;
}

sub get_common_options {
    my $args = shift;
    my (%args, %res);

    map { $args{$_} = 1 } split(//, $args);
    $res{"output|o=s"} = \$opt_out if ($args{o});
    $res{"input|i=s"} = \&verify_opt_in if ($args{i});
    $res{"package|p=s"} = \$opt_package if ($args{p});
    $res{"architecture|a=s"} = \&verify_opt_arch if ($args{a});
    $res{"version|v:s"} = \$opt_version if ($args{v});

    return %res;
}

sub check_mandatory_options {
    my $args = shift;
    my $msg = shift;
    my %args;

    $msg = "" if (!defined $msg);
    map { $args{$_} = 1 } split(//, $args);
    error("input file option (-i) is mandatory $msg") if (!$opt_in && $args{i});
    error("output file option (-o) is mandatory $msg") if (!$opt_out && $args{o});
    error("package name option (-p) is mandatory $msg") if (!$opt_package && $args{p});
    error("architecture option (-a) is mandatory $msg") if (!$opt_arch && $args{a});
    error("version option (-v) is mandatory $msg") if (!$opt_version && $args{v});

    while (@_) {
        my $val = shift;
        my $msg = shift;
        error($msg) if (!$val);
    }
    return 1;
}

############### Common subroutines #################
sub find_package_symbolfile_path {
    my ($package, $arch) = @_;
    my @PATHS = (
        "debian/$package.symbols.$arch",
        "debian/symbols.$arch",
        "debian/$package.symbols",
        "debian/symbols"
    );
    for my $path (@PATHS) {
        return $path if (-f $path);
    }
    return undef;
}

sub out_symfile {
    my $symfile = shift;
    return 1 unless $symfile;

    if ($opt_out) {
        $symfile->save($opt_out, with_deprecated => 1, template_mode => 1);
    } else {
        $symfile->dump(*STDOUT, with_deprecated => 1, template_mode => 1);
    }
    return 0;
}

############### SUBSTS ####################
my $arches64bit = qr/amd64|ia64|alpha/;

our %SUBSTITUTIONS = (
    'ssize_t' => \&subst_ssize_t,
    'size_t' => \&subst_size_t,
    'int64_t' => \&subst_int64_t,
    'uint64_t' => \&subst_uint64_t,
    'qreal' => \&subst_qreal,
    'vt' => \&subst_vt,
);

sub expand_substitutions {
    my $symbol = shift;
    my %substs;

    # Collect substitutions in the symbol name
    while ($symbol =~ /\{(([^}:]+)(?::([^}]+))?)\}/g) {
        my $subst = $1;
        my $name = $2;
        my $val = $3;
        unless (exists $substs{$name}) {
            my $subroutine = $SUBSTITUTIONS{$name};
            if (defined $subroutine) {
                $substs{$subst} = &$subroutine($name, $val, @_);
                if (!defined $substs{$subst}) {
                    error(_g("%s: unable to process symbol substitution '%s'"), $symbol, $subst);
                }
            } # If not defined, silently ignore.
        }
    }

    # Expand substitutions
    for my $subst (keys %substs) {
        $symbol =~ s/\Q{$subst}\E/$substs{$subst}/g;
    }

    return $symbol;
}

# Mangling of C++ type ssize_t:
# - long (l) on amd64, ia64, alpha, s390
# - int (i) on others
sub subst_ssize_t {
    my ($name, $val, %opts) = @_;
    return undef unless exists $opts{arch};
    return ($opts{arch} =~ /amd64|ia64|alpha|s390/) ? 'l' : 'i';
}

# Mangling of C++ type size_t:
# - unsigned long (m) on amd64, ia64, alpha, s390
# - unsigned int (j) on others
sub subst_size_t {
    my ($name, $val, %opts) = @_;
    return undef unless exists $opts{arch};
    return ($opts{arch} =~ /amd64|ia64|alpha|s390/) ? 'm' : 'j';
}

# Mangling of C++ type int64_t:
# - long (l) on 64bit arches
# - long long (x) on others (32bit arches)
sub subst_int64_t {
    my ($name, $val, %opts) = @_;
    return undef unless exists $opts{arch};
    return ($opts{arch} =~ $arches64bit) ? 'l' : 'x';
}

# Mangling of C++ type uint64_t:
# - unsigned long (m) on 64bit arches
# - unsgined long long (y) on others (32bit arches)
sub subst_uint64_t {
    my ($name, $val, %opts) = @_;
    return undef unless exists $opts{arch};
    return ($opts{arch} =~ $arches64bit) ? 'm' : 'y';
}

# Mangling of C++ type qreal:
# - float (f) on arm(el)
# - double (d) on others
sub subst_qreal {
    my ($name, $val, %opts) = @_;
    return undef unless exists $opts{arch};
    return ($opts{arch} =~ /arm/) ? 'f' : 'd';
}

# C++ virtual table offsets:
# - multiply value by 2 on 64bit arches
# - leave unchanged on 32bit arches
sub subst_vt {
    my ($name, $val, %opts) = @_;
    return undef unless exists $opts{arch} &&
           defined $val && $val =~ /^\d+$/;

    $val *= ($opts{arch} =~ $arches64bit) ? 2 : 1;
    return "$val";
}

############### Subcommands ####################
sub subcommand_create {
    info('NOT IMPLEMENTED');
    return 1;
}

sub subcommand_symbolfile {
    my %opts = (
        get_common_options("oipa"),
    );
    if (GetOptions(%opts)) {
        check_mandatory_options("i", "when package (-p) is not specified") unless ($opt_package);
        unless ($opt_in) {
            $opt_in = "debian/$opt_package.symbols.in";
            error("symbol template file '$opt_in' was not found for package '$opt_package'") unless (-r $opt_in);
        }
        # Simple symbol replacement
        my $symfile = Dpkg::Shlibs::SymbolFile->new(file => $opt_in);
        for my $soname (keys %{$symfile->{objects}}) {
            my $obj = $symfile->{objects}{$soname};
            my $syms = $obj->{syms};
            for my $name (keys %$syms) {
                my $sym = $syms->{$name};
                my $newname = expand_substitutions($sym->get_symbolname(), arch => $opt_arch);
                $sym->{symbol} = $newname;
            }
        }
        return out_symfile($symfile);
    }
    return 1;
}

sub subcommand_patch {
    info('Sorry, NOT IMPLEMENTED');
    return 1;
}

sub subcommand_postgensymbols {
    my ($infile, $outfile);
    # We can live without that
    return 0;
}

sub subcommand_resort {
    info('Sorry, NOT IMPLEMENTED');
    return 1;
}

# Boilerplate for the common subcommand handler
sub subcommand_boilerplate {
    my %opts = (
        get_common_options("oipav"),
    );
    if (GetOptions(%opts)) {
#        check_mandatory_options("o");
        return 0;
    }
    return 1;
}

my %SUBCOMMANDS = (
    "create"            => [ 1, \&subcommand_create, "create symbol file template (NOT IMPLEMENTED)" ],
    "symbolfile"        => [ 2, \&subcommand_symbolfile, "generate symbol file from the template" ],
    "patch"             => [ 3, \&subcommand_patch, "apply dpkg-gensymbols patch to the symbol file template (NOT IMPLEMENTED)" ],
    "postgensymbols"    => [ 4, \&subcommand_postgensymbols, "post-process symbols file after dpkg-gensymbols (SKIP)" ],
    "resort"            => [ 5, \&subcommand_resort, "resort symbol file (NOT IMPLEMENTED)" ],
);

my $curcmd = shift @ARGV;
if (defined $curcmd && exists $SUBCOMMANDS{$curcmd}) {
    my $ret = &{$SUBCOMMANDS{$curcmd}->[1]}();
    exit($ret);
} else {
    my $err;
    $err = ($curcmd) ? "unrecognized subcommand '$curcmd'." : "subcommand was not specified.";
    info($err . " Valid subcommands are:\n");

    for my $cmd (sort({ $SUBCOMMANDS{$a}->[0] <=> $SUBCOMMANDS{$b}->[0] }
                 keys %SUBCOMMANDS)) {
        # Display command and its short help
        info("  $cmd - " . $SUBCOMMANDS{$cmd}->[2] . "\n");
    }
    exit(2);
}
