File Coverage

blib/lib/Tk/Dressing.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Tk::Dressing;

use warnings;
use strict;
use Carp;

#==================================================================
# $Author    : Djibril Ousmanou                                   $
# $Copyright : 2011                                               $
# $Update    : 01/01/2011 00:00:00                                $
# $AIM       : Set a design for a Tk widget and its children      $
#==================================================================

use Tk;
use Config::Std { def_gap => 0 };
use File::Basename qw/ dirname /;
use File::Copy qw / copy /;
use File::Spec;

use vars qw($VERSION);
$VERSION = '1.04';

# get theme directory
my $themes_directory = File::Spec->catfile( dirname( $INC{'Tk/Dressing.pm'} ), 'DressingThemes' );

my %new_theme;
my %initial_theme;
my $current_theme;
my $POINT = q{.};

sub new {
  my ($self) = @_;

  $self = ref($self) || $self;
  my $this = {};
  bless $this, $self;

  return $this;
}

sub get_current_theme {
  my $this = shift;

  return $current_theme;
}

sub get_all_theme {
  my $this = shift;

  opendir my $fh_rep, $themes_directory or croak "Unable to read themes directory : $themes_directory\n";
  my @alltheme = grep {m/\.ini$/msx} readdir $fh_rep;
  foreach (@alltheme) { s/\.ini$//msx; }
  closedir $fh_rep or croak "Unable to close themes directory\n";

  # New themes loaded
  push @alltheme, keys %new_theme;

  my %unique;
  @unique{@alltheme} = ();

  return keys %unique;
}

sub get_default_theme_file {
  my ( $this, $theme, $directory ) = @_;

  if ( not defined $theme ) {
    carp("Theme not defined\n");
    return;
  }

  $directory = defined $directory ? $directory : $POINT;

  my $theme_file     = "$themes_directory/$theme.ini";
  my $new_theme_file = "$directory/$theme.ini";

  # default theme file
  if ( -e $theme_file ) {
    copy( $theme_file, $new_theme_file );
    return $new_theme_file;
  }
  carp("$theme not found\n");

  return;
}

sub load_theme_file {
  my ( $this, $theme, $theme_file ) = @_;

  if ( -e $theme_file ) {
    read_config $theme_file => my %config;
    $new_theme{$theme} = \%config;
    return;
  }

  carp("$theme_file not found\n");
  return;
}

sub clear {
  my ( $this, $widget ) = @_;

  if ( ( not defined $widget ) or ( !Exists $widget) ) {
    carp("Widget not defined\n");
    return;
  }

  if (%initial_theme) {
    $this->design_widget( -widget => $widget, -clear => 1 );
    $current_theme = undef;
  }

  return 1;
}

sub _default_config {
  my ( $this, $widget, $ref_config_theme ) = @_;

  my ( $class, $type ) = split m/::/msx, ref $widget;
  $type = defined $type ? $type : $class;
  if ( not defined $type ) { return; }

  # Store the initial configuration before set the first theme
  if ( !$initial_theme{$type} ) {
    foreach my $option ( sort keys %{ $ref_config_theme->{$type} } ) {
      my $initial_value = $widget->cget($option);
      next if ( not defined $initial_value );

      if ( $initial_value eq 'SystemButtonFace' and $type eq 'Entry' ) {
        if ( $option eq '-background' ) { $initial_value = 'white'; }
      }
      elsif ( $initial_value eq 'SystemWindow' and $type eq 'Frame' ) {
        $initial_value = 'SystemButtonFace';
      }
      $initial_theme{$type}{$option} = $initial_value;
    }
  }

  # children widgets design setting
  foreach my $child_level1 ( sort $widget->children ) {
    $this->_default_config( $child_level1, $ref_config_theme );
  }
  return;
}

#============================================
# set design in widget and its children
#============================================
sub design_widget {
  my ( $this, %information ) = @_;

  my $theme = $information{-theme} || 'djibel';
  if ( not defined $theme ) {
    carp("Theme not defined\n");
    return;
  }

  my $widget = $information{-widget};
  if ( ( not defined $widget ) or ( !Exists $widget ) ) {
    carp("Widget not defined\n");
    return;
  }

  my $clear = $information{-clear};

  # Get theme configuration
  my $ref_config_theme;

  # Clear
  if ( defined $clear and $clear == 1 ) {
    $ref_config_theme = \%initial_theme;
  }
  elsif ( exists $new_theme{$theme} ) {
    $ref_config_theme = $new_theme{$theme};
  }
  else {
    my $theme_file = "$themes_directory/$theme.ini";
    if ( !-e $theme_file ) {
      carp("$theme not found\n");
      return;
    }

    read_config $theme_file => my %config;
    $new_theme{$theme} = \%config;
    $ref_config_theme = $new_theme{$theme};
  }
  if ( not defined $ref_config_theme ) { return; }

  # Get Default configuration
  if ( ( !%initial_theme ) or ( not defined $clear or $clear != 1 ) ) {
    $this->_default_config( $widget, $ref_config_theme );
  }

  # Get Class an type of widget to design it
  my ( $class, $type ) = split m/::/msx, ref $widget;

  # For MainWindows widget, ref($widget) = MainWindow, then $type = $class
  # Else for Tk::Widget, ref($widget) = Tk::Toplevel or Tk::Frame, etc => $type ok
  $type = defined $type ? $type : $class;
  if ( not defined $type ) { return; }

  # Read configuration option
  if ( my $design_type = $ref_config_theme->{$type} ) {

    # Set configuration
    $widget->configure( %{$design_type} );
  }

  # children widgets design setting
  foreach my $child_level1 ( $widget->children ) {
    if ( defined $clear and $clear == 1 ) {
      $this->design_widget( -widget => $child_level1, -clear => 1 );
    }
    else {
      $this->design_widget( -widget => $child_level1, -theme => $theme );
    }
  }

  $current_theme = $theme;
  return;
}

1;
__END__