# Copyright (c) 1997-2007
# 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 7546 2007-01-08 16:34:56Z gawrilow $
use strict;
use vars qw( $makedir $usage $strip $exclude_re $noexport
$translate_re $translate_back_re $copylink_re %make_vars
$Unlink $modemask $group $Perl
);
use POSIX qw ( :fcntl_h read write lseek );
use Config;
$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;
}
my $z1024=pack "x1024";
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;
}
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;
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 my $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;
}
}
}
}
} 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)=@_;
if (opendir my $S, $src) {
make_dir($dst,$dirmode) or return 0;
foreach my $f (grep { $_ !~ $exclude_re } readdir $S) {
my $src_f="$src/$f";
if (defined (my $noexport=$noexport->{$src_f})) {
next if $noexport ne "local";
}
if (-d $src_f) {
copy_dir($src_f, "$dst/$f", $dirmode) or return 0;
} else {
copy($src_f, "$dst/$f") or return 0;
}
}
1
} else {
warn "$0: can't traverse $src: $!\n";
0
}
}
$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;
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)/;
my @global_exclude=qw( \. \.\. \.\#.* );
if (exists $patterns{'-X'}) {
push @global_exclude, @{$patterns{'-X'}};
}
if (-d "$ARGV[0]/.svn") {
require SVN::Client;
my $ctx=SVN::Client->new();
$noexport=$ctx->propget("noexport", $ARGV[0], "WORKING", 1);
push @global_exclude, "\\.svn";
}
my $global_exclude=join('|', map { "(?:^$_\$)" } @global_exclude);
$exclude_re=qr/$global_exclude/;
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;
}
}
}
syntax highlighted by Code2HTML, v. 0.9.1