#!/usr/bin/env perl
# Copyright 2011, 2012 Alexandre Rostovtsev <tetromino@gentoo.org>
#
# This program is free software; you may redistribute it and/or modify it
# under the same terms as Perl itself.
use strict;
use warnings;

my $pod=q{
=head1 NAME

fix-la-relink-command - fixes relink_command field of .la files in a build tree

=cut
};
my $pod_synopsis=q{
=head1 SYNOPSIS

B<fix-la-relink-command> [I<OPTIONS>] [I<LAFILES> or I<DIRECTORIES>]

=cut
};
$pod .= $pod_synopsis . q{
=head1 DESCRIPTION

B<fix-la-relink-command> modifies the relink_command field of libtool .la
files to ensure that during the relinking stage of C<make install>, the
corresponding library is linked to libraries in the local build tree and
not to the versions of the same libraries that are installed systemwide.

Specifically, for every .la file in a relative directory $dir that is
specified in relink_command, B<fix-la-relink-command> adds an extra
C<-L$dir/.libs> argument, and puts these arguments before the first
relative .la file or -L argument with an absolute path.

For example,

    relink_command="(cd /tmp/foo/libfoo; /bin/sh /tmp/foo/libtool --silent --tag CC --mode=relink gcc -O2 foo.lo bar/libbar.la ../baz/libbaz.la /usr/lib/libfrob.la -lm)"

will become

    relink_command="(cd /tmp/foo/libfoo; /bin/sh /tmp/foo/libtool --silent --tag CC --mode=relink gcc -O2 foo.lo -Lbar/.libs -L../baz/.libs bar/libbar.la ../baz/libbaz.la /usr/lib/libfrob.la -lm)"

=cut
};
my $pod_options = q{
=head2 Options

=over

=item B<-h>, B<--help>

Show usage information and exit.

=item B<-m>, B<--manual>

Show manual page and exit.

=item B<-q>, B<--quiet>

Do not print messages.

=item B<-v>, B<--version>

Show version information and exit.

=back

=cut
};
my $pod_arguments = q{
=head2 Arguments

If names of .la files are given, they are processed. If names of directories
are given, .la files in them are processed recursively, but hidden or
symlinked subdirectories will not be recursed into.

=cut
};
$pod .= $pod_options . $pod_arguments . q{
=head1 RESTRICTIONS

It is assumed that relink_command is one line. It is assumed that any spaces
in paths are escaped using '\'.

=head1 COPYRIGHT AND LICENSE

Copyright 2011, 2012 Alexandre Rostovtsev <tetromino@gentoo.org>

This program is free software; you may redistribute it and/or modify it
under the same terms as Perl itself.

=head1 SEE ALSO

The GNU libtool manual, L<http://www.gnu.org/software/libtool/manual/libtool.html>

=cut
};

use Cwd qw(realpath);
use File::Basename;
use File::Find;
use Getopt::Long;

my $RELEASE = '0.1';
my $RELEASE_DATE = '2012-05-26';
my $QUIET = 0;

my %processed = ();
sub process_la_file {
    my $filename = $_; # relative to cwd
    my $pretty_filename = $File::Find::name; # relative to initial cwd
    if (-d $filename) { return; }

    # don't process a single .la file multiple times (e.g. if symlinked)
    my $realpath = realpath($filename);
    if ($processed{$realpath}) {
        print "$pretty_filename ($realpath) was already processed\n" unless $QUIET;
	return;
    } else {
        $processed{$realpath}++;
    }

    # preserve the .la file's mtime in order to avoid triggering make rules
    my $mtime = (stat $filename)[9];
    open(my $fh, '<', $filename) or die $!;
    my $text;
    my $changes; # whether the file has been changed
    while (<$fh>) {
        if (/relink_command=/) {
            my ($start, $added, $end);
	    my $ignore = 0; # number of words to not check for similariy to
	                    # an .la filename, following and including the
                            # current word
	    # split by unescaped spaces
	    for my $word (split /(?<!\\) /) {
	        if ($word =~ /^-/) {
                    # ignore command-line options; ignore filename after -o
                    $ignore++;
                    $ignore++ if $word eq '-o' ;
                }
	    	if ($word =~ m:^[^/].*\.la\W*$: and not $ignore) {
                    $added .= "-L" . dirname($word) . "/.libs ";
                    $end .= "$word ";
                    $changes++;
                } else {
                    if ($end) {
                        $end .= "$word ";
                    } else {
                        if ($word =~ m:^-L/:) {
                            # If we have just seen -L(absolute path), then any
                            # -L(relative path) arguments we want to add need
                            # to go before it.
                            $end .= "$word ";
                        } else {
                            $start .= "$word ";
                        }
                    }
                }
                $ignore-- if $ignore > 0;
	    }
	    $_ = "$start$added$end";
            print "Added '$added' to relink_command in $pretty_filename\n" if $changes and not $QUIET;
	}
	$text .= $_;
    }
    close $fh;
    if ($changes) {
        open($fh, '>', $filename) or die $!;
        print $fh $text;
        close $fh;
        # Perl's utime does not support sub-second time :/
        # And Time::HiRes doesn't help. As a workaround, round up the number of
        # seconds in order to avoid triggering make rules.
        utime $mtime + 1, $mtime + 1, $filename;
    }
}

sub die_usage() {
    use Pod::Text; # easier to use on strings than Pod::Usage
    my $usage = $pod_synopsis;
    $usage =~ s/SYNOPSIS/Usage/;
    $usage =~ s/I<([^>]+)>/$1/g; # Don't surround I<> test with **
    my $parser = new Pod::Text();
    $parser->output_fh(*STDERR);
    $parser->parse_string_document($usage);
    exit 1;
}

my ($help, $man, $ver) = (0, 0, 0);

GetOptions(
    "help" => \$help,
    "manual" => \ $man,
    "quiet" => \$QUIET,
    "version" => \$ver);

if ($help) {
    use Pod::Text; # easier to use on strings than Pod::Usage
    my $usage = $pod_synopsis . $pod_options . $pod_arguments;
    $usage =~ s/SYNOPSIS/Usage/;
    $usage =~ s/I<([^>]+)>/$1/g; # Don't surround I<> test with **
    Pod::Text->filter(\$usage);
    exit 0;
} elsif ($man) {
    use Pod::Usage;
    $ENV{PERLDOC} .= " -w center=' ' -w release='fix-la-relink-command v$RELEASE' -w date=$RELEASE_DATE -w quotes='none'";
    pod2usage({-verbose => 2, -exitval => 0, quotes => "none"});
} elsif ($ver) {
    print "fix-la-relink-command v$RELEASE ($RELEASE_DATE)\n" and exit 0;
}

die_usage() unless @ARGV;

find({ wanted => \&process_la_file,
       preprocess => sub {grep { if (-d $_) { /^[^.]/ } else { /\.la$/ } } sort @_}
     }, @ARGV);

die_usage() unless keys %processed;
