The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/env perl 
use strict;
use warnings;

use Getopt::Long;
use File::Spec::Functions qw/catfile catdir splitdir/;
use Cwd;
use Carp;
use File::Find;
@ARGV = '--help' unless @ARGV;
my %args;
GetOptions( \%args, 'install-links=s', 'switch:s', 'help' );

my $USAGE = <<'END'
run: ./tools/shipwright-utility --install-links /usr/local
run: ./tools/shipwright-utility --switch ubuntu

options: 

help: print this usage

install-links: link files in bin, sbin, or libexec to other places
    e.g. --install-links /usr/local

switch: switch to the lib below as/$name, default is uname
    e.g. --switch ubuntu

END
  ;

if ( $args{'help'} ) {
    print $USAGE;
}
elsif ( $args{'install-links'} ) {
    my $cwd = getcwd();

    for my $dir (qw/bin sbin libexec/) {
        next unless -e $dir;
        my $dh;
        opendir $dh, $dir or confess $!;

        mkdir catfile( $args{'install-links'},       $dir )
          unless -e catfile( $args{'install-links'}, $dir );
        my @files = readdir $dh;
        for (@files) {
            next if $_ eq '.' || $_ eq '..';
            symlink catfile( $cwd, $dir, $_ ),
              catfile( $args{'install-links'}, $dir, $_ ) or confess
                  $!;
        }
    }
}
elsif ( defined $args{'switch'} ) {
    my $name = $args{'switch'} || `uname 2>/dev/null`;
    chomp $name;

    my $as_dir = catdir( 'as', $name );
    if ( -e $as_dir ) {
        for my $r ( qw/lib/ ) {
            my $dir = catdir( $as_dir, $r );
            next unless -e $dir;

            if ( $r !~ /bin/ ) {
                unlink $r;
                symlink $dir, $r;
            }
        }

        # remove old ones
        for my $dir ( 'bin', 'sbin', catdir( 'usr', 'bin' ),
            catdir( 'usr', 'sbin' ) )
        {
            if ( -e $dir ) {
                system( "rm -rf $dir" );
            }
        }
        wrap_bin($name);

        open my $fh, '>', '__as' or die $!;
        print $fh $name;
        close $fh;

        print "successfully switched to $name.\n";

    }
    else {
        print "no switch name $name exists\n";
    }
}

sub wrap_bin {
    my $name = shift;
    my $install_base = getcwd();
    my $sub = sub {
        my $file = $_;

        return unless -f $file;

        my $wrap_dir = $File::Find::dir;
        $wrap_dir =~ s!as/$name/!!;

        my $wrap_file = catfile( $wrap_dir, $file );
        my $wrapped_depth =
          scalar( splitdir($File::Find::dir) ) -
          scalar( splitdir($install_base) ) - 2;
        mkdir $wrap_dir unless -d $wrap_dir;

        # return if it's been wrapped already
        if ( -l $wrap_file ) {
            print "seems $file has been already wrapped, skipping\n";
            return;
        }

        my $type;
        if ( -T $file ) {
            open my $fh, '<', $file or confess "can't open $file: $!";
            my $shebang = <$fh>;
            if (
                $shebang =~ m{
\Q$install_base\E(?:/|\\)(?:s?bin)(?:/|\\)(\w+)
|\benv\s+(\w+)
}x
              )
            {
                $type = $1 || $2;
            }
        }

    # if we have this $type(e.g. perl) installed and have that specific wrapper,
    # then link to it, else link to the normal one
        if (
            $type
            && (   -e catfile( '..', 'bin', $type )
                || -e catfile( ('..') x $wrapped_depth, 'bin', $type ) )
            && -e catfile( ('..') x $wrapped_depth, 'etc',
                "shipwright-$type-wrapper" )
          )
        {
            symlink catfile( ('..') x $wrapped_depth,
                'etc', "shipwright-$type-wrapper" ) => $wrap_file
              or confess $!;
        }
        else {

            symlink catfile( ('..') x $wrapped_depth,
                'etc', 'shipwright-script-wrapper' ) => $wrap_file
              or confess $!;
        }
        chmod oct 755, $wrap_file;
    };

    my @dirs =
      grep { -e $_ } map { catdir( $install_base, 'as', $name, $_ ) } 'bin',
      'sbin', catdir( 'usr', 'bin' ), catdir( 'usr', 'sbin' );
    find( { wanted => $sub, follow => 1 }, @dirs ) if @dirs;
}