package Tk::MhConfig;

use 5.008008;
use strict;
use warnings;

require Exporter;

our @ISA = qw(Exporter);

use Storable qw(nstore retrieve dclone);
use File::Basename;
use Tk;
use Tk::Balloon;
use Tk::Pane;
use Tk::Font;
use Tk::NoteBook;
use Tk::MhColorChooser qw(color_chooser);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

our @EXPORT_OK = qw(configuration_edit configuration_store configuration_restore);

our $VERSION = '0.01';

##############################################################
# load the configuration from the given file
##############################################################
sub configuration_restore {
  my $file = shift; # config file with path
  my $configref = shift; # hash reference
  # try to get the saved config hash
  if (-f $file) {
    my $hashref = retrieve($file);
    unless (defined $hashref) {
      return (0, "could not retrieve configuration from $file");
    }
    # the config is a hash of hash (2 levels)
    # we copy each element for its own, so we do not loose any new options and still use all existing user settings
    foreach my $key1 (keys %{$hashref}) {
      if (not defined $configref->{$key1}) {
        warn "MhConfig: Ignoring unknown key \"$key1\" (file:$file)\n";
        next;
      }
      foreach my $key2 (keys %{$hashref->{$key1}}) {
        if (not defined $configref->{$key1}->{$key2}) {
          warn "MhConfig: Unknown key \"$key1->$key2\" (value: $hashref->{$key1}->{$key2}) (file:$file)\n";
          next;
        }
        $configref->{$key1}->{$key2} = $hashref->{$key1}->{$key2};
      }
    }
  }
  return (1, '');
}

##############################################################
# store the configuration in the given file
##############################################################
sub configuration_store {
  my $file = shift;
  my $configref = shift; # hash reference
  if (nstore($configref,  $file)) {
    return (1, '');
  }
  else {
    return (0, "Could not store configuration in file $file: $!\n");
  }
}

##############################################################
# open a dialog to edit the configuration options
##############################################################
sub configuration_edit {
  my $w = shift; # main window widget 
  my $config = shift; # reference to config hash
  my $tab_order = shift; # reference to array containing the tabs in the prefered order
  my $apply_callback = shift; # code reference, callback function to be called when user presses the apply button
  my $reset_callback = shift; # code reference, callback function to be called when user presses the reset button
  my $additional_colors = shift; # list reference (additional color s for color_chooser() 
  my $inactivebackground = shift; # optional color fot the inactive notebook tabs
  my $icon = shift; # optional window icon (Tk::Photo reference)
  
  # the configuration toplevel is named $w->{'config_win'}
  if (Exists($w->{'config_win'})) {
    $w->{'config_win'}->deiconify;
    $w->{'config_win'}->raise;
    $w->{'config_win'}->focus;
    return;
  }

  # open window
  my $conf_win = $w->Toplevel();
  my $title = '';
  $title = $w->{tool_name} if (defined $w->{tool_name});
  $title .= ' Options';
  $conf_win->title($title);
  # calc and set window size
  my $winw = 700; # optimal size, but this depends on OS and font size
  my $winh = 600;
  my $screenw = $conf_win->screenwidth;
  my $screenh = $conf_win->screenheight;
  # limit window to to screensize
  $winw = $screenw if ($screenw < $winw); 
  $winh = $screenh if ($screenh < $winh);
  # center window on screen
  my $xoffset = ($screenw - $winw)/2;  
  my $yoffset = ($screenh - $winh)/2;  
  $conf_win->geometry("${winw}x${winh}+${xoffset}+${yoffset}");
  
  # number of ASCII chars per line (is used to calculate the length of text entries)
  my $total_length = 70;

  # we need a fixed font for a nice layout in the balloon tooltips
  my $font = $conf_win->Font(-family => 'Courier', -size => 8);
  my $balloon = $conf_win->Balloon(-initwait => 1000, -font => $font);
  $balloon->Subwidget('message')->configure(-justify => 'left');
  $conf_win->iconimage($icon) if ($icon and (ref($icon) eq "Tk::Photo"));
  # store config window widget in main window widget
  $w->{'config_win'} = $conf_win;
  
  # get background color from window widget  
  my $background_color = $conf_win->cget(-bg);
  # create notebook
  my $notebook = $conf_win->NoteBook(-background => $background_color, -backpagecolor => $background_color)->pack(-expand => 1, -fill => 'both', -padx => 3, -pady => 3);
  $notebook->configure(-inactivebackground => $inactivebackground) if (defined $inactivebackground);

  # generate notebook tabs in predefined order
  if (@{$tab_order}) {
    foreach my $tab (@{$tab_order}) {
      $conf_win->{$tab} = $notebook->add($tab, -label => $tab);
      # we use a pane to support small screen resolutions, the user is still able to scroll e.g. to the buttons at the bottom of the window
      $conf_win->{$tab}->{pane} = $conf_win->{$tab}->Scrolled('Pane',
            -scrollbars => 'osoe',
            #-width => $pane_w, -height => $pane_h
            )->pack(-expand => 1, -fill => 'both');
    }
  }

  foreach my $item (sort {
    my $ord_a = 100;
    my $ord_b = 100;
    $ord_a = $$config{$a}{ord} if defined $$config{$a}{ord};
    $ord_b = $$config{$b}{ord} if defined $$config{$b}{ord};
    $ord_a <=> $ord_b || uc($a) cmp uc($b)
  } keys %{$config}) {
    # default tab is called Extra (all options without a tab value will be placed there!)
    my $tab = 'Extra';
    $tab = $$config{$item}{tab} if defined $$config{$item}{tab};
    # the config item will not be shown if the item tab is set to "no"
    next if ($tab eq 'no');
    # if the tab still does not exists we create it
    if (not defined $conf_win->{$tab}) {
      $conf_win->{$tab} = $notebook->add($tab, -label => $tab);
    }

    # the option widget will be placed in widget $w which is either the tab itself or a frame inside the tab
    my $w = $conf_win->{$tab}->{pane};

    # options may be grouped into frames
    my $frame;
    $frame = $$config{$item}{frame} if defined $$config{$item}{frame};
    # if the tab does not exists we create it
    if (defined $frame) {
      if (not defined $conf_win->{$tab}->{pane}->{$frame}) {
        $conf_win->{$tab}->{pane}->{$frame} =
          $conf_win->{$tab}->{pane}->Frame(-bd => 1, -relief => 'groove')->pack(-side => 'top', -expand => 1, -fill => 'x', -padx => 4, -pady => 4);
        $conf_win->{$tab}->{pane}->{$frame}->Label(-text => $frame, -width => $total_length)->pack();
      }
      $w = $conf_win->{$tab}->{pane}->{$frame}; # widget w is now the frame
    }
    
    my $item_name = $item;
    $item_name = $$config{$item}{long} if defined $$config{$item}{long};
    my $but;
    if (not defined $$config{$item}{kind}) {
      next; # to display a config option we need to know its nature
    }
    ### BOOL ###
    elsif ($$config{$item}{kind} eq 'bool') {
      $but = $w->Checkbutton(-variable => \$$config{$item}{value}, -text => $item_name, -anchor => 'w')->pack(-side => 'top', -expand => 1, -fill => 'x', -padx => 4, -pady => 4);
    }
    ### NUMBER (INTEGER) ###
    elsif ($$config{$item}{kind} eq 'int') {
      if (defined $$config{$item}{value} and defined $$config{$item}{from} and defined $$config{$item}{to}) {
        $but = $w->Scale(
          -variable => \$$config{$item}{value},
          -label => $item_name,
          -from => $$config{$item}{from},
          -to => $$config{$item}{to},
          -resolution => 1,
          -orient => 'horizontal',
          -showvalue => 1,
          -width => 15,
        )->pack(-side => 'top', -expand => 1, -fill => 'x', -padx => 4, -pady => 4);
      }
      else {
        warn "Configuration option $item \"$item_name\": needs a \"value\" a \"from\" and a \"to\" value";
      }
    }
    ### NUMBER (FLOAT) ###
    elsif ($$config{$item}{kind} eq 'float') {
      if (defined $$config{$item}{value} and defined $$config{$item}{from} and defined $$config{$item}{to} and defined $$config{$item}{res}) {
        $but = $w->Scale(
          -variable => \$$config{$item}{value},
          -label => $item_name,
          -from => $$config{$item}{from},
          -to => $$config{$item}{to},
          -resolution => $$config{$item}{res},
          -orient => 'horizontal',
          -showvalue => 1,
          -width => 15,
        )->pack(-side => 'top', -expand => 1, -fill => 'x', -padx => 4, -pady => 4);
      }
      else {
        warn "Configuration option $item \"$item_name\": needs a \"value\" a \"from\" a \"to\" and a \"res\" value";
      }
    }
    ### COLOR ###
    elsif ($$config{$item}{kind} eq 'color') {
      my $frame = $w->Frame(-bd => 1)->pack(-side => 'top', -expand => 1, -fill => 'x', -padx => 4, -pady => 4);
      $but = $frame->Button(-text => '..',
      -bg => $$config{$item}{value},
      -command => sub { 
        my $rc = color_chooser($conf_win, $additional_colors);
        if (defined $rc) {
          $but->configure(-bg => $rc);
          $$config{$item}{value} = $rc;
        }
      })->pack(-side => 'left');
      $frame->Label(-text => $item_name, -anchor => 'w')->pack(-side => 'left', -expand => 1, -fill => 'x',);
    }
    ### FILE ###
    elsif ($$config{$item}{kind} eq 'file') {
      my $frame = $w->Frame(-bd => 1)->pack(-side => 'top', -expand => 1, -fill => 'x', -padx => 4, -pady => 4);
      $frame->Label(-text => $item_name, -anchor => 'w')->pack(-side => 'left', -expand => 1, -fill => 'x',);
      $but = $frame->Entry(-textvariable => \$$config{$item}{value},
          -width => ($total_length-length($item_name)),
        )->pack(-side => 'left', -padx => 5, -fill => 'y');
      $frame->Button(-text => '..',
      -command => sub { 
                        my $file = $w->getOpenFile(-title => $item_name, -initialdir => dirname($$config{$item}{value}));
                        if ((defined $file) and (-f $file)) {
                          $$config{$item}{value} = $file;
                        }
      })->pack(-side => 'left', -padx => 5);
    }
    ### DIR ###
    elsif ($$config{$item}{kind} eq 'dir') {
      my $frame = $w->Frame(-bd => 1)->pack(-side => 'top', -expand => 1, -fill => 'x', -padx => 4, -pady => 4);
      $frame->Label(-text => $item_name, -anchor => 'w')->pack(-side => 'left', -expand => 1, -fill => 'x',);
      $but = $frame->Entry(-textvariable => \$$config{$item}{value},
          -width => ($total_length-length($item_name)),
        )->pack(-side => 'left', -padx => 5);
      $frame->Button(-text => '..',
      -command => sub { 
                        my $dir = $w->chooseDirectory(-title => $item_name, -initialdir => $$config{$item}{value});
                        if ((defined $dir) and (-d $dir)) {
                          $$config{$item}{value} = $dir;
                        }
      })->pack(-side => 'left', -padx => 5);
    }
    ### STRING ###
    elsif ($$config{$item}{kind} eq 'string') {
      $but = $w->Frame(-bd => 1)->pack(-side => 'top', -expand => 0, -fill => 'x', -padx => 4, -pady => 4);
      $but->Label(-text => $item_name, -anchor => 'w')->pack(-side => 'left', -expand => 1, -fill => 'x',);
      $but->Entry(-textvariable => \$$config{$item}{value},
          -width => ($total_length-length($item_name)),
        )->pack(-side => 'left', -padx => 5);
    }
    ### RADIO ###
    elsif ($$config{$item}{kind} eq 'radio') {
      $but = $w->Frame(-bd => 1, -relief => 'groove')->pack(-expand => 0, -fill => 'x', -padx => 4, -pady => 4);
      $but->Label(-text => $item_name, -anchor => 'w')->pack(-expand => 1, -fill => 'x',);
      foreach my $option (keys %{$config->{$item}->{options}}) {
        $but->Radiobutton(-variable => \$$config{$item}{value}, -text => $$config{$item}{options}{$option}, -value => $option, -anchor => 'w')->pack(-expand => 1, -fill => 'x', -padx => 4, -pady => 4);
       }
    }
    else {
      warn "Configuration option $item \"$item_name\": unsupported config type = $$config{$item}{kind}\n";
      next;
    }
    
    if ((exists $$config{$item}{info}) and ($$config{$item}{info} ne '')) {
      $balloon->attach($but, -msg => $$config{$item}{info});
    }
  }
  
  # button frame for close button etc.
  my $bframe = $conf_win->Frame(-bd => 1)->pack(-side => 'top', -expand => 0, -fill => 'x');

  if ((defined $reset_callback) and (ref($reset_callback) eq 'CODE')) {
    my $reset_but = 
    $bframe->Button(-text => 'Reset',
                    -command => sub {
                                    my $ok =
                                      $conf_win->messageBox(-icon  => 'question', -message => "Really reset all options to default settings?",
                                                       -title => "Reset all options?", -type => 'OKCancel');
                                    if ($ok =~ m/Ok/i) {
                                      &$reset_callback(); # execute callback function
                                      $conf_win->destroy;
                                    }
                                    })->pack(-side => 'left',
                                             -padx => 3, -pady => 3);
    $balloon->attach($reset_but, -msg => 'Reset all options to default settings');
  }
  
  my $OKB = $bframe->Button(-text => 'Close', 
                            -command => sub { $conf_win->destroy;
                            })->pack(-side => 'right', -padx => 3, -pady => 3);

  if ((defined $apply_callback) and (ref($apply_callback) eq 'CODE')) {
    $bframe->Button(-text => 'Apply',
    -command => sub { &$apply_callback(); # execute callback function
    })->pack(-side => 'right', -padx => 3, -pady => 3);
  }

  $conf_win->bind('<Key-Escape>', sub { $OKB->invoke; });
  $conf_win->Popup;
  $conf_win->waitWindow();
}


# Preloaded methods go here.

1;
__END__
# Below is stub documentation for your module. You'd better edit it!

=head1 NAME

Tk::MhConfig - Perl extension to read, store and edit the configuration of a program

=head1 SYNOPSIS

  use Tk::MhConfig qw(configuration_edit configuration_store configuration_restore);

  my %config; # global configuration hash
  
  my ($ok, $err) = configuration_restore($config_file, \%config);
  warn $err if (not $ok);
  
  my ($ok, $err) = configuration_store($config_file, \%config);
  warn $err if (not $ok);

  configuration_edit($top, \%config, \@config_tab_order);
  
  sub configuration_set_default {

  # this defines the order of the tabs in the configuration_edit dialog:
  @config_tab_order = qw(General Behavior Extra);
  %config = (
  
  # General tab
  'make_backup'
  => { 'value' => 1,
       'kind' => 'bool',
	     'long' => 'Make backup',
	     'tab' => 'General',
       'frame' => 'Behavior',
	     'info' => "When selected the tool will always make a backup.",
	     'ord' => 1},

  'show_file_name'
  => { 'value' => 1,
       'kind' => 'bool',
	     'long' => 'Show file name',
	     'tab' => 'General',
       'frame' => 'Display',
	     'info' => "Show the file name (if available)",
	     'ord' => 2},

  'option_b'
  => { 'value' => 9,
    'kind' => 'int',
    'from' => 1,
    'to' => 12,
    'long' => 'Option B',
    'tab' => 'Extra',
    'info' => "Informative text ... blah blah\nblah blah",
    'ord' => 30},

=head1 DESCRIPTION

Tk::MhConfig is a framework to read, store and edit tool configurations (parameters of a software program, like e.g. the window background color).
Tk::MhConfig supports different kinds of options:

bool - boolean value (on/off)

number - integer number (0, 1, 2, 3, ...)

string - ("Hello world")

color - a valid color ("black", "red", "#0405AF")

file - a file with complete path (/usr/local/bin/mapivi)

dir - a directory (/usr/local/bin)

These options may be arranged in any number of tabs and grouped in labeled frames (see 'tab' and 'frame' in the examples above).
The order of the options inside the tabs is controlled by 'ord': low numbers are shown in the upper and high numbers are shown in the lower part of the tab.

=head2 EXPORT

Tk::MhConfig exports no function by default.
The following three functions are exported on demand:
configuration_edit()
configuration_store()
configuration_restore()

=head1 SEE ALSO

=head1 AUTHOR

Martin Herrmann

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2010 by Martin Herrmann

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.8 or,
at your option, any later version of Perl 5 you may have available.


=cut