#!/usr/bin/perl
# $OpenBSD: libtool,v 1.23 2012/07/08 10:42:25 espie Exp $

# Copyright (c) 2007-2010 Steven Mestdagh <steven@openbsd.org>
# Copyright (c) 2012 Marc Espie <espie@openbsd.org>
#
# Permission to use, copy, modify, and distribute this software for any
# purpose with or without fee is hereby granted, provided that the above
# copyright notice and this permission notice appear in all copies.
#
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

use strict;
use warnings;
use feature qw(say switch state);
use Cwd qw(getcwd);
use File::Glob ':glob';
use File::Path;

use LT::Trace;
use LT::Exec;
use LT::Util;
use LT::Getopt;

$SIG{__DIE__} = sub {
	require Carp;

	my $_ = pop @_;
	s/(.*)( at .*? line .*?\n$)/$1/s;
	push @_, $_;
	die &Carp::longmess;
};

package LT::OSConfig;

use Config;
use LT::Util;

sub new
{
    my $class = shift;
    # XXX: incomplete
    my $self = {
	machine_arch => $Config{ARCH},
	ltdir => $ltdir,
    };
    ($self->{gnu_arch} = $self->{machine_arch}) =~ s/amd64/x86_64/;

    if (grep { $_ eq $self->{machine_arch} } qw(m88k vax)) {
	$self->{noshared} = 1;
    } else {
	$self->{noshared} = 0;
    }

    bless $self, $class;
}

sub dump
{
	my $self = shift;
	while (my ($key, $value) = each(%$self)) {
		print "$key = $value\n";
	}
}

package LT::Mode;
use LT::Util;

sub new
{
	my ($class, $origin) = @_;
	# XXX autoload *if needed*.
	eval "require $class; ";
	bless {origin => $origin }, $class;
}

my $mode_maker = { compile => 'LT::Mode::Compile', 
	clean => 'LT::Mode::Clean',
	execute => 'LT::Mode::Execute',
	finish => 'LT::Mode::Finish',
	install => 'LT::Mode::Install',
	link => 'LT::Mode::Link',
	uninstall => 'LT::Mode::Uninstall' };

sub factory
{
	my ($class, $mode, $origin) = @_;
	if (defined $mode_maker->{$mode}) {
		return $mode_maker->{$mode}->new($origin);
	} else {
		shortdie "Mode=$mode not implemented yet.\n";
	}
}

package LT::Mode::Empty;
our @ISA = qw(LT::Mode);
sub run
{
	exit 0;
}
package LT::Mode::Compile;
our @ISA = qw(LT::Mode);

package LT::Mode::Clean;
our @ISA = qw(LT::Mode::Empty);

package LT::Mode::Execute;
our @ISA = qw(LT::Mode);
sub run
{
	my ($class, $ltprog, $gp, $noshared) = @_;
	# XXX check whether this is right
	LT::Exec->silent_run;
	LT::Exec->execute(@$ltprog, @main::ARGV);
}

package LT::Mode::Finish;
our @ISA = qw(LT::Mode::Empty);

package LT::Mode::Install;
our @ISA = qw(LT::Mode);

package LT::Mode::Link;
our @ISA = qw(LT::Mode);

package LT::Mode::Uninstall;
our @ISA = qw(LT::Mode::Empty);

package LT::Options;
use Getopt::Long;
use LT::Util;
our @ISA = qw(LT::Getopt);

my @valid_modes = qw(compile clean execute finish install link uninstall);

my @known_tags = qw(disable-shared disable-static CC CXX F77 FC GO GCJ RC);

sub new
{
	my $class = shift;
	my $o = bless { gp => Getopt::Long::Parser->new }, $class;
# require_order so we stop parsing at the first non-option or argument,
# instead of parsing the whole ARGV.
	$o->{gp}->configure('no_ignore_case',
	    'pass_through',
	    'no_auto_abbrev',
	    'require_order');
	return $o;
}

sub add_tag
{
	my ($self, $value) = @_;
	if ($value =~ m/[^\-\w,\/]/) {
		shortdie "invalid tag name: $value"; 
		exit 1;
	} 
	if (grep {$value eq $_} @known_tags) {
		$self->{tags}{$value} = 1;
	} else {
		say STDERR "ignoring unknown tag: $value";
	}
}

sub has_tag
{
	my ($self, $tag) = @_;
	return defined $self->{tags}{$tag};
}

sub configure
{
	my $o = shift;
	$o->{gp}->configure(@_);
}

sub getoptions
{
	my $o = shift;
	$o->{gp}->getoptions(@_);
}

sub is_abreviated_mode
{
	my ($self, $arg) = @_;
	return undef if !$arg;
	for my $m (@valid_modes) {
		next if length $arg > length $m;
		if ($arg eq substr($m, 0, length $arg)) {
			return LT::Mode->factory($m, $arg);
		}
	}
	return undef;
}

# XXX this should always fail if we are libtool2 !
# try to guess libtool mode when it is not specified
sub guess_implicit_mode
{
	my ($self, $ltprog) = @_;
	my $m;
	for my $a (@$ltprog) {
	   if ($a =~ m/(install([.-]sh)?|cp)$/) {
		$m = LT::Mode::Install->new("implicit $a");
	   } elsif ($a =~ m/cc|c\+\+/) {	# XXX improve test
		if (grep { $_ eq '-c' } @ARGV) {
			$m = LT::Mode::Compile->new("implicit");
		} else {
			$m = LT::Mode::Link->new("implicit");
		}
	   }
	}
	return $m;
}

sub valid_modes
{
	my $self = shift;
	return join(' ', @valid_modes);
}

package main;

use subs qw(
	help
	);

my $ltconfig = LT::OSConfig->new;
my $cwd = getcwd();
my $mode;
my $verbose = 1;

# just to be clear:
# when building a library:
# 	* -R libdir records libdir in dependency_libs
# 	* -rpath is the path where the (shared) library will be installed
# when building a program:
# 	* both -R libdir and -rpath libdir add libdir to the run-time path
# -Wl,-rpath,libdir will bypass libtool.

if ($mode = LT::Options->is_abreviated_mode($ARGV[0])) {
	shift @ARGV;
}

my $gp = LT::Options->new;
$gp->handle_options('-config' => \&config,
		'-debug|x' => sub { 
				LT::Trace->set(1); 
				LT::Exec->verbose_run;
			    },
		'-dry-run|-dryrun|n' => sub { LT::Exec->dry_run; },
		'-features' => sub {
			    my $v = `uname -r`;
			    chomp $v;
			    say "host: $ltconfig->{gnu_arch}-unknown-openbsd$v";
			    say "enable shared libraries" unless $ltconfig->{noshared};
			    say "enable static libraries";
			    exit 0;
			},
		'-finish' => sub { $mode = LT::Mode::Finish->new('--finish'); },
		'-help|?|h' => \&help, # does not return
		'-mode=' => sub {
				$mode = LT::Mode->factory($_[2], "--mode=$_[2]");
			    },
		'-quiet|-silent|-no-verbose' => sub { $verbose = 0; },
		'-verbose|-no-silent|-no-quiet|v' => sub {$verbose = 1;},
		'-tag=' => sub { $gp->add_tag($_[2]); },
		'-version' => sub { 
				say "libtool (not (GNU libtool)) $version" ; 
				exit 0; 
			    },
	);

if ($verbose) {
	LT::Exec->verbose_run;
}

# what are we going to run (cc, c++, ...)
my $ltprog = [];
# deal with multi-arg ltprog
tsay {"ARGV = \"@ARGV\""};
while (@ARGV) {
	# just read arguments until the next option...
	if ($ARGV[0] =~ m/^\-/) { last; }
	# XXX improve checks
	if ($ARGV[0] =~ m/^\S+\.la/) { last; }
	my $arg = shift @ARGV;
	push @$ltprog, $arg;
	tsay {"arg = \"$arg\""};
	# if the current argument is an install program, stop immediately
	if ($arg =~ /cp$/) { last; }
	if ($arg =~ /install([-.]sh)?$/) { last; }
}
tsay {"ltprog = \"@$ltprog\""};

# XXX compat game to satisfy both libtool 1 and libtool 2
# let libtool install work as both libtool 1 and libtool 2
if (@$ltprog == 0 && defined $mode && $mode->{origin} eq 'install') {
	$ltprog = [ 'install' ];
}
if (@$ltprog == 0) { die "No libtool command given.\n" .
			 "Use `libtool --help' for more information.\n" };
# make ltprog a list of elements without whitespace (prevent exec errors)
my @tmp_ltprog = @$ltprog;
@$ltprog = ();
for my $el (@tmp_ltprog) {
	my @parts = split /\s+/, $el;
	push @$ltprog, @parts;
}

if (!defined $mode) {
	$mode = $gp->guess_implicit_mode($ltprog);
	tsay {"implicit mode: ", $mode->{origin}} if $mode;
}

# from here, options may be intermixed with arguments
$gp->configure('permute');

$mode->run($ltprog, $gp, $ltconfig->{noshared});

if (LT::Exec->performed == 0) {
	die "No commands to execute.\n"
}

###########################################################################

sub help
{
	print <<EOF
Usage: $0 [options]
--config - print configuration
--debug - turn on debugging output
--dry-run - don't do anything, only show what would be done
--help - this message
--mode=MODE - use operation mode MODE
--quiet - do not print informational messages
--silent - same as `--quiet'
--tag=TAG - specify a configuration variable TAG
--version - print version of libtool
EOF
;
	exit 0;
}

sub config
{
	$ltconfig->dump;
	exit 0;
}