Prima::Themes - object themes management

	perl -MPrima::Themes program

	# register a theme file
	use Prima::Themes qw(color);
	# or
	use Prima::Themes; load('color');
	# list registered themes
	print Prima::Themes::list;

	# install a theme
	Prima::Themes::install('cyan');
	# list installed themes
	print Prima::Themes::list_active;
	# create object with another theme while 'cyan' is active
	Class->create( theme => 'yellow');
	# remove a theme
	Prima::Themes::uninstall('cyan');

	package ConstLineWidth;
	use vars qw(@ISA);
	@ISA = qw(Prima::Themes::Proxy);

	sub lineWidth { 1 } # line width is always 1 now!

	Prima::Themes::register( '~/lib/constlinewidth.pm', 'constlinewidth', 
		[ 'Prima::Widget' => {
			onPaint => sub {
				my ( $object, $canvas) = @_;
				$object-> on_paint( ConstLineWidth-> new( $canvas));
			},
		} ]
	);

#
#  Copyright (c) 1997-2003 The Protein Laboratory, University of Copenhagen
#  All rights reserved.
#
#  Redistribution and use in source and binary forms, with or without
#  modification, are permitted provided that the following conditions
#  are met:
#  1. Redistributions of source code must retain the above copyright
#     notice, this list of conditions and the following disclaimer.
#  2. Redistributions in binary form must reproduce the above copyright
#     notice, this list of conditions and the following disclaimer in the
#     documentation and/or other materials provided with the distribution.
#
#  THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
#  ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
#  IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
#  ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
#  FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
#  DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
#  OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
#  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
#  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
#  OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
#  SUCH DAMAGE.
#
#  Created by Dmitry Karasik <dmitry@karasik.eu.org>
#
#  $Id$

use strict;
use Prima;
package Prima::Themes;
use vars qw(%themes %data $load_rc_file);

use constant INSTALLED => 0;
use constant CALLBACK  => 1;
use constant PROFILE   => 2;
use constant MODULE    => 3;
use constant INSTALL   => 4;

# install implicit property 'theme' selector
push @Prima::Object::hooks, \&hook;
# load and execute theme from rc file
load_rc(1) if $load_rc_file || !defined $load_rc_file;

sub hook
{
	my ( $object, $profile, $default) = @_;
	if ( exists $default-> {theme} || exists $profile-> {theme}) {
		my $theme = exists($profile-> {theme}) ? $profile-> {theme} : $default-> {theme};
		# execute explicitly selected theme
		execute( $themes{$theme}, $object, $profile, $default) 
			if exists $themes{$theme};
	} else {
		# execute for all installed themes
		execute( $themes{$_}, $object, $profile, $default) 
			for grep { $themes{$_}-> [INSTALLED] } keys %themes;
	}
};

sub load_rc
{
	my $install = defined( $_[0]) ? $_[0] : 1;
	eval "use Prima::Utils;"; die $@ if $@;
	my $f = Prima::Utils::path('themes');
	if ( $f && -f $f && open F, '<'.$f) {
		while ( <F>) {
			next if m/^\s*#/;
			chomp;
			my @r = split(',', $_, 3);
			next unless defined $r[0] && defined $r[1];
			$data{$r[1]} = $r[2];
			eval "use $r[0];";
			warn( "** warning: error loading module `$r[0]': $@\n"), next if $@;
			warn( "** warning: theme `$r[1]' is not defined\n"), next 
				unless loaded($r[1]);
			install($r[1]) if $install;
		}
		close F;
	}
}

# saves currently installed modules
sub save_rc
{
	eval "use Prima::Utils;"; die $@ if $@;
	my $f = Prima::Utils::path('themes');
	return 0 unless open F, '>'.$f;
	for ( keys %themes) {
		next unless $themes{$_}-> [INSTALLED] && $themes{$_}-> [MODULE];
		my $data = defined($data{$_}) ? $data{$_} : '';
		print F "$themes{$_}->[MODULE],$_,$data\n";
	}
	return close F;
}

# register theme
sub register
{
	my ( $file, $theme, $profile, $merger, $installer) = @_;
	deregister($_) if $themes{$theme};
	$themes{$theme} = [ 
		0,         # activity flag
		$merger,   # merger routine, our own if undef
		$profile,  # theme profile
		$file,     # theme file
		$installer,# installer/uninstaller routine
	];
}

# kill theme
sub deregister 
{
	uninstall($_[0]);
	delete $themes{$_[0]};
}

# list registered themes
sub list { keys %themes }
# list active themes
sub list_active { grep { $themes{$_}-> [INSTALLED] } keys %themes }

# checks if theme is loaded
sub loaded { defined($_[0]) ? exists $themes{$_[0]} : undef }
# checks if theme is active
sub active { (defined($_[0]) && exists $themes{$_[0]}) ? $themes{$_[0]}-> [INSTALLED] : undef }


# unistall all themes and select new
sub select
{
	my @themes = @_;
	uninstall (keys %themes);
	install (@themes);
}

# load themes from files
sub load { for ( @_) { eval "use Prima::themes::$_"; die $@ if $@ }}
# makes 'use Prima::Themes qw(mytheme theme1);' possible
sub import { 
	shift; 
	my $install;
	for ( @_ ) {
		if ( $_ eq ':install') {
			$install = 1;
		} else {
			$install ? install($_) : load($_);
		}
	}
}

# install themes
sub install
{
	for ( @_) {
		my $theme = $_;
		next if !exists $themes{$theme} || $themes{$theme}-> [INSTALLED];
		if ( $themes{$theme}-> [INSTALL]) {
			$themes{$theme}-> [INSTALLED] = $themes{$theme}-> [INSTALL]-> ($theme, 1);
		} else {
			$themes{$theme}-> [INSTALLED] = 1;
		}
	}
}

# uninstall themes
sub uninstall
{
	for ( @_) {
		my $theme = $_;
		next if !exists $themes{$theme} || !$themes{$theme}-> [INSTALLED];
		$themes{$theme}-> [INSTALL]-> ($theme, 0) if $themes{$theme}-> [INSTALL];
		$themes{$theme}-> [INSTALLED] = 0;
	}
}

# theme data property
sub data
{
	return $data{$_[0]} unless $#_;
	$data{$_[0]} = $_[1];
}

# default merger procedure
sub merger
{
	my ( $object, $profile, $default, $new) = @_;
	$profile-> {$_} = $new-> {$_} for keys %$new;
}

# applies theme during Object::profile_add
sub execute
{
	my ( $instance, $object, $profile, $default) = @_;
	my $merger = $instance-> [CALLBACK] || \&merger; 
	my $profiles = $instance-> [PROFILE];
	return unless $profiles;
	my $i;
	for ( $i = 0; $i < @$profiles; $i += 2) {
		$merger-> ( $object, $profile, $default, $$profiles[$i+1]) if $object-> isa($$profiles[$i]);
	}
}

package Prima::Themes::Proxy;

sub new
{
	return bless { object => $_[1] }, $_[0];
}

sub AUTOLOAD
{
	no strict;
	my ($method) = $AUTOLOAD =~ /::([^:]+)$/;
	return shift-> {object}-> $method( @_);
}

# do not fordward DESTROY
sub DESTROY {}


1;