###################################################################################
# Distribution    Wx::Perl::Packager
# File            Wx/Perl/Packager/Base.pm
# Description:    base module for OS specific handlers
# File Revision:  $Id: Base.pm 48 2010-04-25 00:26:34Z  $
# License:        This program is free software; you can redistribute it and/or
#                 modify it under the same terms as Perl itself
# Copyright:      Copyright (c) 2006 - 2010 Mark Dootson
###################################################################################

package Wx::Perl::Packager::Base;

use strict;
use warnings;
require Class::Accessor;
use base qw( Class::Accessor );
use File::Copy;
use Digest::MD5;

our $VERSION = '0.27';

#-------------------------------------
# Accessors
#-------------------------------------

__PACKAGE__->follow_best_practice; # I like get/set

__PACKAGE__->mk_ro_accessors( qw( config debug_on is_mswin is_darwin is_linux path_delim dll_suffix) );

__PACKAGE__->mk_accessors( qw( relocate_pdkcheck relocate_packaged
    loadmode_pdkcheck loadmode_packaged loadcore_pdkcheck loadcore_packaged relocateable core_relocated require_overwrite 
    inner_wx_load_path inner_app_extract_path inner_app_relocate_path packaged runtime pdkautopackaged basemodule
    modules unload_loaded_core core_loaded so_module_suffix path_separator pdkcheck_exit unload_loaded_plugins
    unlink_relocated relocate_wx_main pdkcheck_handle
    ));

#---------------------------------------
# Constructor with default configuration
#---------------------------------------

sub new {
    my $class = shift;
    my $self = $class->SUPER::new( {
        debug_on            => $Wx::Perl::Packager::_debug_print_on,
        relocate_pdkcheck   => 0,
        relocate_packaged   => 0,
        relocate_wx_main    => 0,
        loadmode_pdkcheck   => 'standard',  # standard | nullsub | packload
        loadmode_packaged   => 'packload',
        loadcore_pdkcheck   => 0,
        loadcore_packaged   => 0,
        unload_loaded_core  => 1,
        unload_loaded_plugins => 1,
        require_overwrite   => 0,
        runtime             => 'PERL',
        packaged            => 0,
        path_delim          => ( $^O =~ /^mswin/i ) ? ';' : ':',
        dll_suffix          => ( $^O =~ /^mswin/i ) ? '.dll' : '.so',
        relocateable        => 0,
        core_relocated      => 0,
        core_loaded         => 0,
        pdkautopackaged     => 0,
        pdkcheck_exit       => 0,
        pdkcheck_handle     => 0,
        unlink_relocated    => 0,
        path_separator      => ( $^O =~ /^mswin/i ) ? "\\" : '/',
        is_mswin            => ( $^O =~ /^mswin/i ) ? 1 : 0,
        is_linux            => ( $^O =~ /^linux$/i ) ? 1 : 0,
        is_darwin           => ( $^O =~ /^darwin$/i ) ? 1 : 0,
        inner_wx_load_path      => ( $Wx::wx_path ) ? $Wx::wx_path : '',
        inner_app_extract_path  => '',
        inner_app_relocate_path => '',
        modules             => {},
        so_module_suffix    => '',
        }
    );
    $self->debug_print('Initial wx_path is : ' . $self->get_wx_load_path);
    
    return $self;
}

sub cleanup_on_exit { $_[0]->debug_print('Clean up on Exit'); }

sub post_configure {
    my $self = shift;
    my $runtime = $self->get_runtime;
    if($runtime eq 'PDKCHECK') {
        exit(0) if $self->get_pdkcheck_exit;
    }
}

sub debug_print {
    return 1 if !$_[0]->get_debug_on;
    print STDERR 'DEBUG : ' . $_[1] . qq(\n);
}

sub get_core_modules { (qw( base core adv )) }
sub is_missing_fatal { ( $_[1] =~ /^(base|core|adv)$/ ) ? 1 : 0; } # not always same list as get_core_modules

sub configure {
    my ($self, $requireoverwrite) = @_;
    
    $self->set_require_overwrite($requireoverwrite);
    
    $self->config_system();
    $self->config_modules();
    $self->config_environment();
    
    my $runtime = $self->get_runtime;
    $self->debug_print('preparing Wx for runtime ' . $runtime);
    
    $self->prepare_perl     if $runtime eq 'PERL';        
    $self->prepare_pdkcheck if $runtime eq 'PDKCHECK';     
    $self->prepare_perlapp  if $runtime eq 'PERLAPP';     
    $self->prepare_parlexe  if $runtime eq 'PARLEXE';     
        
    $self->debug_print('Runtime ' . $runtime . ' Preparation complete');
    
    #----------------------------------------------------
    # return here for standard perl before Mini is loaded
    #----------------------------------------------------
    
    return if $runtime eq 'PERL';
    
    $self->debug_print('Preparing Load Paths for Wx');
    
    $self->prepare_load_paths;
    
    $self->debug_print('Load Paths Complete');
    
    my $requestrelocate;
    if($runtime eq 'PDKCHECK') {
        $requestrelocate = $self->get_relocate_pdkcheck;
    } elsif( $runtime eq 'PERLAPP') {
        $requestrelocate = $self->get_relocate_packaged;
    }
    
    if ($self->get_relocateable && $requestrelocate) {
        $self->debug_print('Relocating extracted modules for Wx');
        $self->relocate_wx;
        $self->debug_print('Relocation Complete');
    }
    
    $self->debug_print('Preparing and Loading Wx');
    
    #################################################################
    
    $self->run_wx_start; # THIS LOADS WX
    
    #################################################################
    
    $self->debug_print('Wx Load Complete');
    
    $self->before_config_return();
}

sub config_system { 1; }

sub config_modules {
    my $self = shift;
    
    my $modulesuffix = $self->get_so_module_suffix || ''; # module suffix can be undef
    
    foreach my $modulekey ( keys (%{ $Wx::dlls })) {
        if(exists( $Wx::dlls->{$modulekey} ) && $Wx::dlls->{$modulekey}) {
            
            $self->get_modules->{$modulekey} =
                { filename => $Wx::dlls->{$modulekey} . $modulesuffix,
                  loaded => 0,
                  libref => undef,
                  missing_fatal => $self->is_missing_fatal($modulekey),
                };
            }
    }
    
    my $basemodule = ( exists($self->get_modules->{base}) )
        
        ? $self->get_modules->{base}->{filename}
        : $self->get_modules->{core}->{filename};
        
    $self->set_basemodule($basemodule);
}

sub config_environment {
    my $self = shift;
    #------------------------------------------------------------
    # determine if we are run as script, PAR, PerlApp
    #------------------------------------------------------------
    if(my $pdkversion = $PerlApp::VERSION) {
        # PerlApp::VERSION is definitive for PerlApp
        my @verparts = split(/\./, $pdkversion);
        $pdkversion = '';
        for (@verparts) {
            $pdkversion .= sprintf("%04d", $_);
        }
        $pdkversion =~ s/^0+//;
        #die q(This version of Wx::Perl::Packager requires PDK version 7.1 or greater) if( $pdkversion < 700010000 );
        my $execpath = PerlApp::exe();
        
        if($execpath =~ /pdkcheck/) {
            if($self->get_pdkcheck_handle) {
                $self->set_runtime('PDKCHECK');
                $self->set_packaged(0);
            } else {
                $self->set_runtime('PERL');
                $self->set_packaged(0);
            }
        } else {
            $self->set_runtime('PERLAPP');
            $self->set_packaged(1);
        }
        
    } elsif($ENV{PAR_0} && -f($ENV{PAR_0})) {
        $self->set_runtime('PARLEXE');
        $self->set_packaged(1);
    } else {
        # we are perl - reiterate defaults
        $self->set_runtime('PERL');
        $self->set_packaged(0);
    }
    #------------------------------------------------------------
    # set the extract paths and relocate paths
    #------------------------------------------------------------
    
    #------------------------------------
    # RUNTIME PERL
    #------------------------------------
        
    if($self->get_runtime() eq 'PERL') {
        $self->set_relocateable(0);
            
    #------------------------------------
    # RUNTIME PERLAPP & PDKCHECK
    #------------------------------------
    
    } elsif($PerlApp::VERSION) {
        #--------------------------------
        # IS Wx In the PerlApp::RUNLIB
        #--------------------------------
        my $perlappset = 0;
        my $basemodule = $self->get_basemodule;
        my $runlib = $PerlApp::RUNLIB;
        if( $runlib && (-d $PerlApp::RUNLIB )) {
            my $checkpath = $PerlApp::RUNLIB . '/' . $basemodule;
            if(-f  $checkpath ) {
                $self->set_pdkautopackaged(0);
                $self->set_relocateable(0);
                $self->set_wx_load_path( $checkpath );
                $perlappset = 1;
                
                # final check
                die qq(Cannot find directory $checkpath) if !-d $checkpath;
                
            }
        }
        #--------------------------------
        # Were Wx modules bound manually
        #--------------------------------
        if( !$perlappset ) {
            my $basefile = PerlApp::extract_bound_file($basemodule);
            # user packaged
            if( $basefile ) {
                if($basefile =~ /^(.*)[\\\/]\Q$basemodule\E$/) {
                    my $regpath = $1;
                    die qq(Cannot find directory $regpath) if !-d $regpath;
                    $self->set_app_extract_path($regpath);
                    $self->set_wx_load_path($regpath);
                    $self->set_relocateable(1);
                    $self->set_pdkautopackaged(0);
                    $perlappset = 1;
                    # final check
                }
        #------------------------------------------
        # OR Were Wx modules bound by PDK heuristic
        #------------------------------------------
            } else {
            # perlapp packaged (we hope )
                $self->set_pdkautopackaged(1);
                #-------------------------------------------------
                #  see if user has packaged wxmain.dll
                #-------------------------------------------------
                {
                    my $wxmainfile = $self->get_module_filename('wx');
                    $self->debug_print(qq(Module Mainfile Path is $wxmainfile));
                    my $dllfile = PerlApp::extract_bound_file($wxmainfile);
                    if($dllfile && -f $dllfile) {
                        $self->debug_print(qq(Module Mainfile FilePath is $dllfile));
                        if($dllfile =~ /^(.*)[\\\/]\Q$wxmainfile\E$/) {
                            my $regpath = $1;
                            die qq(Cannot find directory $regpath) if !-d $regpath;
                            $self->set_app_extract_path($regpath);
                            $self->set_wx_load_path($regpath);
                            $self->set_relocateable(1);
                            $perlappset = 1;
                            
                        }
                    }
                }
                if(!$perlappset) {
                #-------------------------------------------------
                # user may also set a marker 'wxextractmarker'
                #-------------------------------------------------
                    my $markerfile = PerlApp::extract_bound_file('wxextractmarker');
                    if($markerfile && -f $markerfile) {
                        if($markerfile =~ /^(.*)[\\\/]wxextractmarker$/) {
                            my $regpath = $1;
                            die qq(Cannot find directory $regpath) if !-d $regpath;
                            $self->set_app_extract_path($regpath);
                            $self->set_wx_load_path($regpath);
                            $self->set_relocateable(1);
                            $perlappset = 1;
                        }
                    }
                }
                if(!$perlappset) {
                #-------------------------------------------------
                # No handy marker :-(
                #-------------------------------------------------
                    # check the first item in the path
                    # if author has placed Wx::Perl::Packager at start of
                    # script, that is where it will be.
                    # we will limit search to one level of
                    # path as unexpected stuff may (will) happen
                    # if we traverse further
            
                    my $delim = $self->get_path_delim();
                    my @envpaths = split(/$delim/, $ENV{PATH});
                    my $pdkdirpath = shift @envpaths;
                    $pdkdirpath =~ s/\\/\//g;
                    $pdkdirpath =~ s/\/$//;
                    my $fpath = qq($pdkdirpath/$basemodule);
                    if($fpath && (-f $fpath)) {
                        $self->set_relocateable(1);
                        $perlappset = 1;
                        $self->set_app_extract_path($pdkdirpath);
                        $self->set_wx_load_path($pdkdirpath);
                    }
                }
            }
        }
    #------------------------------------
    # RUNTIME PARLEXE
    #------------------------------------
    
    } elsif($self->get_runtime() eq 'PARLEXE') {
        $self->set_relocateable(0);
        # the extract path we get from PAR
        # could be wxlib + module
        # or just module
        my @ldpath = split(/[\\\/]/, $ENV{PAR_0});
        pop(@ldpath);
        my $loadpath = join('/', @ldpath);
        $self->set_app_extract_path($loadpath);
        $self->set_wx_load_path($loadpath);
    }
}

sub before_config_return { 1; }

sub prepare_perl { 1; };

sub prepare_pdkcheck { 1;}

sub prepare_perlapp {
    require Wx::Perl::Packager::Mini;
}

sub prepare_parlexe { 1;}

sub prepare_load_paths {
    my $self = shift;
    my $loadpath = $self->get_wx_load_path;
    $self->debug_print(qq(Load Path set $loadpath));
}

sub relocate_wx {
    my $self = shift;
    
    # set the relocate path
    $self->config_relocate_path;
    
    my @core = $self->get_core_modules;
    
    my $targetpath = $self->get_app_relocate_path;
    $self->debug_print(qq(Relocate Path is $targetpath));
    die 'relocate path does not exist' if !-d $targetpath;
    
    my $sourcepath = $self->get_app_extract_path;
    $self->debug_print(qq(Extract Path is $sourcepath));
    die 'extract path does not exist' if !-d $sourcepath;
    
    my $forcewrite = $self->get_require_overwrite;

    for my $dllkey ( @core, 'wx' ) { 
        next if !$self->module_exists($dllkey);
        next if(($dllkey eq 'wx') && (!$self->get_relocate_wx_main));
        my $modulefile = $self->get_module_filename($dllkey);
        my $targetmodulepath = qq($targetpath/$modulefile);
        my $sourcemodulepath = qq($sourcepath/$modulefile);
        next if !-f $sourcemodulepath;
        my $copyrequired = 0;
        $copyrequired = 1 if !-f $targetmodulepath;
        $copyrequired = 1 if $forcewrite;
        if( $copyrequired ) {
            $self->delete_file($targetmodulepath);
            $self->copy_file($sourcemodulepath, $targetmodulepath) 
        }
        $self->delete_file($sourcemodulepath) if $self->get_unlink_relocated;
        $self->debug_print(qq(Relocated $dllkey));
    }
    
    $self->set_core_relocated(1);
    
}

sub do_core_load {
    my $self = shift;
    my $runtime = $self->get_runtime;
    my $coreload = 0;
    if($runtime eq 'PDKCHECK') {
        $coreload = $self->get_loadcore_pdkcheck;
        
    } elsif ($runtime eq 'PERLAPP') {
        $coreload = $self->get_loadcore_packaged;
        
    } elsif ($runtime eq 'PARLEXE') {
        $coreload = $self->get_loadcore_packaged;
        
    }
    
    $self->debug_print(qq(Core Load = $coreload));
    
    #--------------------------------------------------------
    # Load Core Modules
    #--------------------------------------------------------
    
    require DynaLoader;
    
    if( $coreload ) {
        
        for my $dll ( $self->get_core_modules ) {
            next if !$self->module_exists($dll);
            my $module = $self->get_modules->{$dll};
            my $filepath = $self->get_module_core_load_path($dll);
            next if( (!-f $filepath) && ( $module->{missing_fatal} == 0) );
            $self->debug_print(qq(Loading Core Module  $dll  from $filepath) );
            my $libref = DynaLoader::dl_load_file($filepath, 0) or die qq(Failed to load $filepath);
            $module->{libref} = $libref;
            $module->{loaded} = 1;
            push(@DynaLoader::dl_librefs,$libref) if $libref;
        }
        $self->set_core_loaded(1);
    }
}

sub run_wx_start {
    my $self = shift;

    $self->do_core_load;
    
    my $runtime = $self->get_runtime;
    my $method = 'standard';
    
    if($runtime eq 'PDKCHECK') {
        
        $method = $self->get_loadmode_pdkcheck;   
    } elsif ($runtime eq 'PERLAPP') {
        
        $method = $self->get_loadmode_packaged;
    } elsif ($runtime eq 'PARLEXE') {
        
        $method = $self->get_loadmode_packaged;
    }
    
    $self->debug_print(qq(Load Method = $method));
    
    return if(!$method || ($method eq 'standard') );
    
    #--------------------------------------------------------
    # Set Load / Unload Subs
    #--------------------------------------------------------
    
    my @loadedmodules = ();

    #---------------------------------
    # start Wx
    #---------------------------------
    
    require Wx;
    
    if( $method eq 'packload' ){
        Wx::set_load_function( sub { my $modulekey = shift;
                        my $module = $self->get_modules->{$modulekey};
                        return if !$module; # maybe mono build
                        # don't load twice
                        return if( $module->{loaded} );
                        
                        my $filepath = $self->get_module_wx_load_path($modulekey);
                        $self->debug_print(qq(Loading Plugin $modulekey from $filepath\n));
                        Wx::_load_plugin( $filepath );
                        push( @loadedmodules, $filepath);
                        
                        $module->{loaded} = 1;
                        
                        1; } );

        Wx::set_end_function( sub {
                        
                        
                        if ( $self->get_unload_loaded_plugins ) {
                            while( my $modulefilename = pop @loadedmodules ) {
                                 $self->debug_print(qq(Unloading Plugin $modulefilename));
                                 Wx::_unload_plugin( $modulefilename );
                            }
                        }
                        
                        # if we don't specifically unload dl refs, we get a fault on
                        # exit if we close the app immediatley after startup without
                        # interacting with controls (e.g STC) from the keyboard
                        
                        # conversely, the rmtree command fails when we DO interact
                        # with controls from the keyboard - which is why we  relocate
                        # to a 'permanent' dir for MSWin
                        
                        if( ( $self->get_core_loaded ) && ( $self->get_unload_loaded_core ) ) {
                        
                            my @core = $self->get_core_modules;
                            
                            while(my $dll = pop(@core) ) {
                                my $libref = $self->get_modules->{$dll}->{libref};
                                if ($libref) {
                                    $self->debug_print( qq(Unloading Core Module $dll) );
                                    DynaLoader::dl_unload_file($libref);
                                }
                            }
                        }
                        
                        1; } );
        
    } elsif( $method eq 'nullsub' ){
        
        Wx::set_load_function( sub { 1; } );
        Wx::set_end_function ( sub { 1; } );
    }  
}

sub delete_file {
    my( $self, $target) = @_;
    return if !-f $target;
    chmod 0700, $target;
    unlink $target;
}

sub copy_file {
    my( $self, $source, $target) = @_;
    File::Copy::copy($source, $target);
}

sub move_file {
    my( $self, $source, $target) = @_;
    File::Copy::move($source, $target);
}

sub compare_paths {
    my($self, $one, $two) = @_;
    $one =~ s/\\/\//g;
    $two =~ s/\\/\//g;
    return ( $one eq $two );
}


#------------------------------
# Overloads for paths
#------------------------------

sub set_app_extract_path { $_[0]->set_inner_app_extract_path( $_[0]->setsys_filepath($_[1]) ); }
sub get_app_extract_path { $_[0]->get_inner_app_extract_path; }

sub set_app_relocate_path { $_[0]->set_inner_app_relocate_path( $_[0]->setsys_filepath($_[1]) ); }
sub get_app_relocate_path { $_[0]->get_inner_app_relocate_path; }

sub set_wx_load_path { $_[0]->set_inner_wx_load_path( $_[0]->setsys_filepath($_[1]) ); }
sub get_wx_load_path { $_[0]->get_inner_wx_load_path; }
    
sub module_exists { exists($_[0]->get_modules->{$_[1]} ); }

sub get_module_filename { $_[0]->module_exists($_[1]) ? $_[0]->get_modules->{$_[1]}->{filename} : undef; }

sub get_module_wx_load_path {
    if(my $filename = $_[0]->get_module_filename($_[1])) {
        my $wxpath = $_[0]->get_wx_load_path();
       
        return ( $wxpath ) ? $wxpath . $_[0]->get_path_separator . $filename : $filename;
    } else {
        return undef;
    }
}

sub get_module_app_relocate_path {
    if(my $filename = $_[0]->get_module_filename($_[1])) {
        my $dirpath = $_[0]->get_app_relocate_path();
        
        return $dirpath . $_[0]->get_path_separator . $filename;
    } else {
        return undef;
    }
}

sub get_module_app_extract_path {
    if(my $filename = $_[0]->get_module_filename($_[1])) {
        my $dirpath = $_[0]->get_app_extract_path();
        
        return $dirpath . $_[0]->get_path_separator . $filename;
    } else {
        return undef;
    }
}

sub get_module_core_load_path {
    if(my $filename = $_[0]->get_module_filename($_[1])) {
        my $dirpath = ( $_[0]->get_core_relocated ) 
            ? $_[0]->get_app_relocate_path
            : $_[0]->get_wx_load_path;
        my $sep = ( $_[0]->get_is_mswin ) ? "\\" : '/';
        
        return ( $dirpath ) ? $dirpath . $sep . $filename : $filename;
    } else {
        return undef;
    }
}
    
sub setsys_filepath {
    my($self, $filepath) = @_;
    $filepath =~ s/\\/\//g;
    return $filepath;
}


#------------------------------------------
# If we have no alternative but to relocate
# wx dlls ........
#------------------------------------------

sub config_relocate_path {
    my $self = shift;
    return if !$self->get_relocateable(); # just in case
    
    # app extract path is writable by us - so create our wxlib extract
    # files side by side
    
    my $appextractpath = $self->get_app_extract_path();
    die qq(error in determining extract paths) if !-d $appextractpath;
    
    # determine where the standard PDK path is
    
    # get a unique extract directory for this application build
    my $runtime = $self->get_runtime();
    my $uid = getlogin || (getpwuid($<))[0];
    my $toplevel = 'wxppl-' . $uid;
    $toplevel =~ s/[^A-Za-z0-9\-_]/_/g;
    
    my $apprelocatedir;
    
    if($runtime eq 'PERLAPP') {
        # get a unique dir for this build in this location
        my $ctx = Digest::MD5->new;
        my $exec = PerlApp::exe();
        $ctx->add( $exec  );
        my $basestatfile = $appextractpath . '/' . $self->get_basemodule();
        $self->debug_print(qq(Base Core extracted module = $basestatfile));
        my $filestat = (-f $basestatfile ) ? (stat($basestatfile))[7]: 'fixed data';
        $ctx->add( $filestat );
        
        if($self->get_relocate_wx_main) {
            # we also relocate wxmain - which means we have to add that to uniqueness
            if( my $wxmain = $self->get_module_filename('wx') ) {
                my $mainstatfile = $appextractpath . '/' . $wxmain;
                $self->debug_print(qq(Wx Main extracted module = $mainstatfile));
                my $mainfilestat = (-f $mainstatfile ) ? (stat($mainstatfile))[7]: 'wxmain data';
                $ctx->add( $mainfilestat );
            }
        }
        
        $apprelocatedir = $ctx->hexdigest;
        
    }   elsif( $runtime eq 'PDKCHECK' ) {
        # we keep the same dir and overwrite
        $apprelocatedir = 'PDKCHECKBUILDING';
    }
    
    # build the directories
    my @paths = split(/[\/\\]/, $appextractpath);
    pop(@paths);
    my $apprunpath = join('/', (@paths, $toplevel));
    mkdir($apprunpath, 0700) if !-d $apprunpath;
    $apprunpath .= '/' . $apprelocatedir;
    mkdir($apprunpath, 0700) if !-d $apprunpath;
    
    $self->set_app_relocate_path($apprunpath);
}

1;