view release on metacpan or  search on metacpan

Getopt.pm  view on Meta::CPAN

			  -padx => 0, -pady => 0,
			  -command => sub {
			      my $color = $frame->chooseColor;
#				  (-initialcolor => $e->get);
			      return unless defined $color;
			      $e->delete(0, "end");
			      $e->insert("end", $color);
			  },
			 )->pack(-side => "left");
    }
    $topframe;
}

sub _font_widget {
    my($self, $frame, $opt) = @_;
    my($topframe, $e) = $self->_fix_layout
	($frame,
	 'Entry',
	 (defined $opt->[OPTEXTRA]{'length'}
	  ? (-width => $opt->[OPTEXTRA]{'length'}) : ()),
	 -textvariable => $self->varref($opt));
    if (eval {require Tk::Font; require Tk::FontDialog; 1}) {
	$topframe->Button(-text => "...",
			  -padx => 0, -pady => 0,
			  -command => sub {
			      my $font = $frame->FontDialog
				  (-initfont => $e->get)->Show;
			      return unless defined $font;
			      $e->delete(0, "end");
			      $e->insert("end", $font->Pattern);
			  },
			 )->pack(-side => "left");
    }
    $topframe;
}

# Creates one page of the Notebook widget
# Arguments:
#   $current_page: Frame for drawing
#   $optnote: Notebook widget
#   $current_top: title of Notebook page
#   $optlist: list of options for this Notebook page
#   $balloon: Balloon widget
#   $msglist: (optional) list of messages for this Notebook page
sub _create_page {
    my($self, $current_page,
       $optnote, $current_top, $optlist,
       $balloon, $msglist) = @_;
    $current_page = $optnote->{$current_top} if !defined $current_page;
    my $opt;
    my $row = -1;

    my $msgobj;
    if (ref $msglist and
	exists $msglist->{$current_top} and
	$msglist->{$current_top} ne "") {
	$row++;
	$msgobj = $current_page->Label(-text => $msglist->{$current_top},
				       -justify => "left",
				       )->grid(-row => $row, -column => 0,
					       -columnspan => 3);
    }

    foreach $opt (@{$optlist->{$current_top}}) {
	my $f = $current_page;
	$row++;
	if (_is_separator($opt)) {
	    my $separator = $f->Frame(-height => 2,
				     )->grid(-row => $row,
					     -column => 0,
					     -columnspan => 3,
					     -pady => 3,
					     -padx => 3,
					     -sticky => "ew");
	    $separator->configure
		(-fg => $separator->cget(-bg),
		 -bg => $separator->Darken($separator->cget(-bg), 60));
	    next;
	}

	my $label;
	my $w;
	if (exists $opt->[OPTEXTRA]{'label'}) {
	    $label = $opt->[OPTEXTRA]{'label'};
	} else {
	    $label = $opt->[OPTNAME];
	    if ($label =~ /^(.*)-(.*)$/ && $1 eq $current_top) {
		$label = $2;
	    }
	}
	my $lw = $f->Label(-text => $label)->grid(-row => $row, -column => 0,
						  -sticky => 'w');
	if (exists $opt->[OPTEXTRA]{'widget'}) {
	    # own widget
	    $w = &{$opt->[OPTEXTRA]{'widget'}}($self, $f, $opt);
	} elsif (defined $opt->[OPTTYPE] &&
		 $opt->[OPTTYPE] eq '!' or $opt->[OPTTYPE] eq '') {
	    $w = $self->_boolean_widget($f, $opt); # XXX _checkmark_
	} elsif (defined $opt->[OPTTYPE] && $opt->[OPTTYPE] =~ /i/) {
	    $w = $self->_integer_widget($f, $opt);
	} elsif (defined $opt->[OPTTYPE] && $opt->[OPTTYPE] =~ /f/) {
	    $w = $self->_float_widget($f, $opt);
	} elsif (defined $opt->[OPTTYPE] && $opt->[OPTTYPE] =~ /s/) {
	    my $subtype = (defined $opt->[OPTEXTRA] &&
			   exists $opt->[OPTEXTRA]{'subtype'} ?
			   $opt->[OPTEXTRA]{'subtype'} : "");
	    if ($subtype eq 'file' ||
		$subtype eq 'savefile' ||
		$subtype eq 'dir') {
		$w = $self->_filedialog_widget($f, $opt, -subtype => $subtype);
	    } elsif ($subtype eq 'geometry') {
		$w = $self->_geometry_widget($f, $opt);
	    } elsif ($subtype eq 'color') {
		$w = $self->_color_widget($f, $opt);
	    } elsif ($subtype eq 'font') {
		$w = $self->_font_widget($f, $opt);
	    } else {
		$w = $self->_string_widget($f, $opt);
	    }
	} else {
	    warn "Can't generate option editor entry for $opt->[OPTNAME]";
	}
	if (defined $w) {
	    $w->grid(-row => $row, -column => 1, -sticky => 'w');
	}
	if (exists $opt->[OPTEXTRA]{'help'} && defined $balloon) {
	    $balloon->attach($w, -msg => $opt->[OPTEXTRA]{'help'})
		if defined $w;
	    $balloon->attach($lw, -msg => $opt->[OPTEXTRA]{'help'})
		if defined $lw;
	}