view release on metacpan or  search on metacpan

GUI/woevap.ptk  view on Meta::CPAN

    $millisecond_update_interval = join ' ', @$millisecond_update_interval0;
    $ignore_output_file_column_one = join ' ', @$ignore_output_file_column_one0;
    $output = join ' ', @$output0;
    $queue = join ' ', @$queue0;
    $destination = join ' ', @$destination0;
    $tty = join ' ', @$tty0;
    $trailing_file_list = join ' ', @$trailing_file_list0;

} # end reset_parameters

sub save_window {

    # Open a file selection window and save text widget $w.

    my($fs, $w) = @_;

    my $o = 'xwoevap.out';
    $o = $fs->Show;
    my $replace = 1;
    if ($o ne '') {
	if (-s $o) {
	    $genPerlTk_replace->configure(
                -text => "Replace existing $o?",
            );
	    my $answer = $genPerlTk_replace->Show;
	    $replace = $answer eq 'Yes';
	}
    }
    if ($replace == 1) {
	open(S, ">$o") or warn $OS_ERROR;
	print S $w->get('1.0', 'end');
	close S;
    }

} # end save_window

sub see_view {

    # Position view of the command widget to this command line parameter.
    # Position help window so help information for this parameter is visible
    # and highlighted for a few seconds.

    my ($p, $ce, $help, $index) = @_;

    if ($p =~ /^end$/) {
	    $ce->xview('end');
    } else {
        $ce->xview(index($genPerlTk_command, $p) - 10);
    }

    $help->yview(-pickplace, 'mark_' . $index);
    $help->tag('configure', 'tag_' . $index, 
        -background => $genPerlTk_highlight,
    );
    $help->after(4000, [$help => 'tag', 'configure', 'tag_' . $index,
        -background => ($help->configure(-background))[3]],
    );

} # end see_view

sub update_command {

    # Create the command to execute.

    # BEGIN application specific command line processing.
    # END   application specific command line processing.

    $genPerlTk_command = 'woevap';

    # Build all non-switch parameters that have been specified.

    my($parameter, @l0, @l1, @udi);
    foreach $parameter (qw( number command scale_factor millisecond_update_interval ignore_output_file_column_one output queue destination tty)) {
	no strict qw(refs);
        @l0 = &shellwords($$parameter);
	next if join(' ', @l0) eq '';
	@l1 = @${"${parameter}0"};
        next if $$parameter eq join ' ', @l1;
        @udi = lunion [ldifference \@l0, \@l1], [lintersection \@l0, \@l1];
        $genPerlTk_command .=
            " -$parameter '" . join("' -$parameter '", @udi) . "'";
    }

    # Build all switch parameters that have been specified.

    foreach $parameter (qw( verbose)) {
	no strict qw(refs);
        next if $$parameter eq "NOT_${parameter}";
	$genPerlTk_command .= " -${parameter}";
    }

    $genPerlTk_command .= ' ' . $trailing_file_list if
        defined $trailing_file_list;

    return $genPerlTk_command;

} # end update_command

sub update_checkbutton_list {

    # Toggle $val in $var.

    my($var, $val) = @_;

    my @l = split ' ', $$var;
    my $i = lsearch $val, @l;
    if ($i >= 0) {
	splice @l, $i, 1;
    } else {
	push @l, $val;
    }
    $$var = join ' ', @l;
    update_command;

} # end update_check_button_list

# Signal handlers.

$SIG{PIPE} = 'IGNORE';

# Initialize global Evaluate Parameters variables.

$number0 = ['123'];
$verbose0 = 'NOT_verbose';
$command0 = ['"ps -el"'];
$scale_factor0 = ['1.2340896e-1'];
$millisecond_update_interval0 = ['$required'];
$ignore_output_file_column_one0 = ['TRUE'];
$output0 = ['stdout'];
$queue0 = ['printer'];
$destination0 = ['`hostname`'];
$tty0 = ['/dev/console', '/dev/tty0', '/dev/tty1'];
$trailing_file_list0 = [''];

# Initialize global generate_PerlTk_program variables.

$genPerlTk_doit_once = 0;
$genPerlTk_required_dialog = $genPerlTk_mw->Dialog(
    -title   => 'Alert',
    -text    => 'Parameter "_" required a value.',
    -bitmap  => 'error',
    -buttons => [qw(Cancel)],
    -wraplength => '6i',
);
$genPerlTk_stdin_dialog = $genPerlTk_mw->Dialog(
    -title   => 'Alert',
    -text    => 'Is standard input really the file you want to process?',
    -bitmap  => 'warning',
    -buttons => [qw(Cancel OK)],
);
$genPerlTk_fini = 0;

$genPerlTk_highlight = $genPerlTk_mw->optionGet(qw(highlight Highlight));
if (not defined $genPerlTk_highlight) {
    if ($genPerlTk_mw->depth > 1) {
	$genPerlTk_highlight = 'yellow';
    } else {
	$genPerlTk_highlight = 'white';
    }