office-gobmx/solenv/bin/relocate

:
    eval 'exec perl -S $0 ${1+"$@"}'
        if 0;
#
# This file is part of the LibreOffice project.
#
# This Source Code Form is subject to the terms of the Mozilla Public
# License, v. 2.0. If a copy of the MPL was not distributed with this
# file, You can obtain one at http://mozilla.org/MPL/2.0/.
#
# This file incorporates work covered by the following license notice:
#
#   Licensed to the Apache Software Foundation (ASF) under one or more
#   contributor license agreements. See the NOTICE file distributed
#   with this work for additional information regarding copyright
#   ownership. The ASF licenses this file to you under the Apache
#   License, Version 2.0 (the "License"); you may not use this file
#   except in compliance with the License. You may obtain a copy of
#   the License at http://www.apache.org/licenses/LICENSE-2.0 .
#
#*************************************************************************
#
#    This tool makes it easy to cleanly re-locate a
# build, eg. after you have copied or moved it to a new
# path. It tries to re-write all the hard-coded path logic
# internally.
#

sub sniff_set($)
{
    my $build_dir = shift;
    my ($dirhandle, $fname);

    opendir ($dirhandle, $build_dir) || die "Can't open $build_dir";
    while ($fname = readdir ($dirhandle)) {
	$fname =~ /Set.sh$/ && last;
    }
    closedir ($dirhandle);

    return $fname;
}

sub sed_file($$$)
{
    my ($old_fname, $function, $state) = @_;
    my $tmp_fname = "$old_fname.new";
    my $old_file;
    my $new_file;

    open ($old_file, $old_fname) || die "Can't open $old_fname: $!";
    open ($new_file, ">$tmp_fname") || die "Can't open $tmp_fname: $!";

    while (<$old_file>) {
	my $value = &$function($state, $_);
	print $new_file $value;
    }

    close ($new_file) || die "Failed to close $tmp_fname: $!";
    close ($old_file) || die "Failed to close $old_fname: $!";

    rename $tmp_fname, $old_fname || die "Failed to replace $old_fname: $!";
}

sub rewrite_value($$)
{
    my ($state, $value) = @_;

    $value =~ s/$state->{'old_root'}/$state->{'new_root'}/g;
    $value =~ s/$state->{'win32_old_root'}/$state->{'win32_new_root'}/g;

    return $value;
}

sub rewrite_set($$$)
{
    my $new_root = shift;
    my $old_root = shift;
    my $set = shift;
    my $tmp;
    my %state;

    print "   $set\n";

# unix style
    $state{'old_root'} = $old_root;
    $state{'new_root'} = $new_root;
# win32 style
    $tmp = $old_root;
    $tmp =~ s/\//\\\\\\\\\\\\\\\\/g;
    $state{'win32_old_root'} = $tmp;
    $tmp = $new_root;
    $tmp =~ s/\//\\\\\\\\/g;
    $state{'win32_new_root'} = $tmp;

    sed_file ("$new_root/$set", \&rewrite_value, \%state);
}

sub read_set($$)
{
    my $new_root = shift;
    my $set = shift;
    my $fname = "$new_root/$set";
    my $file;
    my %env_keys;

    open ($file, $fname) || die "Can't open $fname: $!";

    while (<$file>) {
	if (/\s*([^=]+)\s*=\s*\"([^\"]+)\"/) {
	    my ($name, $value) = ($1, $2);

	    $env_keys{$name} = $value;
	}
    }

    close ($file) || die "Failed to close $fname: $!";

    return \%env_keys;
}

sub sed_file_no_touch($$$)
{
    my ($new_root, $old_root, $file) = @_;
    my ($fin, $fout);

    ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
     $atime,$mtime,$ctime,$blksize,$blocks) = stat ($file);

    open ($fin, $file) || die "Can't open $fin: $!";
    open ($fout, ">$file.sed.bak") || die "Can't open $file.sed.bak: $!";
    while (<$fin>) {
	s/$old_root/$new_root/g;
	print $fout $_;
    }
    close ($fin);
    close ($fout);
    rename ("$file.sed.bak", $file);
#    print "rename $file.sed.bak to $file\n";

    utime $atime, $mtime, $file;
}

sub sed_no_touch_recursive ($$$)
{
    my ($new_root, $old_root, $dir) = @_;
    my $dh;
    opendir ($dh, $dir) || die "Can't open dir: $dir: $!";
    while (my $entry = readdir ($dh)) {
	$entry =~ /^\./ && next;
	my $path = "$dir/$entry";
	sed_no_touch_recursive ($new_root, $old_root, $path) if (-d $path);
	sed_file_no_touch ($new_root, $old_root, $path) if (-f $path);
    }
    closedir ($dh);
}

sub rewrite_product_deps($$$)
{
    my $new_root = shift;
    my $product_path = shift;
    my $old_root = shift;

    my $path = "$new_root/$product_path/misc";
    my $misc_dir;
    opendir ($misc_dir, $path) || return;
    my $name;
    while ($name = readdir ($misc_dir)) {
# Should try re-writing these - but perhaps this would
# screw with timestamps ?
	if ($name =~ m/\.dpcc$/ || $name =~ m/\.dpslo$/ || $name =~ m/\.dpobj$/) {
	    sed_file_no_touch ($new_root, $old_root, "$path/$name");
	}
    }
    closedir ($misc_dir);
}

sub rewrite_dpcc($$)
{
    my $new_root = shift;
    my $old_root = shift;

    my $top_dir;
    my $idx = 0;
    opendir ($top_dir, $new_root) || die "Can't open $new_root: $!";
    my $name;
    while ($name = readdir ($top_dir)) {
	my $sub_dir;
	opendir ($sub_dir, "$new_root/$name") || next;
	my $sub_name;
	while ($sub_name = readdir ($sub_dir)) {
	    if ($sub_name =~ /\.pro$/) {
		$idx || print "\n    ";
		if ($idx++ == 6) {
		    $idx = 0;
		}
		print "$name ";
		rewrite_product_deps ($new_root, "$name/$sub_name", $old_root);
	    }
	}
	closedir ($sub_dir);
    }
    closedir ($top_dir);
    print "\n";
}

sub rewrite_symlinks($$)
{
    my $new_root = shift;
    my $old_root = shift;

    my $dirh;
    opendir ($dirh, $new_root);
    while (my $ent = readdir ($dirh)) {
	$ent =~ /^\./ && next;
	my $link = "$new_root/$ent";
	-l $link || next;
	my $target = readlink ($link);
	my $newtarget = $target;
	$newtarget =~ s/$old_root/$new_root/;
	if ($target =~ m/$new_root/) {
	    print STDERR "skip correct link $target\n";
	} elsif ($newtarget eq $target) {
	    print STDERR "unusual - possibly stale link: $target\n";
	    if ($target =~ m/\/clone\//) { die "failed to rename link"; }
	} else {
	    print "Re-write link $target to $newtarget\n";
	    unlink ($link);
	    symlink ($newtarget, $link);
	}
    }
    closedir ($dirh);
}

sub rewrite_bootstrap($$)
{
    my $new_root = shift;
    my $old_root = shift;

    print "   bootstrap\n";

    my %state;
    $state{'old_root'} = $old_root;
    $state{'new_root'} = $new_root;

    my $rewrite = sub { my $state = shift; my $value = shift;
			$value =~ s/$state->{'old_root'}/$state->{'new_root'}/g;
			return $value; };
    sed_file ("$new_root/bootstrap", $rewrite, \%state);
    `chmod +x $new_root/bootstrap`;
}

for $a (@ARGV) {
    if ($a eq '--help' || $a eq '-h') {
	print "relocate: syntax\n";
	print "  relocate /path/to/new/ooo/source_root\n";
    }
}

$OOO_BUILD = shift (@ARGV) || die "Pass path to relocated source tree";
substr ($OOO_BUILD, 0, 1) eq '/' || die "relocate requires absolute paths";

my $set;

$set = sniff_set($OOO_BUILD) || die "Can't find env. set";
my $env_keys = read_set ($OOO_BUILD, $set);
$OLD_ROOT = $env_keys->{'SRC_ROOT'};
my $solver = $env_keys->{SOLARVER} . "/" . $env_keys->{INPATH};

print "Relocate: $OLD_ROOT -> $OOO_BUILD\n";
if ($OLD_ROOT eq $OOO_BUILD) {
    print "nothing to do\n";
    exit 0;
}

print "re-writing symlinks\n";
rewrite_symlinks($OOO_BUILD, $OLD_ROOT);

print "re-writing dependencies:\n";
rewrite_dpcc($OOO_BUILD, $OLD_ROOT);

if (-d "$solver/workdir/Dep") {
    print "re-writing new dependencies:\n";
    sed_no_touch_recursive ($OOO_BUILD, $OLD_ROOT, "$solver/workdir/Dep");
}

print "re-writing environment:\n";
rewrite_set($OOO_BUILD, $OLD_ROOT, $set);
rewrite_bootstrap($OOO_BUILD, $OLD_ROOT);

print "done.\n";