package Tk::Wizard::Installer::Win32;

=head1 NAME

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

=cut

use strict;
use warnings;

use lib "../../../"; # dev
use Carp;
use Cwd;
use Data::Dumper;    # for debugging only
use File::Path;
use Exporter;
use Tk::Wizard ':use' => 'FileSystem';
use base 'Tk::Wizard::Installer';

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

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

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");
		# It took four CPAN uploads and tests to workout why
		# one user was getting syntax errors for TRACE: must
		# be the Mithrasmas spirit (hic):
		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 $@;
}


=head1 DESCRIPTION

As a sub-class of L<Tk::Wizard|Tk::Wizard> and
L<Tk::Wizard::Installer|Tk::Wizard::Installer>, this module offers
all of those methods and means, plus the below, which
are thought to be specific to the Microsoft Windows platform.

If you are looking for a freeware software installer that is not
dependant upon Perl, try Inno Setup - C<http://www.jrsoftware.org/>. It's
so good, even Microsoft have been caught using it.

If you are looking for a means to update the Windows C<Path> variable,
have a look for I<PathTool.exe>, a tiny Windows 32-bit executable
by Luke Bailey (C<luke@notts.flexeprint.com>). This tool can also be
used to add new, persistant environment variables to the system.

=head1 METHODS

=head2 register_with_windows

Registers an application with Windows so that it can be "uninstalled"
using the I<Control Panel>'s I<Add/Remove Programs> dialogue.

An entry is created in the Windows' registry pointing to the
uninstall script path. See C<UninstallString>, below.

Returns C<undef> on failure, C<1> on success.
Does nothing on non-MSWin32 platforms

Aguments are:

=over 4

=item uninstall_key_name

The name of the registery sub-key to be used. This is transparent to the
end-user, but should be unique for all applications.

=item UninstallString

The command-line to execute to uninstall the script.

According to Microsoft at L<http://msdn.microsoft.com/library/default.asp?url=/library/en-us/dnwue/html/ch11d.asp>:

"You must supply complete names for both the DisplayName and UninstallString
values for your uninstall program to appear in the Add/Remove Programs
utility. The path you supply to Uninstall-String must be the complete
command line used to carry out your uninstall program. The command line you
supply should carry out the uninstall program directly rather than from a
batch file or subprocess."

The default value is:

	perl -e '$args->{app_path} -u'

This default assumes you have set the argument C<app_path>, and that it
checks and reacts to the the command line switch C<-u>:

	package MyInstaller;
	use strict;
	use Tk::Wizard;
	if ($ARGV[0] =~ /^-*u$/i){
		# ... Have been passed the uninstall switch: uninstall myself now ...
	}

Or something like that.

=item QuietUninstallString

As C<UninstallString> above, but for ... quiet uninstalls.

=item app_path

Please see the entry for C<UninstallString>, above.

=item DisplayName

=item DisplayVersion

=item Size

The strings displayed in the Control Panel's Add/Remove Programs list.

=item ModifyPath

=item NoRepair NoModify NoRemove

=item EstimatedSize InstallSorce InstallDate InstallLocation

=item AthorizedCDFPrefix Language ProductID

Unknown

=item Comments

=item RegOwner

=item RegCompnay

=item Contact

=item HelpTelephone

=item Publisher

=item URLUpdateInfo

=item URLInfoAbout

=item HelpLink

These are all displayed when the Support Information link
is clicked in the Add/Remove Programs dialogue. The last
should be full URIs.

=back

The routine will also try to add any other parameters to the
registry tree in the current location: YMMV.

=cut

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} );
    die "Perl Win32::TieRegistry error" if !$uninst_key_ref;

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

    return 1;
}

=head2 addStartMenuPage

Adds a page that allows
users to select a location on the Windows "Start Menu",
perhaps to add a shortcut there.

This routine does not currently create the directory in the
I<Start Menu>, nor does it place a link there - see
L</callback_create_shortcut> for that. Rather, the
caller supplies a C<-variable> parameter that is a reference
to a scalar which, once the page is 'run', will contain
either the path to the user's chosen directory, or C<undef>
if the option to not select was chosen.

In addition, when the page is 'run', it places the path to the
current user's I<Start Menu/Programs> directory into the object
field C<startmenu_dir_current>, and the path to the common
I<Start Menu/Programs> in the object field C<startmenu_dir_common>.

The physical creation of the shortcut is left as an exercise to the reader.
Have a look at the C<$mkdir> C<Button> in C<Tk::Wizard/page_dirSelect>.

=over 4

=item -user

Set to C<all> or C<current> to list the "Start Menu" for all users, or
just the current user.  Default is C<all>.  Note that in the current
versions of Windows in common use, if there exist entries with the
same name in both the common and current user's I<Start Menu>, the
entry in the common menu takes precedence.

=item -variable

A reference to a variable that, when the page is completed,
will contain the directory the user has chosen to create an item in. Note
this is I<not> the full path: see above.

=item -program_group

Name of the directory to create on the start menu, if any.  If
defined, this will be appended to any selection the user makes.  Note
that since addStartMenuPage() is just the GUI part, no directory will
actually be created until C</callback_create_shortcut> is called.

=item -disable_nochoice

Set to prevent the display of the checkbox which allows the user not
to use this feature.  See C<-label_nochoice>, below.

=item -label_nochoice

If the parameter C<-disable_nochoice> has not been set,
C<-label_nochoice> should contain text to use for the label by the
checkbox which disables choices on
this page and causes the page to set the C<-variable> parameter to
C<undef>.
Default text is C<Do not create a shortcut on the Start Menu>.

=item -listHeight

Height of the list box, default is C<10> but you may
vary this if your C<-text> attribute takes up more or less much room.

=back

Accepts the Standard Options that are common to the C<HList> and
C<Label> widgets, but does not accept aliases:

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

You can supply the common Tk::Wizard options:

	-title -subtitle -text

This method will initially attempt to use F<Win32.pm>; failing that,
it will attempt to use a Windows Scripting Host object created via
L<Win32::OLE|Win32::OLE>.  If both fail (WSH only existing by default
in Win98 and above), the routine will return C<undef>, rather than a
page frame object.  This may not be ideal but works for me --
suggestions welcomed for a better idea.

=cut

sub addStartMenuPage {
    my ( $self, $args ) = ( shift, {@_} );
    return $self->addPage( sub { $self->_page_start_menu($args) } );
}

sub _page_start_menu {
    my ($self) = (shift);
    my $args;
    if ( ref $_[0] eq 'HASH' ) {
        $args = shift;
    }
    else {
        $args = {@_};
    }
    local *DIR;
    my $cwd    = cwd;
    my $do_set = 1;
    croak "You must set -variable parameter"
      unless 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_args;    # formatting
    $common_args->{-background} = $args->{-background}
      if exists $args->{-background};
    $common_args->{-relief} = $args->{-relief} if exists $args->{-relief};
    $common_args->{-highlightthickness} = $args->{-highlightthickness}
      if exists $args->{-highlightthickness};
    $common_args->{-borderwidth} = $args->{-borderwidth}
      if exists $args->{-borderwidth};
    $common_args->{-cursor} = $args->{-cursor} if exists $args->{-cursor};
    $common_args->{-highlightcolor} = $args->{-highlightcolor}
      if exists $args->{-highlightcolor};
    $common_args->{-foreground} = $args->{-foreground}
      if exists $args->{-foreground};
    $common_args->{-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 $sDirParent = $self->{startmenu_dir_common};
    if ( $args->{-user} eq 'current' ) {
        $sDirParent = $self->{startmenu_dir_current};
    }

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

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

        # $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 croak " EEE can not open the start menu ($sTry): $!";
        my @asTryChildren = sort readdir DIR;
        local $" = ',';

        # print STDERR " DDD asTryChildren = (@asTryChildren)\n";
        push @asTry, grep { !m/^\.\.?$/ && s/^(.*)$/$sTry\\$1/ && -d } @asTryChildren;
        closedir DIR or warn;
    }    # while TRY_DIR
    my $text = $frame->Label(
        -justify      => 'left',
        -textvariable => $variable,
        -anchor       => 'w',
        %$common_args,
      )->pack(
        -side   => 'top',
        -anchor => 'w',
        -fill   => 'x',
        -padx   => 10,
      );
    DEBUG_FRAME && $text->configure( -background => 'magenta' );
    my $hlist = $frame->Scrolled(
        'HList',
        -scrollbars => "osoe",
        -selectmode => 'single',
        -height     => $args->{-listHeight},
        -itemtype   => 'text',
        -separator  => '\\',
        -browsecmd  => sub {
            $$variable = shift;
            $$variable .= "\\" . $group if $group;
        },
        %$common_args,
      )->pack(
        -expand => 1,
        -fill   => 'both',
        -padx   => 10,
        -pady   => 5,
      );    # HList
    DEBUG_FRAME && $hlist->configure( -background => 'yellow' );
    foreach my $i (@asDir) {
        my $t = $i;
        $t =~ s!\Q$sDirParent!!;
        $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,
          );
        DEBUG_FRAME && $b->configure( -background => 'red' );
    }

    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_} );
        }
    }
}    # toggle_hlist


=head1 CALLBACKS

=head2 callback_create_shortcut

A convenience interface to L<Win32::Shortcut|Win32::Shortcut> method
that creates a shortcut at the path specified.  Parameters are pretty
much what you see when you right-click a shortcut:

=over 4

=item -save_path

The location at which the shortcut should be saved.  This should be
the full path including filename ending in C<.lnk>.

The filename minus extension will be visible in the shortcut.
If the C<-program_group> parameter was passed to
C<METHOD page_start_menu>, the directory it refers to
will be included in the save path you supply.  To avoid
this, either C<undef>ine the object field C<-program_group>,
or supply the parameter C<-no_program_group>.

=item -no_program_group>

See C<-save_path>, above.

=item -target

The shortcut points to this file, directory, or URI -- see notes for
C<-save_path>, above.

=item -workingdir

The working directory for the C<-target>, above.

=item -description

This is what you see when you mouse-over a shortcut
in more "modern" (Win2k/ME+) Windows.

=item -iconpath

Path to the icon file -- an C<.exe>, C<.dll>, C<.ico> or
other acceptable format.

=item -iconindex

Index of the icon in the file if a C<.exe> or C<.dll>.

=item -arguments

Um... it's the second parameter in Win32::Shortcut::Set -
could well be parameters for the target, but I'm too much of
a rush to check. XXX

=item -show

Whether the C<-target>, above, should be
started maximized or minimized. Acceptable values are
the constants:

    SW_SHOWMAXIMIZED SW_SHOWMINNOACTIVE SW_SHOWNORMAL

=item -hotkey

Key combination to activate the shortcut. Probably looks
something like C<ctrl+t>.

=back

On success, returns the C<-save_path>; on failure, C<undef>.

=cut

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

    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}        = '' unless exists $args->{-show};
    $args->{-hotkey}      = '' unless exists $args->{-hotkey};
    $args->{-iconpath}    = '' unless exists $args->{-iconpath};
    $args->{-iconindex}   = '' unless exists $args->{-iconindex};
    undef $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_groups});

        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 )
    {
        croak "Internet shortcuts require a .uri ending!";
    }

    if (    $args->{-target} !~ /^(ht|f)tp:\/\//
        and $args->{-save_path} =~ /\.uri$/i )
    {
        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;
}


=head2 callback_create_shortcuts

Convenience method to create multiple shortcuts at once.
Supply an array of hashes, each hash being arguments
to supply to C<callback_create_shortcut>.

Returns an array or reference to an array that contains
the reults of the shortcut creation.

See L<callback_create_shortcut>.

=cut

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

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

1;

__END__

=head1 CAVEATS AND BUGS

* Error going backwards into a C<addStartMenuPage>.

=head1 CHANGES

Please see the file F<Changes> included with the distribution.

=head1 AUTHOR

Lee Goddard (lgoddard@cpan.org).

=head1 SEE ALSO

L<Tk::Wizard>; L<Tk::Wizard::Installer>;
L<Win32/GetFolderPath>;
L<Win32::Shortcut>;
L<Win32::OLE>.

=head1 KEYWORDS

Wizard; set-up; setup; installer; uninstaller; install; uninstall; Tk; GUI; windows; win32; registry; shortcut;

=head1 AUTHOR

Lee Goddard (lgoddard@cpan.org).

=head1 COPYRIGHT

Copyright (C) Lee Goddard, 11/2002 - 01/2008 ff.

Made available under the same terms as Perl itself.