#!/usr/bin/perl -w

use strict;
use Cwd;
use Getopt::Std;

# $opt_b - bindir
# $opt_h - help
# $opt_i - infodir
# $opt_m - mandir
# $opt_v - verbose
use vars qw($opt_b $opt_h $opt_i $opt_m $opt_v);

$| = 1;


getopts('b:hi:m:v');
usage() if $opt_h;

if ($#ARGV != 0)
{
  print("E: none or too many actions specified\n\n");
  usage();
}

my $action = $ARGV[0];
my $action_len = length($action);

# This is the place to set a minimum length for the <action> keyword
unless ($action_len >= 1)
{
  print("E: <action> argument too short\n\n");
  usage();
}

# Valid actions
my @actions = ('check', 'symlink', 'unlink');

# Verify action validity
my $err = 1;
foreach my $act (@actions)
{
  if ($action eq substr($act, 0, $action_len))
  {
    $err = 0;
    $action = $act;
    $action_len = length($action);
    last;
  }
}
if ($err > 0)
{
  print("E: invalid <action> argument \"$action\"\n\n");
  usage();
}

# Setup default directory names
my $prefix  = "/usr/local";
my $bindir  = "$prefix/cris";
my $infodir = "$prefix/info";;
my $mandir  = "$prefix/man";;
if ($opt_b)
{
  $bindir = $opt_b;
}
if ($opt_i)
{
  $infodir = $opt_i;
}
if ($opt_m)
{
  $mandir = $opt_m;
}

# Setup target (build) directory names
my $here = cwd();
my $bindir_tgt  = "$here/debian/cris-dist" . $bindir;
my $infodir_tgt = "$here/debian/cris-dist" . $infodir;
my $mandir_tgt  = "$here/debian/cris-dist" . $mandir;

if ($opt_v)
{
  print("\nI: ", $action, "ing");
  print(":\n");
  print("I:\tsymlink:\t$bindir\n\ttarget dir:\t$bindir_tgt\n");
  print("I:\tsymlink:\t$infodir\n\ttarget dir:\t$infodir_tgt\n");
  print("I:\tsymlink:\t$mandir\n\ttarget dir:\t$mandir_tgt\n");
}

$err = 0;
if ($action eq $actions[0])
{
  # action 'check' here
  print("\n\n");
  $err = 1 if check_this($bindir, $bindir_tgt) > 0;
  $err = 1 if check_this($infodir, $infodir_tgt) > 0;
  $err = 1 if check_this($mandir, $mandir_tgt) > 0;
}
elsif ($action eq $actions[1])
{
  # action 'symlink' here
  $err = 1 if symlink_this($bindir, $bindir_tgt) > 0;
  $err = 1 if symlink_this($infodir, $infodir_tgt) > 0;
  $err = 1 if symlink_this($mandir, $mandir_tgt) > 0;
}
elsif ($action eq $actions[2])
{
  # action 'unlink' here
  $err = 1 if unlink_this($bindir, $bindir_tgt) > 0;
  $err = 1 if unlink_this($infodir, $infodir_tgt) > 0;
  $err = 1 if unlink_this($mandir, $mandir_tgt) > 0;
}
else
{
  # Should never reach this point
  die "F: internal error,";
}
exit 1 if $err > 0;


exit 0;


sub usage
{
  my $pgm = $0;

  $pgm =~ s,^.*/([^/]+)$,$1,;
  print("Usage: ./$pgm\t[-b <bindir>] [-i <infodir>] [-m <mandir>]
\t\t\t\t[-h] [-v] <action>
where:
\t<action>\targument value may be one of the following keywords:
\t\t\tcheck, symlink or unlink
options:
\t-b <bindir>\tbindir path (default /usr/local/cris)
\t-h\t\tthis help
\t-i <infodir>\tinfodir path (default /usr/local/info)
\t-m <mandir>\tmandir path (default /usr/local/man)
\t-v\t\tverbose
");
  exit 1;
}


sub check_this
{
  my ($lnk, $lnk_tgt) = @_;
  my $ret_err = 0;

  if (-l $lnk)
  {
    unless (readlink($lnk) and (readlink($lnk) eq $lnk_tgt))
    {
      $ret_err = 1;
      print("E: invalid symlink \"$lnk\"\n");
    }
  }
  else
  {
    $ret_err = 1;
    print("E: $lnk should be a symlink pointing to\n   $lnk_tgt\n");
  }

  return $ret_err;
}


sub symlink_this
{
  my ($lnk, $lnk_tgt) = @_;
  my $ret_err = 0;

  if (-l $lnk)
  {
    $ret_err = 1;
    print("E: \"$lnk\" already symlinked to\n   ", readlink($lnk), "\n");
  }
  else
  {
    my $orig = "$lnk.orig";

    if (-d $orig)
    {
      $ret_err = 1;
      print("E: directory $orig already exists\n");
    }
    else
    {
      unless (rename($lnk, $orig))
      {
	my $msg = $!;

	$ret_err = 1;
	print("E: failed moving $lnk to $orig\n");
	print("E: $msg\n");
      }
      else
      {
	print("\nI: $lnk moved to $orig\n") if $opt_v;
      }
    }

    if ($ret_err == 0)
    {
      # symlink function won't symlink to an unexisting directory,
      # so we need to do another ugly hack :(
      my $chopped_tgt = $lnk_tgt;
      $chopped_tgt =~ s,$here/,,;
      my @d_list = split('/', $chopped_tgt);
      my $dir_ws = $here;
      my @dcre_list;

      foreach my $d (@d_list)
      {
	$dir_ws = "$dir_ws/$d";
	unless (-d "$dir_ws")
	{
	  if (mkdir("$dir_ws", 0755))
	  {
	    push(@dcre_list, "$dir_ws");
	    print("I: $dir_ws created\n") if $opt_v;
	  }
	  else
	  {
	    $ret_err = 1;
	    print("E: failed creating directory $dir_ws\n");
	  }
	}
      }

      if ($ret_err == 0)
      {
	if (symlink($lnk_tgt, $lnk))
	{
	  @dcre_list = reverse(@dcre_list);
	  foreach my $d (@dcre_list)
	  {
	    unless (rmdir($d))
	    {
	      $ret_err = 1;
	      print("E: failed removing directory $d\n");
	      last;
	    }
	    else
	    {
	      print("I: $d removed\n") if $opt_v;
	    }
	  }
	}
	else
	{
	  my $msg = $!;

	  # Back off
	  rename($orig, $lnk);

	  $ret_err = 1;
	  print("E: failed symlink creation $lnk pointing to\n   $lnk_tgt\n");
	  print("E: $msg\n");
	}
      }
    }
  }

  return $ret_err;
}


sub unlink_this
{
  my ($lnk) = @_;
  my $ret_err = 0;

  print("\n") if $opt_v;

  unless (-l $lnk)
  {
    $ret_err = 1;
    print("E: \"$lnk\" is not a symlink\n");
  }
  else
  {
    my $orig = "$lnk.orig";

    unless (-d $orig)
    {
      $ret_err = 1;
      print("E: directory \"$orig\" not found\n");
    }
    else
    {
      unless (unlink($lnk))
      {
	$ret_err = 1;
	print("E: symlink \"$lnk\" could not be unlinked\n");
      }
      else
      {
	print("I: unlinked \"$lnk\"\n") if $opt_v;

	unless (rename($orig, $lnk))
	{
	  my $msg = $!;

	  $ret_err = 1;
	  print("E: failed moving $orig to $lnk\n");
	  print("E: $msg\n");
	}
	else
	{
	  print("I: $orig moved to $lnk\n") if $opt_v;
	}
      }
    }
  }

  return $ret_err;
}
