#  Copyright (c) 1997-2004
#  Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Berlin, Germany)
#  http://www.math.tu-berlin.de/polymake,  mailto:polymake@math.tu-berlin.de
#
#  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 2, or (at your option) any
#  later version: http://www.gnu.org/licenses/gpl.txt.
#
#  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.
#-----------------------------------------------------------------------------
#  $Project: polymake $$Id: install_links.pl 4714 2004-06-22 16:23:15Z gawrilow $

use strict;

my $usage="$0 [ -m MASK ] SOURCE_DIR TARGET_DIR INSTALL_TOP [ DESTDIR ]\n";
my $mask=0777;

while (@ARGV && $ARGV[0] =~ /^-/) {
   my $opt=shift;
   if ($opt eq "--") {
      last;
   }
   die $usage if !@ARGV;
   if ($opt eq "-m") {
      $mask=oct shift;
      next;
   }
   die "$0: unknown option: $opt\n$usage";
}

die $usage if @ARGV<3 || @ARGV>4 || !-d $ARGV[0] || !-d $ARGV[1] || !-d $ARGV[2];

my ($from, $to, $top, $destdir)=(@ARGV);
$from eq $to and exit 0;

if ($from =~ s"^\Q$top\E/?"" && $to =~ s"^\Q$top\E/?"") {
   while ((my ($dir, $rest)= split(m"/", $to, 2)) == 2) {
      if ($from =~ s"^\Q$dir\E/"") {
         $to=$rest;
      } else {
         last;
      }
   }
   $to =~ s"[^/]+".."g;
   $from="$to/$from";
   $to=$ARGV[1];
} else {
   $from=$ARGV[0];
   if (defined $destdir) {
      $destdir =~ s"/+$"";
      $from =~ s"^\Q$destdir\E"";
   }
}

opendir D, "$ARGV[0]"  or  die "$0: can't traverse $ARGV[0]: $!\n";
foreach my $f (readdir D) {
   if (-f "$ARGV[0]/$f"  and  (stat(_))[2]&$mask) {
      unlink "$to/$f";
      symlink "$from/$f", "$to/$f"
      or die "$0: can't create $to/$f: $!\n";
   }
}