#  Copyright (c) 2018
#  Charles Jordan (Hokkaido University, Sapporo, Japan),
#  Michael Joswig, Lars Kastner (Technische Universitaet Berlin, Germany)
# 
#  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 3, 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.
#-------------------------------------------------------------------------------

use strict;
use feature 'state';
use vars qw( $dirmode $group $permmask $root $ext_root $buildroot $config_file %ConfigFlags $buildmode
             $xsmod @callable @fakelibs );
use POSIX qw ( :fcntl_h read write lseek );
use File::Path;
use Config;

use Getopt::Long qw( GetOptions :config require_order no_ignore_case );

sub collect_arglist {
   my $list=shift;
   @$list=@_;
   while (@ARGV && $ARGV[0] !~ /^-/) {
      push @$list, shift @ARGV;
   }
}


unless (GetOptions( 'root=s' => \$root,
                    'buildroot=s' => \$buildroot,
                    'config=s' => \$config_file,
                    'mode=s' => \$buildmode,
                    'group=s' => \$group,
                    'perms=i' => \$permmask,
                    ) &&
        !@ARGV &&
        defined($config_file) &&
        defined($root) &&
        defined($buildroot) &&
        defined($buildmode) &&
        -f $config_file &&
        -d $root &&
        -d "$buildroot/$buildmode")
                            {
   die <<".";
usage: $0 --root PATH --buildroot PATH --config PATH/config.ninja 
          --buildmode Opt|Debug [ --group GROUP ] [ --perms MASK ] 
.
}

if (defined $group) {
   my $gid=getgrnam($group)
     or die "$0: unknown group '$group'\n";
   $group=$gid;
}

do "$root/support/install_utils.pl";
die $@ if $@;
%ConfigFlags=load_config_file($config_file, $root);
my @BundledExts= $ConfigFlags{BundledExts} =~ /(\S+)/g;

my @default_exclude_for_copy=qw( \. \.\. \.\#.* .*~ \.git.* \.noexport );

# these variables may be used in sourced extension scripts
use vars qw($InstallTop $InstallInc $InstallArch $InstallBin $InstallLib $InstallDoc $builddir $ExtTop $ExtArch);

foreach (qw(InstallTop InstallInc InstallArch InstallBin InstallLib InstallDoc)) {
   no strict 'refs';
   ${$_}=$ConfigFlags{$_};
}
$builddir="$buildroot/$buildmode";

my $destdir = $ENV{DESTDIR} // $ConfigFlags{DESTDIR};
$destdir =~ s{/$}{};
if (length($destdir)) {
   foreach ($InstallTop, $InstallInc, $InstallArch, $InstallBin, $InstallLib, $InstallDoc) {
      substr($_,0,0) .= $destdir;
   }
}

if (defined $permmask) {
   if (($permmask & 0700) != 0700) {
      die "--perms must allow full access to the file owner\n";
   }
   umask 0;
   $dirmode=0777 & $permmask;
} else {
   $permmask=0777&~umask;
}

make_dir($InstallBin);
foreach my $file(glob "$builddir/bin/*"){
   my $name = basename($file);
   copy_file("$file", "$InstallBin/$name");
}




sub copy_file {
   my ($from, $to, %options)=@_;
   if (-e $from) {
      if (!-f $from and !-l $from) {
         die "$0: $from is neither a regular file nor a symbolic link\n";
      }
   } else {
      die "$0: $from does not exist\n";
   }
   if ($options{clean_dir}) {
      make_dir(dirname($to), clean_dir => 1);
   } elsif (-d $to) {
      $to .= "/" . basename($from);
   }
   copy($from, $to, %options);
}



sub compile_pattern {
   my $expr=join('|', map { "(?:^$_\$)" } @_);
   qr/$expr/;
}


my $z1024=pack "x1024";

sub copy {
   my ($from, $to, %options)=@_;
   my $concat;
   my $mode=$options{mode};

   if (-e $to) {
      if (defined (my $conflict=$options{conflict})) {
         foreach my $c (@$conflict) {
            if ($to =~ $c->[0]) {
               if ($c->[1] eq 'abort') {
                  die "$0: can't install $from: file $to already exists\n";
               } elsif ($c->[1] eq 'concat') {
                  $concat=1;
               } elsif ($c->[1] eq 'keep') {
                  return;
               } elsif ($c->[1] ne 'replace') {
                  die "$0: unknown conflict action $c->[1]\n";
               }
               last;
            }
         }
      }
      unless ($concat || unlink $to) {
         die "$0: can't remove old $to: $!\n";
      }
   }
   my ($fmode, $mtime)=(stat $from)[2,9];
   if (defined $mode) {
      # verbatim copy: assuming binary file
      my $in=POSIX::open $from, O_RDONLY;
      defined($in)
         or die "$0: can't read $from: $!\n";
      my $dummy=O_WRONLY+O_CREAT+O_TRUNC; # bug in AutoLoader!
      my $out;
      if ($concat) {
         open $out, ">>$to";
      } else {
         $out=creat $to, 0600;
      }
      defined($out)
         or die "$0: can't create $to: $!\n";

      my $trailing_zeroes;
      while ((my $size=read $in, $_, 1024)>0) {
         if ($_ eq ($size==1024 ? $z1024 : pack("x$size"))) {
            lseek $out, $size, SEEK_CUR;
            $trailing_zeroes=1;
         } else {
            write $out, $_, $size;
            $trailing_zeroes=0;
         }
      }
      if ($trailing_zeroes) {
         lseek $out, -1, SEEK_CUR;
         write $out, "\0", 1;
      }
      POSIX::close $in;
      POSIX::close $out;

      if (my $lib_id=$options{lib_id}) {
         substr($lib_id, 0, length($destdir))="";
         system("install_name_tool -id $lib_id $to")
           and die "install_name_tool $to failed\n";
      }
   } else {
      # text file: turn on write protection
      $mode=$fmode & 0555;
      local $/;
      open X, "<", $from
         or die "$0: can't read $from: $!\n";
      $_=<X>; close X;
      if (defined (my $transform=$options{transform})) {
	 &$transform;
      }
      open X, ">", $to
         or die "$0: can't create $to: $!\n";
      print X; close X;
   }
   $mode &= $permmask;
   chmod $mode, $to
     or die "can't modify access rights to $to: $!\n";
   if (defined $group) {
      chown -1, $group, $to
        or die "$0: can't change group of $to: $!\n";
   }
   utime $mtime, $mtime, $to
     or die "can't modify mtime of $to: $!\n";
}

sub make_dir {
   my ($dir, %options)=@_;
   my $clean=$options{clean_dir};

   if (-e $dir) {
      if (-d _) {
         if (defined($dirmode) && ((stat _)[2] & 03777) != $dirmode) {
            chmod $dirmode, $dir
               or die "$0: can't change mode of $dir: $!\n";
         }
         if (defined $group and (stat _)[5] != $group) {
            chown -1, $group, $dir
              or die "$0: can't change group of $dir: $!\n";
         }
         if ($clean) {
            my $error;
            if (defined( my $exclude=$options{exclude})) {
               my $exclude_re=compile_pattern(@$exclude, qw(. ..));
               opendir my $D, $dir;
               foreach (readdir $D) {
                  if ($_ !~ $exclude_re) {
                     if (-d "$dir/$_") {
                        File::Path::remove_tree("$dir/_", { error=>\$error });
                        if (@$error) {
                           die "$0: can't remove old files:\n", map { join(": ", %$_)."\n" } @$error;
                        }
                     } else {
                        unlink "$dir/$_"
                          or die "$0: can't remove old $dir/$_: $!\n";
                     }
                  }
               }
            } else {
               File::Path::remove_tree($dir, { keep_root=>1, error=>\$error });
               if (@$error) {
                  die "$0: can't clean $dir:\n", map { join(": ", %$_)."\n" } @$error;
               }
            }
         }
         return;
      }
      unlink $dir
         or die "$0: can't remove old $dir: $!\n";
   }
   File::Path::make_path($dir, { defined($dirmode) ? (mode => $dirmode) : (),
                                 defined($group) ? (group => $group) : () })
      or die "could not create directory $dir: $!\n";
}



# Local Variables:
# cperl-indent-level:3
# indent-tabs-mode:nil
# End:
