view release on metacpan or  search on metacpan

lib/Tk/Dressing.pm  view on Meta::CPAN

  @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__

=head1 NAME

Tk::Dressing - Set a theme (dressing) in your widget and its children.

=head1 SYNOPSIS

  #!/usr/bin/perl
  use warnings;
  use strict;
  use Tk;
  use Tk::Dressing;
  
  use Tk::BrowseEntry;
  
  my $tk_dressing = Tk::Dressing->new();
  
  my $mw = MainWindow->new( -title => "Dressing widget", );
  $mw->minsize( 300, 100 );
  
  $mw->Button( -text => 'Close', )->pack(qw/ -side bottom -padx 10 -pady 10 /);
  
  my $browse_entry_theme = $mw->BrowseEntry(
    -label   => "Select a theme : ",
    -state   => 'readonly',
    -choices => [ 'clear dressing', sort $tk_dressing->get_all_theme ],
  )->pack;
  
  my $message = "Hello everybody\n\nWelcome to Perl/Tk and Tk::Dressing\n\n";
  $mw->Label( -text => $message,     -anchor => 'center' )->pack(qw/ -side top -padx 10 -pady 10 /);
  $mw->Label( -text => 'Example : ', -anchor => 'center' )->pack(qw/ -side left -padx 10 -pady 10 /);