#!/usr/bin/perl

use strict;
use File::Spec;

my $ans = config_xls_cb();
print "$ans\n";


#____________________________________________________________________
sub config_xls_cb {

    my $detailsA_fn = 'detailsA.xls';
    my $detailsA_abs_fn      # 'C:\aa\detailsA.xls'
        = File::Spec->catfile( 'c:', 'aa', 'detailsA.xls' );

    my $ansA_txt = qq[Edit '$detailsA_fn' file];
    my $ansB_txt = 'Exit';
    my $text_for_popup_box = << "END_EDIT_DETAILS";

Click [$ansA_txt] to define things.
You will be editing '$detailsA_abs_fn'.

Click [$ansB_txt] to leave this window.
END_EDIT_DETAILS

    my ( $answer )
        = custTk::open_unique_tk_n_ask_question(
            $text_for_popup_box,
            [ $ansA_txt, $ansB_txt ],
            undef,  # placeholder for font to present the question in
            sub {
                my $users_choice = shift;
                my $preserve_tk_widget = 1; # controls whether to clos
+e widget
                if ( $users_choice eq $ansA_txt ) {
                    gs::system_start_file( $detailsA_abs_fn );
                    return ( $preserve_tk_widget );
                }
                else {
                    return ( $preserve_tk_widget = 0 ); # causes $mw->
+destroy()
                }
            },
            'Work with details file',
        );

}


package custTk;
sub open_unique_tk_n_ask_question {
    eval("use Tk");
    # Presents a stand-alone Tk window whose primary purpose is to:
    #     present a QUESTION and then a set of POSSIBLE ANSWERS that
    #     appear via a Radiobutton.
    # QUESTION could also be a STATEMENT w/ just one POSSIBLE ANSWER (
+e.g. Ok).
    # Since the answers will be presented 'left to right', the questn 
+should be
    # punctuated w/ "\n" often to keep the answers from only being on 
+the left
    #
    # $question is something like:
    #      "Is the 'RelayFax Fax Redirector'\nyour default printer?\n"
    #   $poss_answer_ar is something like:  [ 'Yes', 'No' ]
    #
    # or perhaps you want to display a warning message and also log it
+:
    #   my $warn_msg
    #       = "The filename of '$config_settings_file'\n"
    #       . "does not seem to be of type 'txt' or 'xls'.\n";
    #   warn $warn_msg;
    #   custTk::open_unique_tk_n_ask_question( $warn_msg, [ 'Ok' ] );
    #
    # The user's answer will load into $answer, and $answer will be pa
+ssed
    # as the first parameter to a callback for the Radiobutton that yo
+u
    # optionally supply via $custom_callback_xr
    #
    # If you don't supply a callback, the callback for the Radiobutton
    # will merely destroy the popup window and cause a return of ($ans
+wer).


    my (
        $question,
        $poss_answer_ar,
        $user_font_choice,
        $custom_callback_xr,
            # A callback that must be able to respond to the clicking
            # of any of the designated Radiobuttons.  The callback's r
+eturn
            # will be treated as a boolean that, if true, keeps the wi
+ndow
            # open to allow the clicking of other Radiobuttons.
            # Thus functions/buttons can be invoked one by one.
            # Note:  this makes it critical that the callback return a
            # false or undef value (e.g. via 'return') if clicking a g
+iven
            # answer should close the window once the callback is fini
+shed.
            # Otherwise, the 'true' status of the last expression of t
+he
            # callback will keep the window open.
        $window_title,
                ) = @_;


    my $mw = MainWindow->new;

    if ( $window_title ) {
        $mw->title( $window_title );
    }

    my $answer = '';
    my $final_answer = '';
    $user_font_choice ||= 'arial 10 bold';

    # Prepare a Listbox widget to hold/display the lines of the $quest
+ion
    my @listbox_items = split /\n/, $question;
    my $listbox = $mw->Scrolled(
                    "Listbox",
                    -scrollbars => 'onoe',    # 'onoe': optional north
+, east
                    #-font => "arial 10 bold",
                    -font => $user_font_choice,
                    -selectmode => 'single',
                    -height => scalar @listbox_items,
                    -width => 0,
                            )->pack(
                                -side => 'top',
                                -fill => 'both',
                                -expand => 1
                                    );
    $listbox->insert( 'end', @listbox_items );

    foreach my $poss_answer ( @$poss_answer_ar ) {
#warn "poss_ans 835:  '$poss_answer'\n";
        $mw->Radiobutton(
            -text => $poss_answer,
            -value => $poss_answer,
            -variable => \$answer,
            -padx => 10,
            -command =>
                    sub {
#warn "TkAns82: '$answer'\n";
                        my $preserve_unique_tk_after_callback;
                        if ( $custom_callback_xr ) {
                            ( $preserve_unique_tk_after_callback )
                                = $custom_callback_xr->( $answer );
                        }
                        $preserve_unique_tk_after_callback ||= 0;

                        $mw->destroy()
                            unless $preserve_unique_tk_after_callback;
                    },
        )->pack(
            -side => (
                1 == scalar @$poss_answer_ar    # if only one possible
+ ans
                    ? 'bottom'                  # then center its labe
+l
                    : 'left'                    # else display rt to l
+eft
            )
        );


    }

    # Thanks to perlmonks post 224263 by zentara, 1/4/03
    $mw->withdraw; #avoid the jumping window bug 
    $mw->Popup;

    MainLoop();

#warn "TkAns83: '$answer'\n";
    return ( $answer );
                # Getting flaky results from this.  (In other usages.)
                # Why doesn't this seem to return a result to dd_conf?
                # Hmm, maybe need waitWindow() or OnDestroy for RadioB
+uttons
                # to freeze action at this window til $go_rb is clicke
+d
}



package gs;
sub system_start_file {
    my ( $file_to_run, $dont_use_start ) = @_;

    unless ( -f $file_to_run ) {
        my $warn_msg
           = "red_915ssf  Failed to build a proper path name for\n"
           . "'$file_to_run'\n";
        warn $warn_msg;
        custTk::open_unique_tk_n_ask_question( $warn_msg, [ 'Ok' ] );
        return ();
    }

#warn "path537: '$ENV{PATH}'\n";
    my $prob_found
        = $dont_use_start
            ? system $file_to_run
            : system 'start', $file_to_run;

    if ( $prob_found ) {
        my $warn_msg
          = "red_915ssfpf '$prob_found' There was a problem in trying 
+to open\n"
          . "'$file_to_run'\n";
        warn $warn_msg;
        custTk::open_unique_tk_n_ask_question( $warn_msg, [ 'Ok' ] );
        return ();
    }

    return ();
}
[download]