File Coverage

blib/lib/Tk/Getopt.pm

Criterion	Covered	Total	%
statement	165	801	20.6
branch	71	436	16.2
condition	18	154	11.6
subroutine	16	73	21.9
pod	11	13	84.6
total	281	1477	19.0

# -*- perl -*-

#
# Author: Slaven Rezic
#
# Copyright (C) 1997,1998,1999,2000,2003,2007,2008,2012,2014,2017 Slaven Rezic. All rights reserved.
# This package is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# Mail: [e-mail]
# WWW:  http://www.rezic.de/eserte/
#

package Tk::Getopt;
require 5.005; # calling CODE refs
use strict;
use vars qw($loadoptions $VERSION $x11_pass_through
	    $CHECKMARK_OFF $CHECKMARK_ON
	    $FILE_IMAGE $CURR_GEOMETRY_IMAGE $DEBUG
	   );
use constant OPTNAME  => 0;
use constant OPTTYPE  => 1;
use constant DEFVAL   => 2;
use constant OPTEXTRA => 3;

use Carp qw();

$VERSION = '0.50_50';
$VERSION =~ s{_}{};

$DEBUG = 0;
$x11_pass_through = 0;

sub new {
    my($pkg, %a) = @_;
    my $self = {};

    $self->{'options'} = delete $a{'-options'} if exists $a{'-options'};

    if (exists $a{'-opttable'}) {
	$self->{'opttable'} = delete $a{'-opttable'};
	foreach (@{$self->{'opttable'}}) {
	    # Convert from new style without hash for extra options for
	    # internal operation.
	    # ['opt', '=s', 'defval', 'x' => 'y', 'z' => 'a', ...] into
	    # ['opt', '=s', 'defval', {'x' => 'y', 'z' => 'a', ...}]
	    if (ref $_ eq 'ARRAY' and
		defined $_->[OPTEXTRA] and
		ref $_->[OPTEXTRA] ne 'HASH') {
		if ((@$_ - OPTEXTRA) % 2 != 0) {
		    warn "Odd number of elements in definition for " . $_->[OPTNAME];
		}
		my %h = splice @$_, OPTEXTRA;
		$_->[OPTEXTRA] = \%h;
	    }
	    # Handle aliases
	    if (ref $_ eq 'ARRAY' && $_->[OPTNAME] =~ /\|/) {
		my($opt, @aliases) = split(/\|/, $_->[OPTNAME]);
		$_->[OPTNAME] = $opt;
		push(@{$_->[OPTEXTRA]{'aliases'}}, @aliases);
	    }
	}
    } elsif (exists $a{'-getopt'}) {
	# build opttable from -getopt argument
	my @optionlist;
	my $genprefix = "(--|-|\\+)";
	if (ref $a{'-getopt'} eq 'HASH') {
	    # convert hash to array
	    @optionlist
	      = map { ($_, $a{'-getopt'}->{$_}) } keys %{$a{'-getopt'}};
	} else {
	    @optionlist = @{$a{'-getopt'}};
	}
	delete $a{'-getopt'};
	# check if first argument is hash reference
	if (ref $optionlist[0] eq 'HASH') {
	    $self->{'options'} = shift @optionlist;
	}
	while (@optionlist > 0) {
	    my $opt = shift @optionlist;
	    # Strip leading prefix so people can specify "--foo=i"
	    # if they like.
	    $opt = $2 if $opt =~ /^($genprefix)+(.*)$/;

	    if ($opt !~ /^(\w+[-\w|]*)?(!|[=:][infse][@%]?)?$/) {
		warn "Error in option spec: \"", $opt, "\"\n";
		next;
	    }
	    my($o, $c) = ($1, $2);
	    $c = '' unless defined $c;
	    my @aliases;
	    if ($o =~ /\|/) {
		# Handle alias names
		@aliases = split(/\|/, $o);
		$o = shift @aliases;
	    }
	    my $varref;
	    # If no linkage is supplied in the @optionlist, copy it from
	    # the userlinkage ($self->{'options'}) if available.
	    if (defined $self->{'options'} && !ref $optionlist[0]) {
		$varref = (exists $self->{'options'}{$o} ?
			   $self->{'options'}{$o} :
			   \$self->{'options'}{$o});
	    } elsif (ref $optionlist[0]) {
		# link to global variable
		$varref = shift @optionlist;
	    }
	    my %a;
	    if (defined $varref) {
		if (ref $varref eq 'CODE') {
		    my $code = $varref;
		    $a{'callback'} = sub {
			if ($self->{'options'}{$o}) {
			    &$code;
			}
		    };
		    $varref = \$self->{'options'}{$o};
		}
		if (ref($varref) =~ /^(SCALAR|HASH|ARRAY)$/) {
		    $a{'var'} = $varref;
		} else {
		    die "Can't handle variable reference of type "
		      . ref $varref;
		}
	    }
	    if (@aliases) {
		$a{'alias'} = \@aliases;
	    }
	    push(@{$self->{'opttable'}}, [$o, $c, undef, \%a]);
	}
    } else {
	die "No opttable array ref or getopt hash ref";
    }

    $self->{'caller'}         = (caller)[0];
    $self->{'filename'}       = delete $a{'-filename'};
    $self->{'nosafe'}         = delete $a{'-nosafe'};
    $self->{'useerrordialog'} = delete $a{'-useerrordialog'};

    die "Unrecognized arguments: " . join(" ", %a) if %a;

    bless $self, $pkg;
}

# Return a list with all option names, that is, section labels and
# descriptions are ignored.
sub _opt_array {
    my $self = shift;
    my @res;
    foreach (@{$self->{'opttable'}}) {
	push @res, $_
	    if ref $_ eq 'ARRAY' and
	       $_->[OPTNAME] ne '';
    }
    @res;
}

# Return a reference to the option variable given by $opt
sub varref {
    my($self, $opt) = @_;
    if($opt->[OPTEXTRA]{'var'}) {
	$opt->[OPTEXTRA]{'var'};
    } elsif ($self->{'options'}) {
	\$self->{'options'}{$opt->[OPTNAME]};
    } else {
	# Link to global $opt_XXX variable.
	# Make sure a valid perl identifier results.
	my $v;
	($v = $opt->[OPTNAME]) =~ s/\W/_/g;
	eval q{\$} . $self->{'caller'} . q{::opt_} . $v; # XXX @, %
    }
}
# Formerly the varref method was private:
sub _varref { shift->varref(@_) }

sub optextra {
    my($self, $opt, $arg) = @_;
    $opt->[OPTEXTRA]{$arg};
}

sub _is_separator {
    my $opt = shift;
    defined $opt->[OPTNAME] && $opt->[OPTNAME] eq '' &&
    defined $opt->[DEFVAL]  && $opt->[DEFVAL] eq '-';
}

sub set_defaults {
    my $self = shift;
    my $opt;
    foreach $opt ($self->_opt_array) {
	if (defined $opt->[DEFVAL]) {
	    my $ref = ref $self->varref($opt);
	    if      ($ref eq 'ARRAY') {
		@ {$self->varref($opt)} = @{ $opt->[DEFVAL] };
	    } elsif ($ref eq 'HASH') {
		% {$self->varref($opt)} = %{ $opt->[DEFVAL] };
	    } elsif ($ref eq 'SCALAR') {
		$ {$self->varref($opt)} = $opt->[DEFVAL];
	    } else {
		die "Invalid reference type for option $opt->[OPTNAME] while setting the default value (maybe you should specify  as the default value)";
	    }
	}
    }
}

sub load_options {
    my($self, $filename) = @_;
    $filename = $self->{'filename'} if !$filename;
    return if !$filename;
    require File::Spec;
    if (!-e $filename) {
	warn "File $filename does not exist";
	return undef;
    }
    if (!File::Spec->file_name_is_absolute($filename)) {
	# required for do operation with PERL_USE_UNSAFE_INC=0
	$filename = File::Spec->rel2abs($filename);
    }
    if ($self->{'nosafe'}) {
	require Safe;
	my $c = new Safe;
	$c->share('$loadoptions');
	if (!$c->rdo($filename)) {
	    warn "Can't load $filename";
	    return undef;
	}
    } else {
	eval {do $filename};
	if ($@) {
	    warn $@;
	    return undef;
	}
    }

    my $opt;
    foreach $opt ($self->_opt_array) {
	if (exists $loadoptions->{$opt->[OPTNAME]}) {
	    if (ref $self->varref($opt) eq 'CODE') {
		$self->varref($opt)->($opt, $loadoptions->{$opt->[OPTNAME]}) if $loadoptions->{$opt->[OPTNAME]};
	    } elsif (ref $self->varref($opt) eq 'ARRAY' &&
		     ref $loadoptions->{$opt->[OPTNAME]} eq 'ARRAY') {
		@{ $self->varref($opt) } = @{ $loadoptions->{$opt->[OPTNAME]} };
	    } elsif (ref $self->varref($opt) eq 'HASH' &&
		     ref $loadoptions->{$opt->[OPTNAME]} eq 'HASH') {
		%{ $self->varref($opt) } = %{ $loadoptions->{$opt->[OPTNAME]} };
	    } else {
		$ {$self->varref($opt)} = $loadoptions->{$opt->[OPTNAME]};
	    }
	}
    }
    1;
}

sub save_options {
    my($self, $filename) = @_;
    $filename = $self->{'filename'} if !$filename;
    die "Saving disabled" if !$filename;
    eval "require Data::Dumper";
    if ($@) {
	warn $@;
	$self->my_die("No Data::Dumper available, cannot save options.\n");
    } else {
	if (open(OPT, ">$filename")) {
	    my %saveoptions;
	    my $opt;
	    foreach $opt ($self->_opt_array) {
		if (!$opt->[OPTEXTRA]{'nosave'}) {
		    my $ref;
		    if ($opt->[OPTEXTRA]{'savevar'}) {
			$ref = $opt->[OPTEXTRA]{'savevar'};
		    } else {
			$ref = $self->varref($opt);
		    }
		    if (ref($ref) eq 'SCALAR') {
			$saveoptions{$opt->[OPTNAME]} = $$ref;
		    } elsif (ref($ref) =~ /^(HASH|ARRAY)$/) {
			$saveoptions{$opt->[OPTNAME]} = $ref;
		    }
		}
	    }
	    local $Data::Dumper::Sortkeys = $Data::Dumper::Sortkeys = 1;
	    local $Data::Dumper::Indent = $Data::Dumper::Indent = 1;
	    if (Data::Dumper->can('Dumpxs')) {
		# use faster version of Dump
		print OPT
		  Data::Dumper->Dumpxs([\%saveoptions], ['loadoptions']);
	    } else {
		print OPT
		  Data::Dumper->Dump([\%saveoptions], ['loadoptions']);
	    }
	    close OPT;
	    warn "Options written to $filename" if $DEBUG;
	    1;
	} else {
	    $self->my_die("Writing to config file <$filename> failed: $!\n");
	    undef;
	}
    }
}

sub get_options {
    my $self = shift;
    my %getopt;
    my $opt;
    foreach $opt ($self->_opt_array) {
	$getopt{_getopt_long_string($opt->[OPTNAME], $opt->[OPTTYPE])} =
	  $self->varref($opt);
	# process aliases
	foreach (@{$opt->[OPTEXTRA]{'alias'}}) {
	    $getopt{_getopt_long_string($_, $opt->[OPTTYPE])} =
	      $self->varref($opt);
	}
    }
    require Getopt::Long;
    # XXX anders implementieren ... vielleicht die X11-Optionen zusätzlich
    # in die %getopt-Liste reinschreiben?
    if ($x11_pass_through) {
	Getopt::Long::config('pass_through');
    }
    my $res = Getopt::Long::GetOptions(%getopt);
    # Hack to pass standard X11 options (as defined in Tk::CmdLine)
    if ($x11_pass_through) {
	eval {
	    require Tk::CmdLine;
	    if ($Tk::CmdLine::VERSION >= 3.012) {
		# XXX nicht ausgetestet
		my @args = @ARGV;
		while (@args && $args[0] =~ /^-(\w+)$/) {
		    my $sw = $1;
		    return 0 if !$Tk::CmdLine::Method{$sw};
		    if ($Tk::CmdLine::Method{$sw} ne 'Flag_') {
			shift @args;
		    }
		    shift @args;
		}
	    } else {
		my $flag_ref = \&Tk::CmdLine::flag;
		my @args = @ARGV;
		while (@args && $args[0] =~ /^-(\w+)$/) {
		    my $sw = $1;
		    return 0 if !$Tk::CmdLine::switch{$sw};
		    if ($Tk::CmdLine::switch{$sw} ne $flag_ref) {
			shift @args;
		    }
		    shift @args;
		}
	    }
	    $res = 1;
	};
	warn $@ if $@;
    }
    $res;
}

# Builds a string for Getopt::Long. Arguments are option name and option
# type (e.g. '!' or '=s').
sub _getopt_long_string {
    my($option, $type) = @_;
    $option . (length($option) == 1 &&
	       (!defined $type || $type eq '' || $type eq '!')
	       ? '' : $type);
}

# Prints option name with one or two dashes
sub _getopt_long_dash {
    my $option = shift;
    (length($option) == 1 ? '' : '-') . "-$option";
}

sub usage {
    my $self = shift;
    my $usage = "Usage: $0 [options]\n";
    my $opt;
    foreach $opt ($self->_opt_array) {
	# The following prints all options as a comma-seperated list
	# with one or two dashes, depending on the length of the option.
	# Options are sorted by length.
 	$usage .= join(', ',
 		       sort { length $a <=> length $b }
 		       map { _getopt_long_dash($_) }
 		       map { ($opt->[OPTTYPE] eq '!' ? "[no]" : "") . $_ }
		       ($opt->[OPTNAME], @{$opt->[OPTEXTRA]{'alias'}}));
	$usage .= "\t";
	$usage .= $opt->[OPTEXTRA]{'help'}              if $opt->[OPTEXTRA]{'help'};
	$usage .= " (default: " . $opt->[DEFVAL] . ") " if $opt->[DEFVAL];
	$usage .= "\n";
    }
    $usage;
}

sub process_options {
    my($self, $former, $fromgui) = @_;
    my $bag = {};
    foreach my $optdef ($self->_opt_array) {
	my $opt = $optdef->[OPTNAME];

	my $callback;
	if ($fromgui) {
	    $callback = $optdef->[OPTEXTRA]{'callback-interactive'};
	}
	if (!$callback) {
	    $callback = $optdef->[OPTEXTRA]{'callback'};
	}
	if ($callback) {
	    # no warnings here ... it would be too complicated to catch
	    # all undefined values
	    my $old_w = $^W;
	    local($^W) = 0;
	    # execute callback if value has changed
	    if (!(defined $former
		  && (!exists $former->{$opt}
		      || $ {$self->varref($optdef)} eq $former->{$opt}))) {
		local($^W) = $old_w; # fall back to original value
		&$callback(optdef => $optdef, bag => $bag);
	    }
	}
	if ($optdef->[OPTEXTRA]{'strict'} &&
	    UNIVERSAL::isa($optdef->[OPTEXTRA]{'choices'},'ARRAY')) {
	    # check for valid values (valid are: choices and default value)
	    my $v = $ {$self->varref($optdef)};
	    my @choices = @{$optdef->[OPTEXTRA]{'choices'}};
	    push(@choices, $optdef->[DEFVAL]) if defined $optdef->[DEFVAL];
	    my $seen;
	    for my $choice (@choices) {
		my $value = (ref $choice eq 'ARRAY' ? $choice->[1] : $choice);
		if ($value eq $v) {
		    $seen = 1;
		    last;
		}
	    }
	    if (!$seen) {
		if (defined $former) {
		    warn "Not allowed: " . $ {$self->varref($optdef)}
		       . " for -$opt. Using old value $former->{$opt}";
		    $ {$self->varref($optdef)} = $former->{$opt};
		} else {
		    die "Not allowed: "
		      . $ {$self->varref($optdef)} . " for -$opt\n"
		      . "Allowed is only: " . join(", ", @choices);
		}
	    }
	}
    }
}

sub my_die {
    my($self, $msg, $is_safe) = @_;
    my $use_tk;
    if ($self->{'useerrordialog'} && defined &Tk::MainWindow::Existing) {
	for my $mw (Tk::MainWindow::Existing()) {
	    if (Tk::Exists($mw)) {
		$use_tk = $mw;
		last;
	    }
	}
	if ($use_tk && !defined $is_safe) {
	    for(my $i=0; $i<100; $i++) {
		my(undef,undef,undef,$subroutine) = caller($i);
		last if !defined $subroutine;
		if ($subroutine eq '(eval)') {
		    $use_tk = 0;
		    last;
		}
	    }
	}
    }
    if ($use_tk) {
	eval {
	    $use_tk->messageBox(-icon    => "error",
				-message => $msg,
				-title   => "Error",
			       );
	};
	if ($@) {
	    Carp::croak($msg);
	}
    } else {
	Carp::croak($msg);
    }
}

# try to work around weird browse entry
sub _fix_layout {
    my($self, $frame, $widget, %args) = @_;
    my($w, $real_w);
    if ($Tk::VERSION < 804) {
	my $f = $frame->Frame;
	$f->Label->pack(-side => "left"); # dummy
	$real_w = $f->$widget(%args)->pack(-side => "left", -padx => 1);
	$w = $f;
    } else {
	$w = $real_w = $frame->$widget(%args);
    }
    ($w, $real_w);
}

sub _boolean_widget {
    my($self, $frame, $opt) = @_;
    ($self->_fix_layout($frame, "Checkbutton",
			-variable => $self->varref($opt)))[0];
}

sub _boolean_checkmark_widget {
    # XXX hangs with Tk800.014?!
    my($self, $frame, $opt) = @_;
    _create_checkmarks($frame);
    ($self->_fix_layout($frame, "Checkbutton",
			-variable => $self->varref($opt),
			-image => $CHECKMARK_OFF,
			-selectimage => $CHECKMARK_ON,
			-indicatoron => 0,
		       ))[0];
}

sub _number_widget {
    my($self, $frame, $opt) = @_;
    ($self->_fix_layout($frame, "Scale",
			-orient => 'horizontal',
			-from => $opt->[OPTEXTRA]{'range'}[0],
			-to => $opt->[OPTEXTRA]{'range'}[1],
			-showvalue => 1,
			-resolution => ($opt->[OPTTYPE] =~ /f/ ? 0 : 1),
			-variable => $self->varref($opt)
		       ))[0];
}

sub _integer_widget {
    my($self, $frame, $opt) = @_;
    if (exists $opt->[OPTEXTRA]{'range'}) {
	$self->_number_widget($frame, $opt);
    } else {
	$self->_string_widget($frame, $opt, -restrict => "=i");
    }
}

sub _float_widget {
    my($self, $frame, $opt) = @_;
    if (exists $opt->[OPTEXTRA]{'range'}) {
	$self->_number_widget($frame, $opt);
    } else {
	$self->_string_widget($frame, $opt, -restrict => "=f");
    }
}

sub _list_widget {
    my($self, $frame, $opt) = @_;
    if ($opt->[OPTEXTRA]{'strict'} && grep { ref $_ eq 'ARRAY' } @{$opt->[OPTEXTRA]{'choices'}}) {
	$self->_optionmenu_widget($frame, $opt);
    } else {
	$self->_browseentry_widget($frame, $opt);
    }
}

sub _browseentry_widget {
    my($self, $frame, $opt) = @_;
    require Tk::BrowseEntry;
    my %args = (-variable => $self->varref($opt));
    if ($opt->[OPTEXTRA]{'strict'}) {
	$args{-state} = "readonly";
    }
    my $w = $frame->BrowseEntry(%args);
    my %mapping;
    my @optlist = @{$opt->[OPTEXTRA]{'choices'}};
    unshift @optlist, $opt->[DEFVAL] if defined $opt->[DEFVAL];
    my $o;
    my %seen;
    foreach $o (@optlist) {
	if (!$seen{$o}) {
	    $w->insert("end", $o);
	    $seen{$o}++;
	}
    }
    $w;
}

sub _optionmenu_widget {
    my($self, $frame, $opt) = @_;
    require Tk::Optionmenu;
    my $varref = $self->varref($opt);
    # Have to remember value, otherwise Optionmenu would overwrite it...
    my $value = $$varref;
    my %args = (-variable => $varref,
		-options => $opt->[OPTEXTRA]{'choices'},
	       );
    my $w = $frame->Optionmenu(%args);
    if (defined $value) {
	my $label = $value;
	for my $choice (@{ $opt->[OPTEXTRA]{'choices'} }) {
	    if (ref $choice eq 'ARRAY' && $choice->[1] eq $value) {
		$label = $choice->[0];
	    }
	}
	$w->setOption($label, $value);
    }
    $w;
}

sub _string_widget {
    my($self, $frame, $opt, %args) = @_;
    if (exists $opt->[OPTEXTRA]{'choices'}) {
	$self->_list_widget($frame, $opt);
    } else {
	my($e, $ee) = $self->_fix_layout
	    ($frame, "Entry",
	     (defined $opt->[OPTEXTRA]{'length'}
	      ? (-width => $opt->[OPTEXTRA]{'length'}) : ()),
	     -textvariable => $self->varref($opt));
	if ($args{-restrict} || defined $opt->[OPTEXTRA]{'maxsize'}) {
	    my $restrict_int   = sub { $_[0] =~ /^([+-]?\d+|)$/ };
	    my $restrict_float = sub {
		$_[0] =~ /^(|([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?)$/
	    };
	    my $restrict_len   = sub {
		length $_[0] <= $opt->[OPTEXTRA]{'maxsize'}
	    };
	    eval {
		$ee->configure
		    (-validate => "all",
		     -vcmd => sub {
			 ($args{-restrict} ne "=i" || $restrict_int->($_[0]))
			     &&
			 ($args{-restrict} ne "=f" || $restrict_float->($_[0]))
			     &&
			 (!defined $opt->[OPTEXTRA]{'maxsize'} || $restrict_len->($_[0]))
		     });
	    };
	    warn $@ if $@;
	}
	$e;
    }
}

sub _dir_select {
    my($top, $curr_dir) = @_;

    if ($top->can("chooseDirectory")) {
	return $top->chooseDirectory(-initialdir => $curr_dir);
    }

    if (eval { require Tk::DirSelect; Tk::DirSelect->VERSION("1.03"); 1 }) {
	return $top->DirSelect(-directory => $curr_dir)->Show;
    }

    require Tk::DirTree;
    my $t = $top->Toplevel;
    $t->title("Choose directory:");
    my $ok = 0; # flag: "1" means OK, "-1" means cancelled

    # Create Frame widget before the DirTree widget, so it's always visible
    # if the window gets resized.
    my $f = $t->Frame->pack(-fill => "x", -side => "bottom");

    my $d;
    $d = $t->Scrolled('DirTree',
		      -scrollbars => 'osoe',
		      -width => 35,
		      -height => 20,
		      -selectmode => 'browse',
		      -exportselection => 1,
		      -browsecmd => sub { $curr_dir = shift;
					  if ($^O ne 'MSWin32') {
					      $curr_dir =~ s|^//|/|; # bugfix
					  }
				        },

		      # With this version of -command a double-click will
		      # select the directory
		      -command   => sub { $ok = 1 },

		      # With this version of -command a double-click will
		      # open a directory. Selection is only possible with
		      # the Ok button.
		      #-command   => sub { $d->opencmd($_[0]) },
		     )->pack(-fill => "both", -expand => 1);
    # Set the initial directory
    $d->chdir($curr_dir);

    $f->Button(-text => 'Ok',
	       -command => sub { $ok =  1 })->pack(-side => 'left');
    $f->Button(-text => 'Cancel',
	       -command => sub { $ok = -1 })->pack(-side => 'left');
    $t->OnDestroy(sub { $ok = -1 });
    $f->waitVariable(\$ok);
    $t->destroy if Tk::Exists($t);
    if ($ok == 1) {
	$curr_dir;
    } else {
	undef;
    }
}

sub _filedialog_widget {
    my($self, $frame, $opt, %args) = @_;
    my $subtype = (exists $args{'-subtype'} ? $args{'-subtype'} : 'file');
    my $topframe = $frame->Frame;
    my $e;
    if (exists $opt->[OPTEXTRA]{'choices'}) {
	require Tk::BrowseEntry;
	$e = $topframe->BrowseEntry(-variable => $self->varref($opt));
	my @optlist = @{$opt->[OPTEXTRA]{'choices'}};
	unshift(@optlist, $opt->[DEFVAL]) if defined $opt->[DEFVAL];
	my $o;
	foreach $o (@optlist) {
	    $e->insert("end", $o);
	}
    } else {
	if (!eval '
               use Tk::PathEntry;
               my $real_e;
               ($e, $real_e) = $self->_fix_layout($topframe, "PathEntry",
                                                  -textvariable => $self->varref($opt));
               # XXX Escape is already used for cancelling Tk::Getopt
               $real_e->bind("<$_>" => sub { $real_e->Finish }) for (qw/Return/);
               1;
           ') {
	    ($e) = $self->_fix_layout($topframe, "Entry",
				      -textvariable => $self->varref($opt));
	}
    }
    $e->pack(-side => 'left');

    my $b = $topframe->Button
      (_get_browse_args($topframe),
       -command => sub {
	   require File::Basename;
	   my($fd, $filedialog);
	   if ($Tk::VERSION >= 800) {
	       if ($subtype eq 'dir') {
		   $fd = '_dir_select';
	       } elsif ($subtype eq 'savefile') {
		   $fd = 'getSaveFile';
	       } elsif ($subtype eq 'file') {
		   $fd = 'getOpenFile';
	       } else {
		   die "Unknown subtype <$subtype>";
	       }
	   } else {
	       $fd = 'FileDialog';
	       eval {
		   die "nope" if $subtype eq 'dir';
		   require Tk::FileDialog;
	       };
	       if ($@) {
		   require Tk::FileSelect;
		   $fd = 'FileSelect';
	       }
	       # XXX set FileDialog options via $opt->[3]{'filedialog_opt'}
	       if ($fd eq 'FileDialog') {
		   $filedialog = $topframe->FileDialog
		     (-Title => 'Select file');
	       } else {
		   $filedialog = $topframe->FileSelect;
	       }
	   }
	   my($dir, $base, $file);
	   my $act_val = $ {$self->varref($opt)};
	   if ($act_val) {
	       $dir  = File::Basename::dirname($act_val);
	       $base = File::Basename::basename($act_val);
	       $dir = '.' if (!-d $dir);

	       if ($fd =~ /^get(Open|Save)File$/) {
		   $file = $topframe->$fd(-initialdir => $dir,
					  -initialfile => $base,
					  -title => 'Select file',
# XXX erst ab 800.013 (?)
#						  -force => 1,
					 );
	       } elsif ($fd eq '_dir_select') {
		   $file = _dir_select($topframe, $dir);
	       } elsif ($fd eq 'FileDialog') {
		   $file = $filedialog->Show(-Path => $dir,
					     -File => $base);
	       } else {
		   if ($subtype eq 'dir') {
		       $file = $filedialog->Show(-directory => $dir,
						 -verify => [qw(-d)],
						);
		   } else {
		       $file = $filedialog->Show(-directory => $dir);
		   }
	       }
	   } else {
	       if ($fd =~ /^get(Open|Save)File$/) {
		   $file = $topframe->$fd(-title => 'Select file');
	       } elsif ($fd eq '_dir_select') {
		   require Cwd;
		   $file = _dir_select($topframe, Cwd::getcwd());
	       } else {
		   if ($subtype eq 'dir') {
		       $file = $filedialog->Show(-verify => [qw(-d)]);
		   } else {
		       $file = $filedialog->Show;
		   }
	       }
	   }
	   if (defined $file && $file ne "") {
	       $ {$self->varref($opt)} = $file;
	   }
       });
    $b->pack(-side => 'left');
    $topframe;
}

sub _geometry_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));
    $topframe->Button(_get_curr_geometry_args($topframe),
		      -command => sub {
			  my $mw = $frame->MainWindow;
			  $e->delete(0, "end");
			  $e->insert("end", $mw->geometry);
		      },
		     )->pack(-side => "left");
    $topframe;
}

sub _color_widget {
    return shift->_string_widget(@_);

    # XXX funktioniert leider nicht...
    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 ($frame->can("chooseColor")) {
	$topframe->Button(-text => "...",
			  -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;
	}
	if (exists $opt->[OPTEXTRA]{'longhelp'}) {
	    $f->Button(-text => '?',
		       -padx => 1,
		       -pady => 1,
		       -command => sub {
			   my $t = $f->Toplevel
			       (-title => $self->{_string}{"helpfor"}
				. " $label");
			   $t->Message(-text => $opt->[OPTEXTRA]{'longhelp'},
				     -justify => 'left')->pack;
			   $t->Button(-text => 'OK',
				      -command => sub { $t->destroy }
				     )->pack;
			   $t->Popup(-popover => "cursor");
		       })->grid(-row => $row, -column => 2, -sticky => 'w');
	}
    }
    $current_page->grid('columnconfigure', 3, -weight => 1);
    $current_page->grid('rowconfigure', ++$row, -weight => 1);
}

sub _do_undo {
    my($self, $undo_options) = @_;
    my $opt;
    foreach $opt ($self->_opt_array) {
	next if $opt->[OPTEXTRA]{'nogui'};
	if (exists $undo_options->{$opt->[OPTNAME]}) {
	    my $ref = ref $self->varref($opt);
	    if      ($ref eq 'ARRAY') {
		my @swap = @ {$self->varref($opt)};
		@ {$self->varref($opt)} = @{ $undo_options->{$opt->[OPTNAME]} };
		@{ $undo_options->{$opt->[OPTNAME]}} = @swap;
	    } elsif ($ref eq 'HASH') {
		my %swap = % {$self->varref($opt)};
		% {$self->varref($opt)} = %{ $undo_options->{$opt->[OPTNAME]} };
		%{ $undo_options->{$opt->[OPTNAME]}} = %swap;
	    } elsif ($ref eq 'SCALAR') {
		my $swap = $ {$self->varref($opt)};
		$ {$self->varref($opt)} = $undo_options->{$opt->[OPTNAME]};
		$undo_options->{$opt->[OPTNAME]} = $swap;
	    } else {
		die "Invalid reference type for option $opt->[OPTNAME]";
	    }
	}
    }
}

sub option_dialog {
    my($self, $top, %a) = @_;
    my $button_pressed;
    $a{'-buttonpressed'} = \$button_pressed;
    $a{'-wait'} = 1;
    $self->option_editor($top, %a);
    $button_pressed;
}

sub option_editor {
    my($self, $top, %a) = @_;
    my $callback  = delete $a{'-callback'};
    my $nosave    = delete $a{'-nosave'};
    my $buttons   = delete $a{'-buttons'};
    my $toplevel  = delete $a{'-toplevel'} || 'Toplevel';
    my $pack      = delete $a{'-pack'};
    my $transient = delete $a{'-transient'};
    my $use_statusbar = delete $a{'-statusbar'};
    my $wait      = delete $a{'-wait'};
    my $string    = delete $a{'-string'} || {};
    my $delay_page_create = (exists $a{'-delaypagecreate'}
			     ? delete $a{'-delaypagecreate'}
			     : 1);
    my $page      = delete $a{'-page'};
    my $button_pressed;
    if (exists $a{'-buttonpressed'}) {
	if (ref $a{'-buttonpressed'} ne "SCALAR") {
	    die "The value for the -buttonpressed option has to be a SCALAR reference, not a " . ref($a{'-buttonpressed'}) . "\n";
	}
	$button_pressed = delete $a{'-buttonpressed'};
    } else {
	# dummy
	$button_pressed = \do { my $dummy };
    }
    {
	my %defaults = ('optedit'    => 'Option editor',
			'undo'       => 'Undo',
			'lastsaved'  => 'Last saved',
			'save'       => 'Save',
			'defaults'   => 'Defaults',
			'ok'         => 'OK',
			'apply'      => 'Apply',
			'cancel'     => 'Cancel',
			'helpfor'    => 'Help for:',
			'oksave'     => 'OK',
		       );
	for my $key (keys %defaults) {
	    next if exists $string->{$key};
	    $string->{$key} = $defaults{$key};
	}
    }
    $self->{_string} = $string;

    if (defined $page) {
	$self->{'raised'} = $page;
    }

    # store old values for undo
    my %undo_options;
    my $opt;
    foreach $opt ($self->_opt_array) {
	next if $opt->[OPTEXTRA]{'nogui'};
	my $ref = ref $self->varref($opt);
	if      ($ref eq 'ARRAY') {
	    @{ $undo_options{$opt->[OPTNAME]} } = @ {$self->varref($opt)};
	} elsif ($ref eq 'HASH') {
	    %{ $undo_options{$opt->[OPTNAME]} } = % {$self->varref($opt)};
	} elsif ($ref eq 'SCALAR') {
	    $undo_options{$opt->[OPTNAME]}      = $ {$self->varref($opt)};
	} else {
	    die "Invalid reference type for option $opt->[OPTNAME]";
	}
    }

    require Tk;

    my $dont_use_notebook = 1;
    foreach $opt (@{$self->{'opttable'}}) {
	if (ref $opt ne 'ARRAY') { # found header
	    undef $dont_use_notebook;
	    last;
	}
    }
    if (!$dont_use_notebook) {
	eval { require Tk::NoteBook };
	$dont_use_notebook = 1 if $@;
    }

    my $dont_use_balloon;
    eval { require Tk::Balloon };
    $dont_use_balloon = 1 if $@;

    my $cmd = '$top->' . $toplevel . '(%a)';
    my $opt_editor = eval $cmd;
    die "$@ while evaling $cmd" if $@;
    $opt_editor->transient($transient) if $transient;
    eval { $opt_editor->configure(-title => $string->{optedit}) };

    my $opt_notebook = ($dont_use_notebook ?
			$opt_editor->Frame :
			$opt_editor->NoteBook(-ipadx => 6, -ipady => 6));
    $self->{Frame} = $opt_notebook;

    my($statusbar, $balloon);
    if (!$dont_use_balloon) {
	if ($use_statusbar) {
	    $statusbar = $opt_editor->Label;
	}
	$balloon = $opt_notebook->Balloon($use_statusbar
					  ? (-statusbar => $statusbar)
					  : ());
    }

    my $optlist = {};
    my $msglist = {};
    my $current_top;
    if ($dont_use_notebook) {
	$current_top = $string->{'optedit'};
	foreach $opt ($self->_opt_array) {
	    push(@{$optlist->{$current_top}}, $opt)
	      if !$opt->[OPTEXTRA]{'nogui'};
	}
	# XXX message missing
	$self->_create_page($opt_notebook, undef, $current_top,
			    $optlist, $balloon);
    } else {
	my @opttable = @{$self->{'opttable'}};
	unshift(@opttable, $string->{'optedit'})
	    if ref $opttable[OPTNAME] eq 'ARRAY'; # put head

	my $page_create_page;
	foreach $opt (@opttable) {
	    if (ref $opt ne 'ARRAY') {
		if (!$delay_page_create && $page_create_page) {
		    $page_create_page->();
		    undef $page_create_page;
		}

		my $label = $opt;
		$current_top = lc($label);
		my $c = $current_top;
		$optlist->{$c} = [];
		$msglist->{$c} = "";
		my $page_f;
		$page_create_page = sub {
		    $self->_create_page
			($page_f,
			 $opt_notebook, $c,
			 $optlist, $balloon, $msglist);
		};
		$page_f = $opt_notebook->add
		    ($c,
		     -label => $label,
		     -anchor => 'w',
		     ($delay_page_create?(-createcmd => $page_create_page):()),
		    );
            } elsif ($opt->[OPTNAME] eq '' && !_is_separator($opt)) {
		$msglist->{$current_top} = $opt->[DEFVAL];
	    } else {
		push @{$optlist->{$current_top}}, $opt
		    if !$opt->[OPTEXTRA]{'nogui'};
	    }
	}
	if (!$delay_page_create && $page_create_page) {
	    $page_create_page->();
	    undef $page_create_page;
	}

    }

    require Tk::Tiler;
    my $f;
    $f = $opt_editor->Tiler
      (-rows => 1,
       -columns => 1,
       -yscrollcommand => sub {
	   my $bw = $f->cget(-highlightthickness);
	   return if (!$f->{Sw});
	   my $nenner = int(($f->Width-2*$bw)/$f->{Sw});
	   return if (!$nenner);
	   my $rows = @{$f->{Slaves}}/$nenner;
	   return if (!$rows or !int($rows));
	   if ($rows/int($rows) > 0) {
	       $rows = int($rows)+1;
	   }
	   $f->GeometryRequest($f->Width,
			       2*$bw+$rows*$f->{Sh});
       });
    $f->bind('' => sub {
		 if ($f->y + $f->height > $opt_editor->height) {
		     $opt_editor->geometry($opt_editor->width .
					   "x" .
					   ($f->height+$f->y));
		 }
	     });
    my @tiler_b;

    my %allowed_button;
    if ($buttons) {
	if (ref $buttons ne 'ARRAY') {
	    undef $buttons;
	} else {
	    %allowed_button = map { ($_ => 1) } @$buttons;
        }
    }

    if (!$buttons || $allowed_button{'ok'}) {
	my $ok_button
	    = $f->Button(-text => $string->{'ok'},
			 -underline => 0,
			 -command => sub {
			     $self->process_options(\%undo_options, 1);
                             if (!$dont_use_notebook) {
                                 $self->{'raised'} = $opt_notebook->raised();
                             }
                             $opt_editor->destroy;
			     $$button_pressed = 'ok';
                         }
                        );
        push @tiler_b, $ok_button;
    }

    if ($allowed_button{'oksave'}) {
	my $ok_button
	    = $f->Button(-text => $string->{'oksave'},
			 -underline => 0,
			 -command => sub {
			     $top->Busy;
			     eval {
				 $self->save_options;
				 $self->process_options(\%undo_options, 1);
				 if (!$dont_use_notebook) {
				     $self->{'raised'} = $opt_notebook->raised();
				 }
			     };
			     my $err = $@;
			     $top->Unbusy;
			     if ($err) {
				 $self->my_die($err, 'safe');
			     }
                             $opt_editor->destroy;
			     $$button_pressed = 'ok';
                         }
                        );
        push @tiler_b, $ok_button;
    }

    if (!$buttons || $allowed_button{'apply'}) {
	my $apply_button
	    = $f->Button(-text => $string->{'apply'},
			 -command => sub {
			     $self->process_options(\%undo_options, 1);
			 }
			);
	push @tiler_b, $apply_button;
    }

    my $cancel_button;
    if (!$buttons || $allowed_button{'cancel'}) {
	$cancel_button
	    = $f->Button(-text => $string->{'cancel'},
			 -command => sub {
			     $self->_do_undo(\%undo_options);
			     if (!$dont_use_notebook) {
				 $self->{'raised'} = $opt_notebook->raised();
			     }
			     $opt_editor->destroy;
			     $$button_pressed = 'cancel';
			 }
			);
	push @tiler_b, $cancel_button;
    }

    if (!$buttons || $allowed_button{'undo'}) {
	my $undo_button
	    = $f->Button(-text => $string->{'undo'},
			 -command => sub {
			     $self->_do_undo(\%undo_options);
			 }
			);
	push @tiler_b, $undo_button;
    }

    if ($self->{'filename'}) {
	if (!$buttons || $allowed_button{'lastsaved'}) {
	    my $lastsaved_button
		= $f->Button(-text => $string->{'lastsaved'},
			     -command => sub {
				 $top->Busy;
				 $self->load_options;
				 $top->Unbusy;
			     }
			    );
	    push @tiler_b, $lastsaved_button;
	}

	if (!$nosave && (!$buttons || $allowed_button{'save'})) {
	    my $save_button;
	    $save_button
		= $f->Button(-text => $string->{'save'},
			     -command => sub {
				 $top->Busy;
				 eval { $self->save_options };
				 if ($@ =~ /No Data::Dumper/) {
				     $save_button->configure(-state => 'disabled');
				 }
				 $top->Unbusy;
			     }
			    );
	    push @tiler_b, $save_button;
	}
    }

    if (!$buttons || $allowed_button{'defaults'}) {
	my $def_button
	    = $f->Button(-text => $string->{'defaults'},
			 -command => sub {
			     $self->set_defaults;
			 }
			);
	push @tiler_b, $def_button;
    }

    $f->Manage(@tiler_b);

    &$callback($self, $opt_editor) if $callback;

    if (!$dont_use_notebook && defined $self->{'raised'}) {
	$self->raise_page($self->{'raised'});
    }

    $opt_editor->bind('' => sub { $cancel_button->invoke });

    $f->pack(-fill => 'x', -side => "bottom");
    $opt_notebook->pack(-expand => 1, -fill => 'both');
    if (defined $statusbar) {
	$statusbar->pack(-fill => 'x', -anchor => 'w');
    }

    if ($opt_editor->can('Popup')) {
	$opt_editor->withdraw;
	$opt_editor->Popup;
    }
    if ($wait) {
	if ($pack) {
	    $opt_editor->pack(@$pack);
	}
	my $wait_var = 1;
	$opt_editor->OnDestroy(sub { undef $wait_var });
	$opt_editor->waitVisibility unless $opt_editor->ismapped;
	$opt_editor->grab;
	$opt_editor->waitVariable(\$wait_var);
    }

    $opt_editor;
}

sub _create_checkmarks {
    my $w = shift;

    $CHECKMARK_ON  = $w->Photo(-data => <
R0lGODdhDgAOAIAAAP///1FR+ywAAAAADgAOAAACM4SPFplGIXy0yDQK4aNFZAIlhI8QEQkUACKC
4EMERFAI3yg+wb+ICEQjMeGjRWQahfCxAAA7
EOF
      unless $CHECKMARK_ON;
    $CHECKMARK_OFF = $w->Photo(-data => <
R0lGODdhDgAOAIAAAAAAAP///ywAAAAADgAOAAACDYyPqcvtD6OctNqrSAEAOw==
EOF
      unless $CHECKMARK_OFF;
}

sub _get_browse_args {
    my $w = shift;
    if (!defined $FILE_IMAGE) {
	require Tk::Pixmap;
	$FILE_IMAGE = $w->Pixmap(-file => Tk->findINC("openfolder.xpm"));
	$FILE_IMAGE = 0 if (!$FILE_IMAGE);
    }
    if ($FILE_IMAGE) {
	(-image => $FILE_IMAGE);
    } else {
	(-text => "Browse...");
    }
}

sub _get_curr_geometry_args {
    my $w = shift;
    if (!defined $CURR_GEOMETRY_IMAGE) {
	require Tk::Photo;
	$CURR_GEOMETRY_IMAGE = $w->Photo(-file => Tk->findINC("win.xbm"));
	$CURR_GEOMETRY_IMAGE = 0 if (!$CURR_GEOMETRY_IMAGE);
    }
    if ($CURR_GEOMETRY_IMAGE) {
	(-image => $CURR_GEOMETRY_IMAGE);
    } else {
	(-text => "Geom.");
    }
}

sub raise_page {
    my($self, $page) = @_;
    my $opt_notebook = $self->{Frame};
    $page = lc $page; # always lowercase in NoteBook internals
    $opt_notebook->raise($page);
}

1;

__END__