Tk::Wizard::Installer::Win32 - Win32-specific routines for Tk::Wizard::Installer

	-relief -highlightthickness -background -borderwidth -cursor
	-highlightcolor -foreground -font

	-title -subtitle -text

use strict;
use warnings;

package Tk::Wizard::Installer::Win32;
our $VERSION = do { my @r = ( q$Revision: 2.21 $ =~ /\d+/g ); sprintf "%d." . "%03d" x $#r, @r };

use lib "../../../"; # dev
use Carp ();
use Cwd;
use File::Path;
use Exporter;
use Tk::Wizard ':use' => 'FileSystem';
use base 'Tk::Wizard::Installer';

use vars '@EXPORT';
@EXPORT = ("MainLoop");

use constant DEBUG_FRAME => 0;

# use Log4perl if we have it, otherwise stub:
# See Log::Log4perl::FAQ
BEGIN {
	eval { require Log::Log4perl; };
	if($@) {
		no strict qw"refs";
		*{__PACKAGE__."::$_"} = sub { } for qw(TRACE DEBUG INFO WARN ERROR FATAL);
	} else {
		no warnings;
		no strict qw"refs";
		require Log::Log4perl::Level;
		Log::Log4perl::Level->import(__PACKAGE__);
		Log::Log4perl->import(":easy");
		if ($Log::Log4perl::VERSION < 1.11){
			*{__PACKAGE__."::TRACE"} = *DEBUG;
		}
	}

    use Win32::Shortcut;
    require Win32;
    if ( $Win32::VERSION lt 0.2 ) {
        eval 'use Win32::OLE';    # autouse is still not very good?
        die "Could not load Win32::OLE: $@" if $@;
    }
    eval {
    	use Win32;
    	use Win32::TieRegistry( Delimiter => "/", ArrayValues => 0 );
	};
	die $@ if $@;
}

sub register_with_windows {
    my ( $self, $args ) = ( shift, {@_} );
    return 1 if $^O !~ /mswin32/i;

    unless ($args->{DisplayName}
        and $args->{UninstallString}
        and ( $args->{uninstall_key_name} or $args->{app_path} ) ){
        die __PACKAGE__
          . "::register_with_windows requires an argument of name/value pairs which must include the keys 'UninstallString', 'uninstall_key_name' and 'DisplayName'";
    }

    if ( not $args->{UninstallString} and not $args->{app_path} ) {
        die __PACKAGE__ . "::register_with_windows requires either argument 'app_path' or 'UninstallString' be set.";
    }

    if ( $args->{app_path} ) {
        $args->{app_path} = "perl -e '$args->{app_path} -u'";
    }
    my $uninst_key_ref =
      $Registry->{'LMachine/SOFTWARE/Microsoft/Windows/CurrentVersion/Uninstall/'}->CreateKey(
		  $args->{uninstall_key_name}
	);
    Carp::confess "Perl Win32::TieRegistry error" if !$uninst_key_ref;

    foreach my $i ( keys %$args ) {
        next if $i =~ /^(app_path|uninstall_key_name)$/g;
        $uninst_key_ref->{"/$i"} = $args->{$i};
    }

    return 1;
}

sub addStartMenuPage {
    my ( $self, $args ) = ( shift, {@_} );
    # return $self->addPage( sub { $self->_page_start_menu($args) } );
	my %btn_args =
		map { my $x = delete $args->{$_}; $_ => $x }
		grep { /ButtonAction$/ }
		keys %$args;
	return $self->addPage( sub { $self->_page_start_menu($args) }, %btn_args );
}

sub _page_start_menu {
    local *DIR;
    my ($self) = (shift);
    my $args;
    if ( ref $_[0] eq 'HASH' ) {
        $args = shift;
    }
    else {
        $args = {@_};
    }
    my $cwd    = cwd;
    my $do_set = 1;

    Carp::croak "You must set -variable parameter"
		if not exists $args->{-variable};

    $args->{-user} ||= 'common';

    $args->{-background} = 'white'  unless exists $args->{-background};

    $args->{-relief}     = 'sunken' unless exists $args->{-relief};

    $args->{-border}     = 1        unless exists $args->{-border};

    $args->{-listHeight} = 10       unless exists $args->{-listHeight};

    $args->{-title}    ||= "Create Shortcuts";

    $args->{-subtitle} ||= "Please select where to place an icon on the start menu";

    $args->{-text}     ||= "
If you want the new Program Group to be installed within an existing
folder in your Start Menu, select that folder below.
If you do not want to install the new Program in your Start Folder,
check the checkbox below.";

    $args->{-label_nochoice} ||= "Do not create a shortcut on the Start Menu";

    $self->{-program_group} = $args->{-program_group};

    my $common_formatting = {};

    $common_formatting->{-background} = $args->{-background}
      if exists $args->{-background};

    $common_formatting->{-relief} = $args->{-relief} if exists $args->{-relief};

    $common_formatting->{-highlightthickness} = $args->{-highlightthickness}
      if exists $args->{-highlightthickness};

    $common_formatting->{-borderwidth} = $args->{-borderwidth}
      if exists $args->{-borderwidth};

    $common_formatting->{-cursor} = $args->{-cursor} if exists $args->{-cursor};

    $common_formatting->{-highlightcolor} = $args->{-highlightcolor}
      if exists $args->{-highlightcolor};

    $common_formatting->{-foreground} = $args->{-foreground}
      if exists $args->{-foreground};

    $common_formatting->{-font} = $args->{-font} if exists $args->{-font};

    # Don't pass these to other modules
    my $variable = $args->{-variable};
    delete $args->{-variable};
    my $group = $args->{-program_group};
    delete $args->{-program_group};

    my $frame = $self->blank_frame(%$args);
    DEBUG_FRAME && $frame->configure( -background => 'blue' );

    if ( $Win32::VERSION gt 0.1999999 ) {
        $self->{startmenu_dir_current} = eval('Win32::GetFolderPath(Win32::CSIDL_STARTMENU)') . '\Programs';
        $self->{startmenu_dir_common}  = eval('Win32::GetFolderPath(Win32::CSIDL_COMMON_STARTMENU)') . '\Programs';
    }

    # The above may not work if non-standard/non-English setup, so:
    if (   not $self->{startmenu_dir_current}
        or not $self->{startmenu_dir_common} ) {
        my $WshShell = eval 'Win32::OLE->CreateObject("WScript.Shell")';
        if ( ref $WshShell eq 'Win32::OLE' ) {
            $self->{startmenu_dir_current} = $WshShell->SpecialFolders(17);
            $self->{startmenu_dir_common}  = $WshShell->SpecialFolders(2);
        }
        else {
            warn "Could not find special folders using Win32 or OLE!";
            return undef;
        }
    }

    # The default is to install for all users:
    my $dir_parent = $self->{startmenu_dir_common};
    if ( $args->{-user} eq 'current' ) {
        $dir_parent = $self->{startmenu_dir_current};
    }

    # This is the default answer, if the user just clicks "Next":
    $$variable = "$dir_parent\\$group";

    # Recursively read the Start Menu folder, building up a list of
    # all folders in there:
    my @asTry = ($dir_parent);
    my @asDir;

  	TRY_DIR:
    while (@asTry) {
		local $" = ',';

        # $sTry is the FULL path of this folder:
        my $sTry = shift @asTry;
        next TRY_DIR if !-d $sTry;
        push @asDir, $sTry;
        opendir DIR, $sTry
          or Carp::croak "Can not open the start menu ($sTry): $!";
        my @asTryChildren = sort readdir DIR;

        push @asTry, grep { !m/^\.\.?$/ && s/^(.*)$/$sTry\\$1/ && -d } @asTryChildren;
        closedir DIR or warn $!;
    }

    my $text = $frame->Label(
        -justify      => 'left',
        -textvariable => $variable,
        -anchor       => 'w',
        %$common_formatting,
      )->pack(
        -side   => 'top',
        -anchor => 'w',
        -fill   => 'x',
        -padx   => 10,
      );

    $text->configure( -background => 'magenta' ) if DEBUG_FRAME;

    my $hlist = $frame->Scrolled(
		'HList',
		-scrollbars => "osoe",
		-selectmode => 'single',
		-height     => $args->{-listHeight},
		-itemtype   => 'text',
		-separator  => '\\',
		-browsecmd  => sub {
			$$variable = shift;
			$$variable .= "\\" . $group if $group;
        },
        %$common_formatting,
	)->pack(
        -expand => 1,
        -fill   => 'both',
        -padx   => 10,
        -pady   => 5,
	);
    $hlist->configure( -background => 'yellow' ) if DEBUG_FRAME;

    foreach my $i (@asDir) {
        my $t = $i;
        $t =~ s!\Q$dir_parent!!;
        $t =~ s!\A\\!!;
        if ( !$hlist->info( "exists", $t ) ) {

            DEBUG "trying to add i=$i= t=$t= to hlist...\n";
            $hlist->add(
                 $t,
                -text => $t,
                -data => $i,
            );
        }
    }

    $self->{_hlist_active_} = 0;
    $self->_toggle_hlist( $hlist, $variable, $group );
    if ( !$args->{-disable_nochoice} ) {
        my $b = $frame->Checkbutton(
            -text    => $args->{-label_nochoice},
            -anchor  => 'w',
            -command => [ \&_toggle_hlist, $self, $hlist, $variable, $group ],
          )->pack(
            -side   => 'left',
            -anchor => 'w',
            -padx   => 10,
            -pady   => 5,
          );
        $b->configure( -background => 'red' ) if DEBUG_FRAME;
    }

    return $frame;
}


sub _toggle_hlist {
    my $self = shift;

    # Required arg1 = the Scrolled HList widget:
    my $hlist = shift || return;

    # Required arg2 = reference to variable that HList is bound to:
    my $rs = shift || return;

    # Optional arg3 = the group string being added onto the path:
    my $group = shift;
    $self->{_hlist_active_} = !$self->{_hlist_active_};

    my $w = $hlist->Subwidget('scrolled');
    if ( !$self->{_hlist_active_} ) {
        $$rs = '';
        # Deactivate the entire HList.  HList does not support the
        # -state configuration option, therefore we use the bindtags
        # "hack":
        $self->{_hlist_bindtags_} = $w->bindtags;
        $w->bindtags( ['Freeze'] );
    }

    else {
        $$rs = $hlist->info('anchor');
        $$rs .= "\\" . $group if $group;
        if ( $self->{_hlist_bindtags_} ) {
            $w->bindtags( $self->{_hlist_bindtags_} );
        }
    }
}

sub callback_create_shortcut {
    my ( $self, $args ) = ( shift, {@_} );
    Carp::croak "-target is required (you gave " . ( join ", ", keys %$args ) . ")"
      unless defined $args->{-target} and $args->{-target} ne '';

    Carp::croak "-save_path is required  (you gave " . ( join ", ", keys %$args ) . ")"
      unless defined $args->{-save_path} and $args->{-save_path} ne '';

    $args->{-arguments}   = '' unless exists $args->{-arguments};
    $args->{-workingdir}  = '' unless exists $args->{-workingdir};
    $args->{-description} = '' unless exists $args->{-description};
    $args->{-show}        = 0  unless exists $args->{-show};
    $args->{-hotkey}      = 0  if not exists $args->{-hotkey} or $args->{-hotkey} eq '';
    $args->{-iconpath}    = 0  unless exists $args->{-iconpath};
    $args->{-iconindex}   = 0  unless exists $args->{-iconindex};
    delete $self->{-program_group} if exists $args->{-no_program_group};

    if (    exists $self->{-program_group}
        and exists $args->{-save_path} ) {
        my ( $base, $file ) = $args->{-save_path} =~ /(.*?)([^\/\\]+)$/;

        # Historical error on $self->{-program_groups}
        $base .= "\\" . ($self->{-program_groups} || $self->{-program_group});

        mkpath $base if !-e $base;
        $args->{-save_path} = $base . "\\" . $file;
        $args->{-save_path} =~ s/[\\\/]+/\\/g;
    }

    if (    $args->{-target} =~ /^(ht|f)tp:\/\//
        and $args->{-save_path} !~ /\.uri$/i ) {
        Carp::croak "Internet shortcuts require a .uri ending!";
    }

    if (    $args->{-target} !~ /^(ht|f)tp:\/\//
        and $args->{-save_path} =~ /\.uri$/i ) {
        Carp::croak "Only internet shortcuts require a .uri ending!";
    }

    my $s = Win32::Shortcut->new;
    $s->Set(
        $args->{-target},
        $args->{-arguments},
        $args->{-workingdir},
        $args->{-description},
        $args->{-show},
        $args->{-hotkey},
        $args->{-iconpath},
        $args->{-iconindex},
    );
    my $r = $s->Save(
		$args->{-save_path}
	) ?
		$args->{-save_path} : undef;

    $s->Close;

    return $r;
}

sub callback_create_shortcuts {
    my $self = shift;
    my @paths;
    foreach (@_) {
        Carp::confess "Not a hash reference" unless ref $_ eq 'HASH';
        $self->callback_create_shortcut(%$_);
    }
    return wantarray ? @paths : \@paths;
}


sub Tk::Error::RedefineIfNeeded {
    local $\ = "\n";
    print STDERR @_;
}

1;

__END__