#!/usr/bin/perl
#########################################################################################
# Description:  Installer for HiPi modules
# Copyright:    Copyright (c) 2016 Mark Dootson
# Licence:      This work is free software; you can redistribute it and/or modify it 
#               under the terms of the GNU General Public License as published by the 
#               Free Software Foundation; either version 3 of the License, or any later 
#               version.
#########################################################################################

use strict;
use warnings;

our $VERSION ='0.50';

#####################################

package HiPi::Installer;

#####################################
use Config;

sub new {
    my $class = shift;
    my $self = bless {
        dotest        => 0,
        rooturl       => 'http://raspberrypi.znix.com/hipifiles',
        getversionurl => 'http://raspberrypi.znix.com/hipifiles/latest.txt',
        gettesturl    => 'http://raspberrypi.znix.com/hipifiles/testversion.txt',
        tmproot       => '/var/tmp/_hipiinstall',
        architectures => {
            'arm-linux-gnueabihf-thread-multi-64int' => { 'v5.14.2' => 1, 'v5.20.2' => 1 }, 
        },
        dependencies  => {
            standard  => [ qw(
                libextutils-parsexs-perl
                libextutils-xspp-perl
                libtry-tiny-perl
                libdevice-serialport-perl
                libfile-slurp-perl
                libuniversal-require-perl
                libclass-accessor-perl
                libfile-chdir-perl
                libio-string-perl
                libio-stringy-perl       
                libfile-copy-recursive-perl
                libpar-dist-perl
                libwww-perl
                libtext-patch-perl
                libtext-diff-perl
                libmodule-info-perl
                libio-multiplex-perl
                i2c-tools
                git
                libperl-dev
                libio-epoll-perl
                raspi-gpio
                wiringpi
            )],
            
            wheezy   => [ qw(
                libthreads-perl
                libthreads-shared-perl
                libthread-queue-perl
            )],
            
            wx       => [ qw(
                libwebkitgtk-1.0-0
                zlib1g-dev
            )],
        },
        
        notes => {
            dowx => 0,
        },
        
        minumum_wx    => 0.9928,
        minimum_alien => 3.000002, 
        
    }, $class;
    
    return $self;
}

#############################################################################
# _readline, prompt and y_n are adaptations of methods in Module::Build::Base
#############################################################################

sub _perl_versionstring {
    my $perlversionstring = $^V;
    return $perlversionstring;
}

sub _perl_version {
    my $perlversion = _perl_versionstring();
    $perlversion =~ s/^v//;
    return $perlversion;
}

sub invalid_architecture {
    my $self = shift;
    my $archname = $Config{archname};
    my $pv = $self->_perl_versionstring;
    my $rval = '';
    unless(exists($self->{architectures}->{$archname}->{$pv})) {
        $rval = qq(Perl architecture $pv $archname is not supported by hipi-install);
    }
    return $rval;
}

sub _readline {
  my $self = shift;
  my $answer = <STDIN>;
  chomp $answer if defined $answer;
  return $answer;
}

sub prompt {
  my $self = shift;
  my $mess = shift
    or die "prompt() called without a prompt message";

  # use a list to distinguish a default of undef() from no default
  my @def;
  @def = (shift) if @_;
  # use dispdef for output
  my @dispdef = scalar(@def) ?
    ('[', (defined($def[0]) ? $def[0] . ' ' : ''), ']') :
    (' ', '');

  local $|=1;
  print "$mess ", @dispdef;
  
  my $ans = $self->_readline();

  if ( !defined($ans)        # Ctrl-D or unattended
       or !length($ans) ) {  # User hit return
    print "$dispdef[1]\n";
    $ans = scalar(@def) ? $def[0] : '';
  }

  return $ans;
}

sub y_n {
  my $self = shift;
  my ($mess, $def)  = @_;

  die "y_n() called without a prompt message" unless $mess;
  die "Invalid default value: y_n() default must be 'y' or 'n'"
    if $def && $def !~ /^[yn]/i;

  my $answer;
  while (1) { # XXX Infinite or a large number followed by an exception ?
    $answer = $self->prompt(@_);
    return 1 if $answer =~ /^y/i;
    return 0 if $answer =~ /^n/i;
    local $|=1;
    print "Please answer 'y' or 'n'.\n";
  }
}

sub log_info {
    my $self = shift;
    print @_ , qq(\n);
}

sub log_fatal {
    my $self = shift;
    print @_ , qq(\n);
    chdir('/var/tmp');
    qx(rm -rf $self->{tmproot}) if -e $self->{tmproot};
    exit(1);
}

sub wx_required { shift->{notes}->{dowx}; }

sub welcome {
    my $self = shift;
    $self->log_info(qq(################################################\n));
    $self->log_info(qq(HiPi Installer Version $VERSION\n));
    $self->log_info(qq(################################################\n));
}

sub check_permissions {
    my $self = shift;
    if ($>) {
        $self->log_fatal(q(hipi-install must be run with root permissions. Run as 'sudo perl hipi-install'));
    }
}

sub check_requirements {
    my $self = shift;
    
    if (my $badarch = $self->invalid_architecture ) {
        $self->log_fatal( $badarch );
    }
    
    # maybe wx is already installed so there's no point in asking the question
    my $maywantwx = 1;
    
    eval{ delete($INC{'Alien/wxWidgets.pm'}) if exists($INC{'Alien/wxWidgets.pm'}); };
    
    eval {
        no warnings;
        require Wx::Mini;
        my $wxversion = $Wx::VERSION || 0;
        require Alien::wxWidgets;
        Alien::wxWidgets->import;
        my $widgversion = Alien::wxWidgets->version || 0;        
        unless( $wxversion < $self->{minumum_wx} || $widgversion < $self->{minimum_alien} ) {
            $maywantwx = 0;
        }
    };

    if ( $maywantwx ) {
        my $prompt = qq(The HiPi Modules distribution includes a GUI built with Wx $self->{minumum_wx}.\nDo you want to install pre-built Wx $self->{minumum_wx} modules for your architecture? [y/n]);
    
        my $dowx = $self->y_n($prompt);
        $self->{notes}->{dowx} = $dowx;
    }
    
}

sub check_dependencies {
    my $self = shift;
    
    my @rawdebs = @{ $self->{dependencies}->{standard} };
    
    if ( $self->_perl_version eq '5.14.2' ) {
        push( @rawdebs, @{ $self->{dependencies}->{wheezy} } );
    }
    
    if ( $self->wx_required ) {
        push( @rawdebs, @{ $self->{dependencies}->{wx} } );
    }
    
    my @debs = sort @rawdebs;
    
    $self->log_info('Checking dependencies');
    
    my @missing = ();
    
    for my $deb ( @debs ) {
        my $result = qx(dpkg -s $deb 2>/dev/null | grep Status);
            
        if ($result =~ /installed/) {
            $self->log_info( qq($deb is installed) );
        } else {
            $self->log_info( qq($deb is missing) );
            push @missing, $deb;
        }
    }
    
    if (@missing) {
        $self->log_info(qq(\nThe following packages are not installed and are required for HiPi\n));
        $self->log_info( join(qq(\n), @missing ) . qq(\n) );
        $self->log_info('This installer can install the packages using apt-get update, apt-get install');
        $self->log_info('The installer will not call apt-get upgrade for you so you may');
        $self->log_info('wish to do that first.');
        my $doinstall = $self->y_n(q(do you want to install the missing packages now? [y/n]));
        unless( $doinstall ) {
            $self->log_fatal('You can apt-get update, apt-get updgrade, and apt-get install the required packages yourself before running this script again');
        }
        my $cmd = qq(apt-get update);
        system($cmd) and $self->log_fatal(qq(failed updating package lists: $!));
        $cmd = qq(apt-get -y install ) . join(' ', @debs);
        system($cmd) and $self->log_fatal(qq(failed installing dependencies: $!));
    }
}

sub get_version_url {
    my $self = shift;
    return ( $self->{dotest} ) ? $self->{gettesturl} : $self->{getversionurl};
}

sub get_latest_version_file {
    my $self = shift;
    require LWP::UserAgent;
    
    my $versionurl = $self->get_version_url;
    
    my $ua = LWP::UserAgent->new( timeout => 10 );
    $ua->agent(qq(HiPi Installer/$VERSION));
    $ua->env_proxy;
    
    my $response = $ua->get($versionurl);
    
    my $content = ( $response->is_success ) ? $response->decoded_content : undef;
    if(!defined($content) ) {
        $self->log_fatal('The HiPi web site is unavailable or could not be reached.');
    }
    
    chomp($content);
    
    if (!$self->{dotest} && $VERSION < $content ) {
        $self->log_info(qq(\n#############################################\n\nThis version $VERSION of hipi-install is out of date\n));
        $self->log_info(qq(download the latest version $content using:));
        $self->log_fatal(qq(wget $self->{rooturl}/hipi-install));
    }
    
    my $sourcename = qq(HiPi-${content});
    my $sourcefile = $sourcename . '.tar.gz';
    my $sourceurl = $self->{rooturl} . '/' . $sourcefile;
    
    return ($sourcename, $sourcefile, $sourceurl);
}

sub check_my_version {
    my ($self, @args) = @_;
    if( @args ) {
        my $commandargs = join('', @args);
        if ( $commandargs =~ /dotest/) {
            $self->{dotest} = 1;
        }
    }   
}

sub extract_module_source {
    my $self = shift;
    
    $self->log_info('Creating temporary directory');
    
    my $tmproot = $self->{tmproot}; 
    qx(rm -rf $tmproot) if -e $tmproot;
    mkdir($tmproot, 0777) or $self->log_fatal('could not create temporary install directory');
    chdir($tmproot) or  $self->log_fatal('could not enter temporary install directory');

    my ($sourcename, $sourcefile, $sourceurl) = $self->get_latest_version_file();
    
    $self->log_info('Downloading latest source');
    system(qq(rm -rf $sourcename));
    system(qq(rm $sourcefile));
    system(qq(wget $sourceurl)) and $self->log_fatal('Failed to download latest tarball');
    system(qq(tar -xvzf $sourcefile)) and $self->log_fatal('Failed to extract latest tarball');
    
    $self->{_source_build_dir} = qq($tmproot/$sourcename);
}

sub build_module {
    my $self = shift;
    chdir($self->{_source_build_dir}) or $self->log_fatal('could not enter extracted source directory');
    my $bldcmd = qq($^X Build.PL);
    system($bldcmd) and $self->log_fatal('Failed to run perl Build.PL');
    system(qq($^X Build)) and $self->log_fatal('Failed to run perl Build');
    $self->log_info('HiPi Modules have been built');
}

sub test_module {
    my $self = shift;
    chdir($self->{_source_build_dir}) or $self->log_fatal('could not enter extracted source directory');
    system(qq($^X Build test)) and $self->log_fatal('Failed to run perl Build test');
    $self->log_info('HiPi Modules have been tested');
}

sub install_module {
    my $self = shift;
    chdir($self->{_source_build_dir}) or $self->log_fatal('could not enter extracted source directory');
    system(qq($^X Build install)) and $self->log_fatal('Failed to run perl Build install');
    $self->log_info('HiPi Modules have been installed');
}

sub clean_up_exit {
    my $self = shift;
    chdir('/var/tmp');
    qx(rm -rf $self->{tmproot}) if -e $self->{tmproot};
    exit(0);
}

sub install_wx {
    my $self = shift;
    return unless $self->{notes}->{dowx};
    $self->log_info(qq(Installing PAR Dists for wxPerl\n));
    chdir($self->{_source_build_dir}) or $self->log_fatal('could not enter extracted source directory');
    system(qq($^X inc/installwx.pl)) and $self->log_fatal('failed to install wxPerl');   
}

#####################################

package main;

#####################################

my $handler = HiPi::Installer->new();
$handler->check_my_version(@ARGV);
$handler->welcome();
$handler->check_permissions();
$handler->check_requirements();
$handler->check_dependencies();
$handler->extract_module_source();
$handler->install_wx();
$handler->build_module();
$handler->test_module();
$handler->install_module();
$handler->clean_up_exit();

1;

__END__

1;