#  Copyright (c) 1997-2006
#  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.pl,v 1.27 2006/01/12 17:31:54 gawrilow Exp $

use strict;
use vars qw( $makedir $usage $strip $global_exclude $global_exclude_re $exclude_re
	     $translate_re $translate_back_re $copylink_re %make_vars
	     $Unlink $modemask $group $Perl
	   );
use POSIX qw ( :fcntl_h read write lseek );
use Config;

my ($support_dir)= $0=~m|^(.*/)[^/]+$|;
require "${support_dir}make2perl.pl";

$usage=<<".";
usage: $0 [ -m MODE ] [ -g GROUP ] [ -{X,L} pattern ... ] [ -T old:new ] [ -s ] [ -U ] [ -P /path/bin/perl ] SOURCE TARGET
   or: $0 [ -m MODE ] [ -s ] SOURCE_FILE ... TARGET_DIRECTORY
   or: $0 
   or: $0 -d [ -m MODE ] [ -U ] DIRECTORY ...
.

sub check {
   my ($file)=@_;
   if (-e $file) {
      if (!-f $file and !-l $file) {
	 warn "$0: $file is neither a regular file nor a symbolic link\n";
	 return 0;
      }
   } else {
      warn "$0: $file does not exist\n";
      return 0;
   }
   1;
}

sub basename {
   $_[0]=~m|([^/]+)$|;
   $1;
}

sub copy {
   my ($from, $to, $mode)=@_;
   if (defined $translate_re) {
      my $other_from=$from;
      return 1 if $other_from =~ s/$translate_back_re/$^R/  and  -e $other_from;
      $to =~ s/$translate_re/$^R/;
   }
   if (!$Unlink and -e $to) {
      unless (unlink $to) {
	 warn "$0: can't remove old $to: $!\n";
	 return 0;
      }
   }
   if (-l $from) {
      my $target=readlink($from);
      if ($target !~ $copylink_re) {
	 unless (symlink $target, $to) {
	    warn "$0: can't create $to -> $from: $!\n";
	    return 0;
	 }
	 return 1;
      }
   }
   my ($fmode, $mtime)=(stat $from)[2,9];
   if (defined $mode) {
      # verbatim copy - assuming binary file
      my $in=POSIX::open $from, O_RDONLY;
      if (!defined $in) {
	 warn "$0: can't read $from: $!\n";
	 return 0;
      }
      my $dummy=O_WRONLY+O_CREAT+O_TRUNC; # bug in AutoLoader!
      my $out=creat $to, 0600;
      if (!defined $out) {
	 warn "$0: can't create $to: $!\n";
	 return 0;
      }

      while ((my $size=read $in, $_, 1024)>0) {
	 if ($_ eq "\0"x$size) {
	    lseek $out, $size, SEEK_CUR;
	 } else {
	    write $out, $_, $size;
	 }
      }
      POSIX::close $in;
      POSIX::close $out;
      system "strip $to" if $strip;
   } else {
      # text file
      $mode=$fmode;
      unless (open X, "<", $from) {
	 warn "$0: can't read $from: $!\n";
	 return 0;
      }
      $_=<X>; close X;
      if ($mode & 0111) {
	 s|^#!\S+/perl\b|$Perl|s;
	 $mode=0555;
      } else {
	 $mode=0444;
      }
      unless (open X, ">", $to) {
	 warn "$0: can't create $to: $!\n";
	 return 0;
      }
      print X; close X;
      $mode&=$modemask;
   }
   utime $mtime, $mtime, $to
      and
   chmod $mode, $to
      and
   do {
      !defined $group
      or chown -1, $group, $to
      or do {
	 warn "$0: can't change group of $to: $!\n";
	 0
      }
   }
}

sub make_dir {
   my ($dir, $mode)=@_;
   if (-e $dir) {
      if (-d _) {
	 if (defined $mode and ((stat _)[2] & 03777) != $mode) {
	    unless (chmod $mode, $dir) {
	       warn "$0: can't change mode of $dir: $!\n";
	       return 0;
	    }
	 }
	 if (defined $group and (stat _)[5] != $group) {
	    unless (chown -1, $group, $dir) {
	       warn "$0: can't change group of $dir: $!\n";
	       return 0;
	    }
	 }
	 if ($Unlink) {
	    opendir D, $dir;
	    foreach (readdir D) {
	       if ($_ !~ $exclude_re  and  -l "$dir/$_" || -f _) {
		  unless (unlink "$dir/$_") {
		     warn "$0: can't remove old $dir/$_: $!\n";
		     return 0;
		  }
	       }
	    }
	    closedir D;
	 }
      } else {
	 warn "$0: $dir is not a directory\n";
	 return 0;
      }
      return 1;
   }
   my @path=split m|/|, $dir;
   my $accumulated=".";
   if ($path[0] eq "") {
      $accumulated="";
      shift @path;
   }
   foreach my $p (@path) {
      $accumulated.="/$p";
      if (-e $accumulated) {
	 next if -d _;
	 warn "$0: $accumulated is not a directory\n";
	 return 0;
      }
      unless (mkdir $accumulated, $mode) {
	 warn "$0: can't create $accumulated: $!\n";
	 return 0;
      }
   }
   1;
}

sub copy_dir {
   my ($src, $dst, $dirmode)=@_;
   unless (opendir S, $src) {
      warn "$0: can't traverse $src: $!\n";
      return 0;
   }

   local %make_vars;
   process_dot_export($src);
   my $no_install=make2perl_filename(".export $make_vars{NoInstall}");
   local $exclude_re= defined($no_install) ? qr{$global_exclude|$no_install} : $global_exclude_re;

   make_dir($dst,$dirmode) or return 0;
   foreach my $f (grep { $_ !~ $exclude_re } readdir S) {
      if (-d "$src/$f") {
	 copy_dir("$src/$f", "$dst/$f", $dirmode) or return 0;
      } else {
	 copy("$src/$f", "$dst/$f") or return 0;
      }
   }
   closedir S;
   1;
}

$makedir=$strip=$Unlink=0;
$modemask=0777;
undef $/;
my ($mode, $dirmode, %patterns);

while (@ARGV && $ARGV[0] =~ /^-/) {
   my $opt=shift;
   if ($opt eq "--") {
      last;
   }
   if ($opt eq "-d") {
      $makedir=1;
      next;
   }
   if ($opt eq "-U") {
      $Unlink=1;
      next;
   }
   if ($opt eq "-s") {
      $strip=1;
      next;
   }
   die $usage if !@ARGV;
   if ($opt eq "-m") {
      $mode=oct shift;
      next;
   }
   if ($opt eq "-g") {
      $_=shift;
      defined($group=getgrnam($_))
      or die "$0: unknown group '$_'\n";
      next;
   }
   if ($opt =~ "-[XTL]") {
      $_=shift;
      s/\./\\./g;  s/\?/./g;  s/\*/.*/g;
      push @{$patterns{$opt}}, $_;
      next;
   }
   if ($opt eq "-P") {
      $Perl=shift;
      die "$Perl is not an executable" unless substr($Perl,0,1) eq '/' and -x $Perl;
      next;
   }
   die "$0: unknown option: $opt\n$usage";
}

die $usage if $makedir && keys %patterns
           or @ARGV < 2-$makedir;
die "$0: can't strip non-executables\n" if $strip and !defined($mode) || !($mode & 0111);

if ($makedir) {
   if (defined $mode) {
      umask 0;
   } else {
      $mode=0777&~umask;
   }
   map { make_dir($_,$mode) or exit 1 } @ARGV;
} else {
   if (defined $mode) {
      umask 0;
   } else {
      $mode=0666&~umask;
   }

   if (defined $Perl) {
      $Perl="#!$Perl";
   } else {
      $Perl=$Config::Config{startperl};
   }

   if (-d $ARGV[0]) {
      die $usage if @ARGV > 2;
      $dirmode=$mode|0200;
      undef $mode;
      $modemask=$dirmode&0111;
      $modemask|=$modemask<<2;
      $global_exclude=join('|', map { "(?:^$_\$)" } (@{$patterns{'-X'}}, qw( \. \.\. \.\#.* )));
      $global_exclude_re=qr/$global_exclude/;
      if ($patterns{'-T'}) {
	 use re 'eval';
	 my $translate=join('|', map { my ($from,$to)=split /:/; "(?:$from(?{\"$to\"}))" } @{$patterns{'-T'}});
	 my $translate_back=join('|', map { my ($from,$to)=split /:/; "(?:$to(?{\"$from\"}))" } @{$patterns{'-T'}});
	 $translate_re=qr/$translate/;
	 $translate_back_re=qr{(?=[^/]+$)(?:$translate_back)};
      }
      my $copylink=join('|', qw(/), exists $patterns{'-L'} ? @{$patterns{'-L'}} : ());
      $copylink_re=qr/^(?:$copylink_re)/;
      copy_dir(@ARGV, $dirmode) or exit 1;
   } else {
      die $usage if $Unlink or $patterns{'-X'} or $patterns{'-L'};
      if (-d $ARGV[-1]) {
	 my $dst=pop @ARGV;
	 if (-w _) {
	    foreach my $src (@ARGV) {
	       check($src) && copy($src, "$dst/".basename($src), $mode) or exit 1;
	    }
	 } else {
	    die "$0: target directory $dst not writable\n";
	 }
      } elsif (@ARGV==2) {
	 check($ARGV[0]) && copy(@ARGV,$mode) or exit 1;
      } else {
	 die $usage;
      }
   }
}
