view release on metacpan or  search on metacpan

lib/Getopt/Janus/Tk.pm  view on Meta::CPAN

  my $run_flag_set = sub { $run_flag = 1; $m->destroy; return; };
  $m = $self->set_up_window($m, $run_flag_set);

  DEBUG and print "\n";
  Tk::MainLoop();
  DEBUG and print "\n";
  DEBUG and print '', !$run_flag_set ? "Aborting.\n" : "Now running.\n";
  
  undef $m;
  exit unless $run_flag;
  # otherwise fall thru
  return;
}

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

sub set_up_window {
  my($self, $widget, $run_flag_set) = @_;

  my $m = MainWindow->new();
  $m->title( $self->{'title'} )  if  $self->{'title'};
  $m->bind('<Escape>' => [$m, 'destroy'] );
  $m->geometry('+0+0');

  $self->{'width'}  = 0;
  $self->{'height'} = 0;

  my $pane = $m->Scrolled( 'Pane',
   '-scrollbars' => 'osoe',
   '-sticky'     => 'nsew',
   '-gridded'    => 'y'
  );
  $pane->pack( '-fill' => 'both',  '-expand' => 1 );
  
  $self->make_bundles($pane, $m);
  $self->button_bar($pane, $m,
    1,   # was: !@{$self->{'options'} || []},  # whether to focus the OK button
    $run_flag_set,
  );
  $self->place_window($pane, $m);
  $m->focus;
  return $m;
}

# ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

sub make_bundles {
  # Iterate over the options, and for each one, make a BUNDLE of GUI things
  # (a label, some more stuff, a help button, whatever).

  my($self, $pane, $mainwindow) = @_;
  my $them = $self->{'options'} || [];
    
  foreach my $option (@$them) {
    my $method = 'make_bundle_'
     . ( $option->{'type'} || confess "Typeless option?!" );
    $self->$method($option, $pane, $mainwindow);

    # And now a little divider
    my $f = $pane->Frame(qw/  -relief ridge  -bd 1  -height 3  /);
    $f->grid( qw<  -columnspan 3  -sticky ew  > );
    $self->consider_grid_row($f);
  }
  
  return;
}

# ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

sub button_bar {
  my($self, $pane, $mainwindow, $whether_focus_okay, $run_flag_set) = @_;

  # A frame within which we can use pack instead of grid:
  my $button_bundle_frame = $pane->Frame();

  $button_bundle_frame->grid( qw< -columnspan 3  -sticky s > );

  my @button_pack_options = qw< -side left  -pady 9 -padx 9  >;

  my $okay;
  
  ($okay = $button_bundle_frame->Button(
    '-text'    => 'OK',
    '-command' => $run_flag_set,
  ))->pack( @button_pack_options,  );
  
  $button_bundle_frame->Button(
    '-text'    => 'Cancel',
    '-command' => [ $mainwindow => 'destroy' ],
  )->pack(  @button_pack_options );

  my $main_help_box = $self->main_help_maker( $mainwindow );
  $mainwindow->bind('<F1>' => $main_help_box );

  $button_bundle_frame->Button(
    '-text'    => 'Help',
    '-command' => $main_help_box,
  )->pack( @button_pack_options );
  
  $self->consider_grid_row( $button_bundle_frame );
  
  $okay->focus if $whether_focus_okay;

  return;
}

# ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
sub main_help_maker {
  my($self, $mainwindow) = @_;
  return sub {
    my $dialogbox;
    require Tk::DialogBox;
    require Tk::Text;

    {
      $dialogbox = $mainwindow->DialogBox(
        '-title'   => "Help for $$self{'title'}",
        '-buttons' => [
          'OK',
          $self->{'license'} ? ('See License') : ()
        ],
      );
      my $t = $dialogbox->add('Scrolled' => 'Text' =>
        -scrollbars => 'oe',
        -height => 22,
        -width => 80,
        -font => 'roman',  # no real need for monospace
      );
      $t->pack;
      $t->insert('@0,0', $self->_text_for_program() );
      $t->configure(qw<  -state disabled  -takefocus 1  >);
        # make it non-editable, but selectable
    }


    return unless 'See License' eq ($dialogbox->Show || '');