package Tk::Style;

$VERSION='0.4';

use strict;
use Carp;
use XML::Parser;
use Storable;
use base 'Tk::MainWindow';

{
  my $parse; 
  {
    my %stuff;
    my $handler     = sub {
                            shift;
                            my $name      = shift;
                            return if $name eq 'tkcss'; 
                            my %x         = @_;
                            my $y;
                            @$y{map {'-' . lc($_)} keys %x } = values 
+%x;
                            $stuff{$name} = $y;
                          };
    
    $parse = 
      sub {
        my $xml     = new XML::Parser(Handlers => { Start => $handler 
+});
        my @args    = @_;
        my $badlist = 'Incorrect argument list; ' .
                      'for correct usage, see perldoc Tk::Style.';

        my $stylize = sub {
                            @_ % 2 and croak $badlist;
                            my %temp = @_;
                            for (keys %temp) {
                              $stuff{$_}  ||= {};
                              %{$stuff{$_}} = (%{$stuff{$_}}, %{$temp{
+$_}});
                            }
                          };

        my @style;
        my %action  = (
                        style => sub { push @style, $_[0] },
                        file  => sub { 
                                       $stylize->(@style) if @style;
                                       @style = ();
                                       $xml->parsefile($_[0])
                                     }
                      );

        my $state   = 'style';
        while ($_ = shift @args){
          if   (/^file$/i || /^style$/i) { $state = lc $_ }
          else                           { $action{$state}->($_) }
        }
        $stylize->(@style) if @style;
        my %x  = %stuff;
        ref $x{$_} eq 'HASH' or delete $x{$_} for keys %x;
        %stuff = ();
        %x;
      };
  }

  my $style    = sub { shift->{___style} };
  my $init;

  {
    my $unknown  = 'Stylesheet refers to unknown method ';

    $init     = sub {
                       my $self = $_[0];
                       no strict 'refs';
                       for my $x (keys %{&$style}){
                         my $y = $self->can($x) or croak $unknown . $x
+;
                         *{$x} = sub { $self->$y( %{&$style->{$x}}, @_
+ ) };
                       }
                     };
  }

  sub new {
    my $class = shift;
    my %style = &$parse;
    my %new   = $style{new} ? %{$style{new}} : ();
    my $self  = $class->SUPER::new( %new );
    delete $style{new};
    $self->{___style} = \%style;
    $self->$init();
    $self;
  }

  sub Style { my $x = Storable::dclone(&$style); wantarray ? %$x : $x 
+}
  
  sub Edit {
    my $x    = &$style;
    my %y    = &$parse;
    $x->{$_} = { (%{$x->{$_}||{}}, %{$y{$_}}) } for keys %y;
  }

  sub Alter {
    my $x    = &$style;
    my %y    = &$parse;
    %$x      = (%$x, %y);
  }
  
  sub Replace {
    my $x    = &$style;
    my %y    = &$parse;
    %$x      = %y;
  }
  
  sub AUTOLOAD { 
    no strict 'vars'; 
    carp "Warning! $AUTOLOAD should not have been called!";
  }
}  
  
1;


=head1 NAME

Tk::Style - Stylesheet support for Perl/Tk

=head1 VERSION

 This document describes version 0.4 of Tk::Style, which is 
 an alpha release.  Both the name and the API of the module 
 are subject to change.  Suggestions are welcome, even in 
 matters of style, though they may not be heeded.

 0.4 released (admitted to?) August 16, 2001

=head1 SYNPOSIS

   use Tk::Style;

   my %style = (                         # A plan to make Buttons, by 
                                         # default, utterly tasteless.
                 Button => {
                             -background       => '#00FF00',
                             -activebackground => '#0000FF',
                             -foreground       => '#FF00FF',
                             -activeforeground => '#FFFF00'
                           }
               );

                                         # Implement the plan
   my $style = Tk::Style->new(
                               file        => 'ugly.tkcss',
                               style       => %style,
                                              -background => '#00EEFF'
                             ); 
   $style->title('Demo');
   $style->Button(
                   -text    => 'Exit',
                   -command => sub { exit } 
                 )->pack;
   MainLoop;

=head1 DESCRIPTION

 Tk::Style inherits Tk::MainWindow, and adds the capacity 
 for supplying default parameters to MainWindow methods.  
 Explicitly supplied parameters override default ones, 
 providing a 'cascading' effect.  Hopefully this module 
 may be of some use in the holy quest to separate presentation 
 from content, and in reducing the number of highly redundant 
 presentation details commonly mixed up with GUI program logic.

 Style parameters may be supplied either from a TkCSS file 
 (ie. an appropriate XML document), or more directly in the 
 calling code.

=head1 PUBLIC METHODS

=head2 Interface

 Of the five public methods, one (Style) takes no arguments 
 at all.  The other four (new, Edit, Alter and Replace) all
 expect the same two sorts of arguments.  The structure of 
 these arguments is dictated by Tk::Style, but the content 
 is not; with any widget paramters that Tk::MainWindow will accept, 
 Tk::Style is perfectly happy.

 Firstly, one may specify default parameters directly by 
 supplying widget-name / hashref-of-default-param pairs.  
 The following example should make this clear:

   $style->method( Button => { -background => '#0000FF' } );

 Here background of the Button widget is made bright blue by 
 default.  Naturally multiple defaults may be set...

   $style->method( Button => { 
                                -background => '#0000FF',
                                -foreground => '#FF0000'
                              } 
                  );

 And multiple widgets may be specified as well:

   $style->method( 
                    Button => { -background => '#0000FF' }, 
                    Label  => { -background => '#00FF00' }
                  );

 It should be noted that style information will be applied 
 in the order that it is supplied, and that later information 
 will override earlier information.  For instance, if you 
 said this:

   $style->method( 
                    Button => { 
                                -background => '#FF0000',
                                -foreground => '#FF00FF'
                              }
                    Label  => { -background => '#00FF00' }
                    Button => { -background => '#0000FF' }, 
                  );

 The Button's default background would be set to green 
 (#00FF00) not red (#FF0000).  The Button's default 
 foreground, however, would remain purple.

 As the astute reader will have guessed, a list like this may 
 just as well be supplied by a hash:

   my %style = ( 
                 Button => { -background => '#0000FF' }, 
                 Label  => { -background => '#00FF00' }
               );
   $style->method( %style );

 Or by several hashes:

   my %style     = ( Button => { -background => '#0000FF' } );
   my %morestyle = ( Label  => { -background => '#00FF00' } );
   $style->method( %style, %morestyle );

 Now, one of the nice things about stylesheets, of course, 
 is the ability to keep presentation information apart from 
 your content... Tk::Style accepts properly formatted XML 
 files full of style information.  Lists of such files are 
 designated by the word 'file', like so:

   $style->method( file => 'filename.tkcss' );
   $style->method( 
                   file => 'filename.tkcss', 
                           'anotherfile.tkcss' 
                 );

 It is also possible to mix stylesheet files and explicitly 
 supplied style information in the same call; for this purpose 
 the designation 'style' is supplied.  

 So, these two calls are equivalent:

   $style->method( style  => %style );
   $style->method( %style );

 And here are some mixed calls:

   $style->method( 
                   file   => 'file.tkcss', 
                             'anotherfile.tkcss', 
                   style  => %style
                 );

   $style->method( 
                   file  => 'file.tkcss', 
                   style => %style, 
                            %morestyle 
                 );

   $style->method( 
                   file  => 'file.tkcss', 
                   style => %style, 
                            Button => { 
                                        -text   => 'Foo!',
                                        -relief => 'groove'
                                      }
                 );

   $style->method( 
                   file  => 'file.tkcss', 
                   style => %style, 
                   file  => 'file2.tkcss', 
                            'file3.tkcss',
                   style => Button => { -background => '#00FF00' }
                 );

 Again, order is important, and the last value supplied for 
 an attribute of a given widget will be the one that sticks.

 Now, on to the actual methods...

=head2 Methods

=over

=item * new

  new(), not surprisingly, is the constructor.  The object 
  returned may then be used just as you'd use a MainWindow 
  object.  The widgets it creates will use the default 
  paramters you've supplied, and any additional ones you 
  give the widget creation method.  Explicitly supplied 
  parameters will automatically override defaults.

  In addition to default parameters, this method will accept 
  a parameter called 'new', which will be taken as a parameter 
  to the inherited new constructor itself.  This will not 
  become a default parameter for the new() method.  This is 
  how you give Tk:Style those constructor parameters you used 
  to give to MainWindow->new().

=item * Style

  Style() simply returns the style information the object 
  already contains.  Called in list context, Style() 
  returns a list of key/value pairs, suitable for storing 
  in a hash.  Called in scalar context, Style() returns 
  a reference to the object's style information.

=item * Edit

  The Edit() method updates a widget's default parameters, 
  preserving old values for each where new values are not 
  supplied.  So for instance, if you said:

  my $style_object = Tk::Style->new(
                                     Button => {
                                                 -text  => 'Bar!',
                                                 -width => 10
                                               }
                                   );

  and then said:

    $style_object->Edit( Button => { -width => 20 } );

  You will have increased the default width of a button, 
  while allowing the default background color to remain 
  green.

=item * Alter

  The Alter() method is just like the Edit() method, but it 
  actually replaces the widget's entire paramter list with a 
  new one.  If you took the object described above, for instance, 
  and said:

    $style_object->Alter( Button => { -width => 40 } );

  a Button's default width would likewise be increased to 
  40, but Buttons would no longer have any other default 
  parameters whatsoever.  Labels, however, and other widgets 
  would retain any style information they had already been 
  given.

=item * Replace

  The Replace() method replaces all style information for 
  the Tk::Style object entirely.  If you were to say:

    $style_object->Replace( Button => { -width => 40 } );

  Then a Button would have a default width of 40, but no other 
  defaults... and neither would a Label or a Entry or any other 
  widget.  Calling Replace() without parameters, therefore, 
  simply clears all style information from the object.

=back

=head1 STYLESHEET SYNTAX

=head2 Synopsis

 <?xml version="1.0"?>
 <tkcss>
   <Button FOREGROUND="#00FFFF" 
           BACKGROUND="#FF00FF"
           ACTIVEBACKGROUND="#0000FF"
           ACTIVEFOREGROUND="#FFFF00"
           WIDTH="30"
   />
   <Label  FOREGROUND="#FFFF00"
           BACKGROUND="#FF0044"
           RELIEF="groove"
   />
   <new    BACKGROUND="#000044"/>
 </tkcss>

=head2 Description

 A "TkCSS" stylesheet is a simple XML document.  The root 
 element is called 'tkcss', and it should contain only 
 empty nodes named after Tk widgets.  The attributes of these 
 elements should be named after appropriate widget options, 
 and given appropriate values.  Pretty simple, really.

 So for instance, if the stylesheet says:

     <Button FOREGROUND="#00FFFF">

 It is the equivalent of coding:

 $style->method( Button => { -foreground => "#00FFFF" } );

 Use your creativity here, and be sure to let the author know if 
 you run into strange behavior.

=head1 DEPENDENCIES

  This module is implemented using XML::Parser, Storable, and 
  Tk::MainWindow (which means you should install Tk generally).

=head1 QUALMS, QUIRKS AND QUANDRIES

  There are various shortcomings to this module.  Most notably, 
  it only works at present for TopLevel widgets, because of the 
  very strange nature of Tk.  It would be good to correct this, 
  but rather than let the module sit around my hard drive any 
  longer, I've decided to get it out the door.  Perhaps others 
  will have improvements.

  It should be noted that this module does slightly Weird 
  Things(tm) with inheritance.  Not all modules are written 
  in a way that makes them easy to inherit; certainly Tk 
  isn't.  It is possbile that you could encounter strange, 
  hard-to-track bugs.  I haven't, and it seems to work well 
  enough, but it's possible.

  Edit, Alter, and Replace aren't exactly the best names for 
  methods.  Suggestions are welcome.

  It is even possible that someone will convince me that this 
  isn't a good idea in the first place.  I'm all ears.

  The author is cognizant of the absurdity of having far more 
  documentation than code.  Oh well.

  Even this list of shortcomings is incomplete.  Hey, what do 
  you want for nothing?  A rubber biscuit?

=head1 CHANGELOG

=item 0.4

 Realized the private method &$amend was unnecessary; it was
 assimilated into &$handler.

 More minor progress in the eternal quest for eloquence.


=item 0.3

 Released to PerlMonks August 16, 2001.

 Because of the streamlining done in 0.2, it was easy to see
 that the private method &$validate was unnecessary; it has
 been assimilated by &$parse.

 Slight improvment made in terms of shrinking the scope of
 a particular closure.


=item 0.2 

 Released to PerlMonks August 16, 2001.

 The Style method was added.

 The API for creating or changing the style data was changed 
 to allow one to arbitrarily mix 'style' and 'file' designators.

 The root element of a TkCSS stylesheet was changed from 
 'Tk_Stylesheet' to 'tkcss', in the great geek tradition of 
 favoring the brief and the obscure.

 The code was tightened in a number of ways.  The supporting 
 package Tk::Style::XML_HANDLER was made unnecessary and removed, 
 for instance.  All private methods were made unreachable from the 
 outside by implementing them with closures.  Numerous expressions 
 were streamlined, and program logic was improved.  All in all, 
 it came to suit the author's tastes much better.

=item 0.1 

 Released to PerlMonks August 14, 2001.

=head1 BUGS

  None known.  Ignorance is bliss.

=head1 AUTHOR

  Ray Brinzer (Petruchio of PerlMonks) <rbrinzer@avalon.net>

=head1 COPYRIGHT

  Copyright 2001, Ray Brinzer. All Rights Reserved.
  This program is free software; you can redistribute it and/or
  modify it under the terms of the GNU General Public License
  as published by the Free Software Foundation; either version 2
  of the License, or (at your option) any later version.
  <http://www.gnu.org/copyleft/gpl.html>
[download]