#!SPPSYM_PERL_CMD
#spp comment vim: set filetype=perl: #
#spp include ../bldcfg/paths.spp
use strict; 
#  leave a standard path unless there is some reason not to
$ENV{'PATH'} = '/bin:/usr/bin:/sbin:/usr/sbin';
($main::progname = $0) =~ s/^.*\/([^\/]+)/$1/;
$main::svn_id = '$HeadURL$ $LastChangedRevision$';
$main::version_scheme = 'release';
$main::release_version = 'ADE_APP_TOKEN_RELEASE_ID';
my($tmp_dir) = ($ENV{'TMPDIR'}) ? $ENV{'TMPDIR'} : "SPPSYM_TMPDIR";

#  Modules
use Cwd;

#  Defaults for options
undef my($dflt_mode);
my($dflt_warnonunsreadabledir) = 1;

#  Option variables (needed at global level 'cos used in path reporting function)
undef my($opt_mode);
undef my($opt_warnonunsreadabledir);

#  Other globals

sub main
{
    my(@ARGV) = @_;
    my($dirent, $rc, $source, $target, $abs_target, $link_dir, $link_target);
    my($is_symlink, $is_directory, $is_readable, $is_execable, $listpaths, $optval);

    ##########################################################################
    #
    #  PROCESS OPTIONS
    #
    ##########################################################################

    #
    #  Load option values from command line
    #
    while (defined($ARGV[0]) && $ARGV[0] =~ /^-./) {
        $_ = $ARGV[0];

        #  standard options
        if (/^(?:-V|--version)$/) {
            &ade_msg_version(\&app_version);

        } elsif (/^(-d$|--debug=)(.*)/) {
            $main::verboselevel = ($1 !~ /^-[^-]/) ? $2 : ((defined($ARGV[1])) ? scalar($optval=$ARGV[1],shift @ARGV,$optval) : &ade_msg_usage(\&app_usage, 1));

        } elsif (/^(?:-v|--verbose)$/) {
            $main::verboselevel = 3;

        } elsif (/^(?:-h|--help)$/) {
            &ade_msg_usage(\&app_usage, 0);

        } elsif (/^(?:-p|--list-paths)$/) {
	    $listpaths = 1;

        } elsif (/^--create$/) {
	    $opt_mode = "create";

        } elsif (/^--delete$/) {
	    $opt_mode = "delete";

        } elsif (/^--no-warn-on-unreadable-dir$/) {
	    $opt_warnonunsreadabledir = 0;

        } elsif (/^--$/) {
            shift @ARGV;
	    last;

        } else {
            &ade_msg_usage(\&app_usage, 1);
        }

        shift @ARGV;
    }

    #
    #  Load option values from environment
    #

    #  (not supported by this program)

    #
    #  Load option values from config file
    #

    #  (not required for this program)

    #
    #  hard-coded defaults
    #
    $opt_mode                 = $dflt_mode                 if (!defined($opt_mode));
    $opt_warnonunsreadabledir = $dflt_warnonunsreadabledir if (!defined($opt_warnonunsreadabledir));

    #
    #  Sanity check and option rewrites
    #
    (!$listpaths) && (!defined($opt_mode)) && &ade_msg_usage(\&app_usage, 1);

    ##########################################################################
    #
    #  ARGUMENT PROCESSING
    #
    ##########################################################################

    #  Any number of parameters is valid.
    &ade_msg_listpaths(\&app_listpaths) if ($listpaths);

    ##########################################################################
    #
    #  FORKING AND LOCKING
    #
    ##########################################################################

    #  (not required for this program)

    ##########################################################################
    #
    #  GUTS STARTS HERE
    #
    ##########################################################################

    for $target (@ARGV) {
        #  SOURCE is the thing we are creating!
        $source = &ade_fnm_basename($target);
    
        #  It is an error for the thing to exist and not be a symlink!
        if ((! -l $source) && (-e $source)) {
            &ade_msg_errorerror("$source: exists already and is not symlink");
            return(1);
        }
    
        #  Symlinks that point to the wrong thing are deleted and recreated.
        if ((-l $source) && (readlink($source) ne $target)) {
           &ade_msg_warning("$source: removing wrongly directed symlink ...");
           unlink $source;
        }
    
        #  Create the symlink if necessary
        if (($opt_mode eq "create") && (! -l $source)) {
            &ade_msg_info("creating symlink $source -> $target ...");
            symlink $target, $source;
        } elsif (($opt_mode eq "delete") && (-l $source)) {
            &ade_msg_info("deleting symlink $source ...");
    	    unlink $source;
        }
    
        if (-l $source) {
            #  Check target is world accessible
	    if (($rc=&checklinkchain($source, undef)) != 0) {
                return($rc);
            }

            #  Check it's not dangling
            if (! -f $source && ! -d $source) {
                &ade_msg_errorerror("$source: dangling symlink");
                return(1);
            }
        } 
    }

    #  In 'clean' mode there should be *no* symlinks left now.
    if ($opt_mode eq "delete") {
        if (!opendir(HANDLE, ".")) {
            &ade_msg_errorerror(".: couldn't read");
            return(1);
        }
        while (defined($dirent=readdir(HANDLE))) {
            next if ($dirent eq "." || $dirent eq "..");
            if (-l $dirent) {
                &ade_msg_errorerror("$dirent: unowned symlink?");
                return(1);
            }
        }
        closedir(HANDLE);
    }

    return(0);
}

sub checklinkchain
{
    my($thing, $wrt) = @_;
    my($rc, $nextwrt, @cmpts, $cmpt, $tocheck);

    &ade_msg_debug(5, sprintf("checklinkchain: sof (thing=$thing, wrt=%s)", (defined($wrt))?$wrt:"undef"));

    #  If no directory was provided for prepending to relative paths,
    #  then use the current directory.
    $wrt = cwd if (!defined($wrt));

    #  Make the passed path absolute
    if ($thing !~ /^\//) {
        &ade_msg_debug(5, "checklinkchain: using $wrt to make $thing absolute ...");
        return($rc) if (($rc=&ade_fnm_makeabsolute($thing, $wrt, \$thing)) != 0);
    }

    #  Ok, convert /a/b/c to a b c.
    #  relative to /.
    @cmpts = split("/", $thing);
    shift(@cmpts);

    #  Here's where the chdir-sequence 'a b c' is relative to.
    $wrt = "/";

    #  working our way through the 'a b c' list ...
    for $cmpt (@cmpts) {

	#  work out the next path down from / that we have to check
        $tocheck = ($wrt eq "/") ? "$wrt$cmpt" : "$wrt/$cmpt";

	#  if we encounter a symlink then make its destination absolute
	#  and going and checking that before continuing.
        if (-l $tocheck) {
            return($rc) if (($rc=&checklinkchain(readlink($tocheck), (readlink($tocheck) =~ /^\//) ? undef : $wrt)) != 0);

        #  if we encounter a directory then make it's readable and
	#  execable by everyone.
        } elsif (-d _) {
            if (~(stat(_))[2] & 004) {
                &ade_msg_warning("$tocheck: directory without read permission") if ($opt_warnonunsreadabledir);
            }
            if (~(stat(_))[2] & 001) {
                &ade_msg_errorerror("$tocheck: directory without execute permission");
                return(1);
            }

	#  for files, just check it's readable.
        } elsif (-f _) {
            if (~(stat(_))[2] & 004) {
                &ade_msg_errorerror("$tocheck: file without read permission");
                return(1);
            } 

	#  we don't handle anything else
        } elsif (-e _) {
            &ade_msg_errorerror("$tocheck: unsupported filesystem item type");
            return(1);
        
        } else {
            &ade_msg_errorerror("$tocheck: does not exist (dangling symlink?)");
            return(1);
        }

  	#  Move down one level in the chain ready to test the next thing in the list
        $wrt = $tocheck;
    }

    return(0);
}

sub app_usage
{
    print "Usage:   $main::progname [ <options> ] [ <target> ... ]\n";
    print "\n";
    #  standard options
    print "Options: -V | --version                       display program version\n";
    print "         -v | --verbose                       verbose\n";
    print "         -d | --debug=<level>                 set debug level\n";
    print "         -h | --help                          display this text\n";
    print "         -p | --list-paths                    list used paths\n";
    #  application-specific options
    print "              --create                        create symlinks to targets in cwd\n";
    print "              --delete                        delete symlinks to targets in cwd\n";
    print "              --no-warn-on-unreadable-dir     no warninf on unreadable directory\n";
    print "\n";

    return(0);
}

sub app_version
{
    my($version_ref) = @_;

    ${$version_ref} = $main::version;

    return(0);
}

sub app_listpaths
{
    return(0);
}

#spp include SPPSYM_ADEROOT_LIB/ade_utils.pl.spp
#spp include SPPSYM_ADEROOT_LIB/ade_gep.pl.spp