#!/usr/local/bin/perl -w

use strict;
use Getopt::Long; 
use File::Basename;
use Cwd;
use Data::Dumper;

#< pod
=pod

=head1 Name

release - install files and directories, making permissions reasonable

=head1 Synopsys

release [--OPTIONS] source[s] destination

=head1 Description

The unix install program (man 1 install) copies files to a destination
and simultaneously adjusts their permissions and ownership.  This does
about the same.

When a source is a directory and a directory with the same name exists
in the destination directory, then the old destination with the same
name is removed before copying, to avoid the new going inside the old.
When the source is a directory and destination basename is the same as
the source basename, then the destination directory is replaced.

Unlike unix install, this does not do backups, does not differentiate
between plain file and directory sources, automatically creates
destination directories, mails a maintainer with problems, and can
keep a log.

=head1 Options

=over

=item --chmod=CHMOD OPTS

These are simply passed as options to chmod.  Default is '-R ug=rwx,o=rx'.

=item --group=GROUP 

set group ownership to GROUP

=item --owner=USER

set ownership (superuser only)

=item --warning [msg-file]

read a warning message ("do not touch the installed version, the source
is actually here") from msg-file and attach it to each text-file
argument after the first blank line.

If the first line in the header file is: 

  comment-chars:

then the following lines until the next double newline will be treated
specially.  They will be read in pairs.  If the first line (usually
shebang) of an installed text file matches the first line of any pair
of lines, then the second line (comment string) will be prepended to
every other line in the file.  If no first lines match, then nothing
will be prepended to the lines.  In either case, these pairs of lines
will not be part of the attached message.

A file might begin with 

  comment-chars: 
  perl -w 
  #
  \\bscheme\\b
  ;
  
  Header message here.

If there is no filename argument, a standard warning is included.

=item --unknown-comment-string

The default comment string for unrecognized files is none (""), but
for strange files like Makefiles, if you don't want to rely on putting
a special string in the first line of each one, you can use this to
set the default to '#' or any other string.  This *only* affects files
whose first line is not otherwise recognized. 

=item --replace

Generally, release removes the destination before copying the new one.
This is a good idea when multiple owners are installing, and the new
installer would not have permission to chmod the old owner's file.
It's also a good idea when the items in question are directories, or
else the new one would end up inside the old one.  

The replace option supresses that remove, causing cp to replace the
existing installed item (or in the case of directories to do the wrong
thing). 

This might be useful if you have write permission on the file, but not
on the directory.  Though currently that should fail outright.

=item --verbose

print source names as they are copied

=item --quiet

suppress error messages [most useful in cron job in combination with -m or -l]

=item --debug --noact

print debugging information.  If --noact, then do not actually do
anything, just show what would have been done.

=item --maintainer=EMAIL@ADDRESS

someone to send mail to when things go wrong.

=item --log [file]

append to a log file (Default file: /tmp/release-destination.log)

=back

=head1 See Also

L<cp(1)>S<   >L<chmod(1)>S<    >L<install(1)>

=head1 Author

Gregory A. Marton       L<http://csail.mit.edu/~gremio/>

=begin html

=head1 Download

This program is distributed under the GNU General Public License: L<http://www.gnu.org/copyleft/gpl.html>

The source: L<http://csail.mit.edu/~gremio/code/release.pl>

=end html

=cut
    ;
#>

use constant QUIET => -1;
use constant VNORM => 0;
use constant VERB => 1;
use constant DEBUG => 3;
use constant NOACT => 4;

my $chmodopts='-R ug=rwx,o=rx';
my $debug=0;
my $verbose=VNORM;
my ($group, $owner, $maintainer, $logfile, $replace, $header, %commentstrs);
my $default_comment_string="";

#< arguments
my $USAGE="relase [OPTIONS] source(s) destination\n";

Getopt::Long::Configure("noignorecase");
GetOptions("chmod=s" => \$chmodopts,
	   "group=s" => \$group,
	   "owner=s" => \$owner,
	   "warning:s" => \$header,
	   "unknown-comment-string=s" => \$default_comment_string,
	   "replace!" => \$replace,
	   "verbose!" => sub {$verbose=VERB},
	   "debug+" => sub {$verbose=DEBUG},
	   "noaction" => sub {$verbose=NOACT},
	   "quiet!" => sub {$verbose=QUIET},
	   "maintainer=s" => \$maintainer,
	   "log:s" => \$logfile,
	   "help!" => sub { system("perldoc $0") and 
				&error("use perldoc $0 to get help"); 
			    exit 0; });

&error($USAGE) if (@ARGV < 2);
my $dest = pop @ARGV;

$logfile = "/tmp/release-$dest.log" if (defined $logfile and $logfile eq "");
#< determine installed header info
if (defined $header) {
    if ($header eq "") {
	my $cwd = cwd();
	if (-d "CVS" and 
	    open(CVSROOT, "CVS/Root") and
	    open(CVSREP,  "CVS/Repository")) {
	    my $cvsroot = <CVSROOT>;
	    my $cvsrep = <CVSREP>;
	    close CVSROOT;
	    close CVSREP;
	    chomp $cvsroot;
	    chomp $cvsrep;
	    $cwd = "cvs -d $cvsroot co $cvsrep";
	}
        if (-d ".svn") {
	    my ($url) = (`svn info .` =~ /^URL: (.*)/m);
	    $cwd = "svn co $url";
	}
	$header = <<"EOH";





      Warning  WARNING  Warning  WARNING  Warning

      This file is an autogenerated copy.  DO NOT EDIT
      Your changes will be lost.

      the original can be found at:
       $cwd












EOH
    ;
	%commentstrs = (perl => "#",
                        ".pm" => "#",
                        ".pl" => "#",
                        ".py" => "#",
			bash => "#",
                        ".sh" => "#",
			"/sh" => "#",
			lisp => ";",
			".scm" => ";",
			".css" => "//",
			guile => ";",
			ruby => "#",
                        ".rb" => "#");
    } else {
	open(HEADER, "<".$header) or &error("cannot read $header: $!\n");
	$header = "";
	while(<HEADER>) {
	    if ($. == 1 and /^\s*comment-chars:\s*$/) {
		while (<HEADER>) {
		    last if /^\s*$/;
		    chomp;
		    my $key = $_;
		    my $c = <HEADER>;
		    chomp $c;
		    $commentstrs{$key} = $c;
		}
	    }
	    $header .= $_;
	}
    }
}
#>

if ($verbose == DEBUG) {
    print "Installing sources [" . join("], [", @ARGV) ."]\n";
    print "    to destination [" . $dest ."]\n";
    print "    changing perms $chmodopts\n";
    print "    user: $ENV{USER}\n";
    print "    replacing\n" if $replace;
    print "    mailing errors to $maintainer\n" if $maintainer;
    print "    logging to $logfile\n" if $logfile;
    print "    header is: \n" if $header;
    print $header if $header;
    print "    comment strings: " . Dumper(\%commentstrs) if $header;
}
#> 

#< open the log file
if ($logfile) {
    open(LOG, ">>$logfile") or &error("cannot open logfile $logfile: $!");
    print LOG "invoked by $ENV{USER} on ".localtime()."\n";
    print LOG "  installing ".join(", ",@ARGV)." to $dest\n";
}
#>
my $destinside=(@ARGV>1);
#< make sure the destination exists and is writeable
if (-d $dest) {
    if (@ARGV == 1 and basename($dest) eq basename($ARGV[0])) {
	info('  dir single equal arg') if $verbose >= DEBUG;
	#&error(qq(cannot write to destination directory ).dirname($dest))
	#    unless -w dirname($dest);
    } else {
	info('  dir') if $verbose >= DEBUG;
	#&error(qq(cannot write to destination directory $dest)) unless -w _;
	$destinside=1;
    }
} elsif (-e _) {
    info('  file') if $verbose >= DEBUG;
    #&error(qq(cannot overwrite destination $dest)) unless -w _;
} elsif (-e dirname($dest)) {
    info('  new file') if $verbose >= DEBUG;
    #&error(qq(cannot create $dest)) unless -w _;
} elsif ($destinside) {
    info('  new dest dir') if $verbose >= DEBUG;
    mkdir($dest) or &error(qq(cannot create $dest: $!$@)); 
} else {
    info('  new dest parent dir') if $verbose >= DEBUG;
    mkdir(dirname($dest)) or &error(qq(cannot create ).dirname($dest));
}
#>   

for my $source (@ARGV) {
    #< make sure the source exists and is readable
    error("no such file or directory [$source]") unless (-e $source);
    error("source [$source] not readable") unless -r _;
    #>

    my $realdest=$dest;
    $realdest .= "/" . basename($source) if $destinside;
    $realdest =~ s|/\.\.?$||;
    $realdest =~ s|/$||;

    print "$source --> $realdest\n" if $verbose >= VERB;
    print LOG "   $source --> $realdest\n" if $logfile;
    
    #< remove the old file
    if (! $replace and -e $realdest) {
	trycmd(qq(rm -fr "$realdest"),
	       qq(cannot remove $realdest)) and next;
    }
    #>
    #< make new file
    if ($header and -T $source) {
	# rebuild the file including a warning.
	open(SRC, "<" . $source) or &error("cannot read $source: $!\n");
	open(DST, ">" . $realdest) or &error("cannot write $realdest: $!\n");
	my $commentmark;
	$commentmark = $default_comment_string if defined $header;
	local $.=0;
	while (<SRC>) {
	    #< play header
	    if ($. == 1 and 0 < scalar keys %commentstrs) {
		foreach my $key (keys %commentstrs) {
		    if (/$key/) { # this is not safe for root execution
			$commentmark=$commentstrs{$key};
			last;
		    }
		}
		if ($source =~ /(\.\w+)$/ and $commentstrs{$1}) {
		    $commentmark=$commentstrs{$1};
		} elsif ($realdest =~ /(\.\w+)$/ and $commentstrs{$1}) {
		    $commentmark=$commentstrs{$1};
		}
		unless (defined $commentmark) {
		    warn "WARNING: did not find a comment mark for file $source.\n";
		    warn "         duplicating the warning without any comment mark!\n";
		}
	    }
	    if (defined $commentmark and /^\s*$/) {
		print DST;
		my $tmphead = $header;
		$tmphead =~ s/^/$commentmark/gm;
		print DST $tmphead;
		undef $commentmark;
	    }
	    #>
	    print DST;
	}
	close SRC;
	close DST;
    } else {
	# otherwise just try to copy what's there
	trycmd(qq(cp -fR "$source" "$realdest"),
	       qq(cannot copy $source to $dest)) and next;
    }
    #> 
    #< change its permissions
    trycmd(qq(chmod $chmodopts "$realdest"), 
	   qq(cannot change permissions on $realdest));
    #>
    #< change group
    if ($group) {
	trycmd(qq(chgrp $group "$realdest"),
	       qq(cannot change group on $realdest));
    }
    #>
    #< change owner...
    if ($owner) {
	trycmd(qq(chown $owner "$realdest"),
	       qq(cannot change ownership on $realdest));
    }
    #>
}

#< error
sub error { 
    if ($maintainer) {
	open (MAIL, "| mail $maintainer") 
	    or die "release: cannot send mail to $maintainer: $!\n";
	print MAIL "Subject: release error: " . join ("", @_) . "\n";
	print MAIL "\n";
	$dest = "undef (!!!)" unless defined $dest;
	print MAIL "user: $ENV{USER}  destination $dest\n";
	print MAIL "sources: " . join (" ", @ARGV) . "\n";
	print MAIL "sysmsgs: [$!][$@]\n";
	print MAIL "release error: " . join("", @_) . "\n";
	close MAIL;
    } 
    if ($logfile and defined *LOG) {
	print LOG "release error: " . join ("", @_) . "\n";
    }

    if ($verbose == QUIET) {
	exit 0;
    } else {
	die join("","release error: ", @_). "\n";
    }
}
#> 
#< info
sub info { 
    if ($logfile and defined *LOG) {
	print LOG join ("", @_) . "\n";
    }
    warn join("",@_)."\n" unless ($verbose == QUIET);
}
#> 
#< trycmd
sub trycmd {
    my $cmd = shift;
    my $error = shift;
    $cmd .= " 2>&1";
    info($cmd) if $verbose >= DEBUG;
    return if $verbose > DEBUG;
    my $result = qx($cmd);
    &error(qq(error: $error : $result)) if $result;
    return $result;
}
#>