#!/usr/bin/perl
#
# Use like mv(1), but writes a .htaccess file setting up redirection.
# Or use like rm(1), but writes a .htaccess setting up redirection or
# 'gone' at your choice.
#
# -- Ed Avis <ed@membled.com>, 2003-08-17
#

use warnings;
use strict;
use File::Basename;
sub transitive_closure_add( $$$$;$ );
sub add_redirection( $$;$ );

my $verbose = 0;
my (@flags, @files);
while (defined($_ = shift @ARGV)) {
    if ($_ eq '--') {
	push @flags, $_;
	@files = @ARGV;
	last;
    }
    elsif (/^--vers/) {
	print <<END
wmv, part of wutils version 0.1.2
See <http://membled.com/work/apps/wutils/>
END
  ;
	exit();
    }
    elsif (/^--verb/ or $_ eq '-v') {
	$verbose = 1;
	push @flags, $_;
    }
    elsif (/^-/) {
	push @flags, $_;
    }
    else {
	die "absolute paths not handled: $_" if m!^/!;
	die ".. not handled: $_" if m!(?:^|/)[.][.](?:$|/)!;
	push @files, $_;
    }
}

my $htaccess = '.htaccess';
open(HTACCESS, "+>>$htaccess") or die "cannot write to $htaccess: $!";
my $seen_rewriteengine = 0;
seek HTACCESS, 0, 0 or die "cannot seek: $!";

# Keep track of existing redirections ($already{from}{to}) in an
# attempt to warn about redirect loops.  But this is not guaranteed to
# work for those that were not created by wmv.
#
my %already;
while (<HTACCESS>) {
    if (/^\s*rewriteengine\s+on\b/i) {
	$seen_rewriteengine = 1;
    }
    elsif (/^\s*rewriterule\s+(\S+)\s+(\S+)/) {
	my ($from, $to) = ($1, $2);
	$from =~ s/^\^// or next;
	$from =~ s/\$// or next;
	$from =~ s!/[*]$!!;
	$from =~ s/\\ (.)/$1/gx; # unquote metacharacters
	$to =~ s!/+!!;
	transitive_closure_add(\%already, $from, $to, "$htaccess line $.");
    }	
}
print HTACCESS "rewriteengine on\n" unless $seen_rewriteengine;

my $invoked_as = basename($0);
if ($invoked_as eq 'wmv') {
    # Run mv -v and process the output.
    my $pid = open(CHILD, '-|');
    die "cannot fork: $!" if not defined $pid;
    if (not $pid) {
	# Child.
	exec 'mv', '-v', @flags, @files or die "cannot exec: $!";
	exit();
    }
    
    # Parent.
    my %seen_from;
  LINE: while (<CHILD>) {
	chomp;
	next if /^removed (?:directory: |)[\'\`](.+)\'$/;
	$_ =~ qr/^[\`\'](.+)\' -> [\`\'](.+)\'/
	  or die "bad line from mv -v: $_";
	print "$_\n" if $verbose;
	my ($from, $to) = ($1, $2);
	
	# Ignore lines which are recursing inside already-seen
	# directories.
	#
	$seen_from{$from}++ && die "source '$from' seen twice in mv output";
	for (my $from_check = $from; $from_check =~ s!(.+)/.*!$1!;) {
	    next LINE if $seen_from{$from_check};
	}
	
	foreach ($from, $to) {
	    warn("absolute paths not supported: $_"), next LINE if m!^/!;
	    warn(".. not handled: $_"), next LINE if m!(?:^|/)[.][.](?:$|/)!;
	}
	eval {
	    add_redirection('permanent', $from, $to);
	};
	warn "not adding redirection $from -> $to, because $@" if $@;
    }
    
    my $r = waitpid $pid, 0;
    if ($r == $pid or $r == -1) {
	my $signal_num  = $? & 127;
	kill $$, $signal_num if $signal_num;
	
	my $dumped_core = $? & 128;
	die "command dumped core\n" if $dumped_core;
	
	my $exit_value  = $? >> 8;
	exit $exit_value;
    }
    else { die "bad return from waitpid(): $r (our child was $pid)" }
}
elsif ($invoked_as eq 'wrm' or $invoked_as eq 'wrmdir') {
    # Look at each file given and prompt about it, before running rm.
    my $default_redirection = 'gone';
    my $default_seeother;
    foreach (@files) {
	warn("$_ not found, skipping redirection\n"), next if not -e;
	my $is_dir = -d _;
      ASK:
	print "redirection for $_ (gone,seeother,temporary,permanent) [$default_redirection]: ";
	my $resp = <STDIN>;
	for ($resp) {
	    die "cannot read stdin: $!" if not defined;
	    chomp;
	    if (not /\S/) { $_ = $default_redirection }
	    elsif (/^[gG]/) { $_ = 'gone' }
	    elsif (/^[sS]/) { $_ = 'seeother' }
	    elsif (/^[tT]/) { $_ = 'temporary' }
	    elsif (/^[pP]/) { $_ = 'permanent' }
	    else {
		print "bad answer '$resp\n";
		goto ASK;
	    }
	}
	my $dest; undef $dest; # because of goto
	if ($resp eq 'gone') {
	    # No destination needed.
	}
	elsif ($resp eq 'seeother' and defined $default_seeother) {
	    print "$resp redirect to [$default_seeother]: ";
	    for ($dest = <STDIN>) {
		die "cannot read stdin: $!" if not defined;
		chomp;
		$_ = $default_seeother if not /\S/;
	    }
	}
	else {
	    print "$resp redirect to: ";
	    while (not defined $dest) {
		for ($dest = <STDIN>) {
		    die "cannot read stdin: $!" if not defined;
		    chomp;
		    print "bad destination '$dest'", undef $_ if not /\S/;
		}
	    }
	    $default_seeother = $dest if $resp eq 'seeother';
	}
	
	eval {
	    add_redirection($resp, $_, $dest);
	};
	if ($@) {
	    warn "bad redirection: $@\n";
	    goto ASK;
	}
    }
    (my $cmd = $invoked_as) =~ s/^w// or die;
    exec $cmd, @flags, @files;
}




# Given a hash which is a transitive relation R (a R b iff defined
# $h{a}{b}) and a new pair a, b to add, add a R b to the relation and
# compute the transitive closure again.
#
# The values of the hash exist iff a R b is in the relation; but in
# fact the defined values are strings and computing a transitive
# closure concatenates strings separated by comma, so you have a kind
# of 'trail' of why (a, b) is in the relation.
#
# Parameters:
#   ref to hash of relation (to be modified)
#   a
#   b
#   'reason' why a R b (a string)
#   optional flag 'yes, I know it might already be there, don't warn'
#
sub transitive_closure_add( $$$$;$ ) {
    our %h; local *h = shift;
    my ($a, $b, $reason, $nowarn) = @_;
    die if not defined $reason;
    my $already = $h{$a}{$b};
    $h{$a}{$b} = $reason;
    if (defined $already) {
	warn "($a, $b) being added because $reason, but already there because $already"
	  unless $nowarn;
	return;
    }
    foreach my $k (keys %h) {
	if (exists $h{$k}{$a}) {
	    die if not defined $h{$k}{$a};
	    transitive_closure_add(\%h, $k, $b, "$h{$k}{$a},$reason", 1);
	}
    }
    foreach my $k (keys %{$h{$b}}) {
	my $v = $h{$b}{$k};
	die if not defined $v;
	transitive_closure_add(\%h, $a, $k, "$reason,$v", 1);
    }
}

# Add a redirection, throwing an exception if it shouldn't be added.
# Uses global %already and HTACCESS.
#
sub add_redirection( $$;$ ) {
    my ($resp, $from, $to) = @_;
    my $dir;
    if ($resp eq 'gone') {
	die "no destination can be given for 'gone'" if defined $to;
	$to = '.'; # dummy to keep mod_rewrite happy
	$dir = -d $from;
    }
    else {
	die "destination required for '$resp'" if not defined $to;
	if (exists $already{$from}{$to}) {
	    warn "not adding redirection $from -> $to,\n"
	      . "because already there from: $already{$from}{$to}\n";
	    return;
	}
	die "redirection loop with lines: $already{$to}{$from}\n"
	  if exists $already{$to}{$from};
	transitive_closure_add(\%already, $from, $to, "'$_'");
	$dir = -d $from || -d $to;
    }

    my %http = (gone      => 'G',
		seeother  => 'R=303',
		temporary => 'R=302',
		permanent => 'R=301',
	       );
    my $http = $http{$resp};
    die "bad redirection type '$resp'" if not $http;

    my $from_re = '^' . quotemeta($from);
    if ($dir) {
	if ($resp eq 'seeother') {
	    # Don't assume that the destination is a directory.
	    print HTACCESS 'rewriterule ', $from_re, '$ ',     $to, " [$http,L]\n";
	    print HTACCESS 'rewriterule ', $from_re, '/(.*) ', $to, " [$http,L]\n";
	}
	else {
	    print HTACCESS 'rewriterule ', $from_re, '$ ',     $to, '/ ',   "[$http,L]\n";
	    print HTACCESS 'rewriterule ', $from_re, '/(.*) ', $to, '/$1 ', "[$http,L]\n";
	}
    }
    else {
	print HTACCESS 'rewriterule ', $from_re, '$ ', $to, " [$http,L]\n";
    }
}