package AMP::Style; ###### Style class
### 	$Id: Style.pm,v 1.4 2003/05/09 19:32:14 steve Exp $
###

###	This class implements a style for formatting HTML with &AMP;

use XML::Node;
use XML::TrivialParser;
use Exporter();
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);

BEGIN {
    $VERSION=1.00;
    @ISA = qw(Exporter);
    @EXPORT = qw(&heading &footing &titleRow &bodyTag &setStyle
		 &hangIndent
		 %styles
		 $black $white $silver
		 );
}

#############################################################################
###
### Constants:
###

### Color constants
#	all style constants are pre-quoted for convenient use 
#	in a string like: "<table bgcolor=$white>

$white  = color('fff');
$silver = color('cccccc');
$grey1  = color('ccc');
$grey2  = color('999');
$grey3  = color('666');
$grey4  = color('333');
$black  = '"#000000"';

$orange = '"#FFCC99"';

$red	= color('f00');		# red
$dred	= color('900');		# dark red
$pred	= color('fcc');		# pale red (pink)

$green  = '"#00cc00"';		# green
$dgreen = '"#009900"';		# dark green
$pgreen = '"#ccffcc"';		# pale green

$blue	= color('00f');		# blue
$dblue	= color('009');		# dark blue
$pblue	= color('ccf');		# pale blue

### Font constants

$sans_serif = '"Verdana, Arial, Helvetica, sans-serif"';
$logoFace = $sans_serif;

#############################################################################
###
### Canned schemes:
###

%styles = 
    (
     allgrey   => { body => $silver,   text => $black,
		    hb => '999', tb => $silver, gb => $silver, rv => 0},
     whitebar  => { body => $silver,   text => $black,
		    hb => $white, tb => $silvver, gb => $silver, rv => 0},
     whitebox  => { body => $silver,   text => $black,
		    hb => $white, tb => $white, gb => $white, rv => 0},
     greybox   => { body => $white,   text => $black,
		    hb => $silver, tb => $silver, gb => $silver, rv => 0},
     greybar   => { body => $white,   text => $black,
		    hb => $silver, tb => $white, gb => $silver, rv => 0},
     darkred   => { body => $white,   text => $black,
		    hb => $dred, tb => $white, gb => $silver, rv => 1},
     palered   => { body => $white,   text => $black,
		    hb => $pred, tb => $white, gb => $silver, rv => 0},
     darkgreen => { body => $white,   text => $black,
		    hb => $dgreen, tb => $white, gb => $silver, rv => 1},
     palegreen => { body => $white,   text => $black,
		    hb => $pgreen, tb => $white, gb => $silver, rv => 0},
     darkblue  => { body => $white,   text => $black,
		    hb => $dblue, tb => $white, gb => $silver, rv => 1},
     paleblue  => { body => $white,   text => $black,
		    hb => $pblue, tb => $white, gb => $silver, rv => 0},
     goth      => { body => $black,   text => $white,
		    link => '99f',   vlink => '90f',
		    hb => '666', tb => '333', gb => '666', rv => 0},
     );
			 
	   
sub default {
    setStyle('greybar');
}

default();			# set the default color scheme


#############################################################################
###
### Color and style setting
###

sub setStyle {
    $h = shift;

    if (ref $h) {
	setBodyColors(color($h->{body}), color($h->{text}), 
		      color($h->{link}), color($h->{vlink}));
	setHeadingColors(color($h->{hb}), $h->{rv});
	setTableColors(color($h->{tb}), color($h->{gb}));
	$style = $h;
    } elsif (ref $styles{$h}) {
	$styleName = $h;
	setStyle($styles{$h});
    } else {
	default;
    }
}

sub getStyle {
    return $style;
}

#setStyle({body=>$white, text=>$black, tb=>ccc, hb=>ccc});

sub color {
    my ($rgb) = (@_);
    
    if (!$rgb || $rgb =~ /["']/) { return $rgb; } #'"])
    
    if ($rgb =~ /^([0-9a-f])([0-9a-f])([0-9a-f])$/i) {
	$rgb = "$1$1$2$2$3$3";
    }
    $rgb = "#" . $rgb unless $rgb =~ /^\#/;
    return "'$rgb'";
}

### setBodyColors(bg, text, lin, vlink)
#	Set the colors for the body tag.  Should be called first.
sub setBodyColors {
    my ($bgcolor, $textcolor, $linkcolor, $vlinkcolor) = (@_);

    $body = $bgcolor? $bgcolor : $white;
    $text = $textcolor? $textcolor : $black;
    $link = $linkcolor? $linkcolor : color('0000ee');	# from netscape 4
    $vlink= $vlinkcolor? $vlinkcolor : color('551a8b');	# from netscape 4
}

### setTableColors(normal, group)
#	The "normal" color is used primarily in Message->tableRow and other
#	places where you want to set a table off from the body text; it's
#	not used in tables that are just used for layout of something
#	that is basically body information.
#
#	The "group" background color is used, as one might expect,
#	for grouping things together when you don't want to use a
#	contrasting heading.   
#
sub setTableColors {
    my ($tbcolor, $gbcolor) = (@_);

    $tb = $tbcolor? $tbcolor : $body;
    $gb = $gbcolor? $gbcolor : $hb? $hb : $body;
}

### setHeadingColors(reverseVideo, hbcolor)
#	Set the background and foreground colors for the titleRow, 
#	heading, and footing.  if reverseVideo is true, render the 
#	text in white instead of the default (typically black).
sub setHeadingColors {
    my ($hbcolor, $reverseVideo) = (@_);
    $rv = $reverseVideo;

    $fg = $rv? $body : $text;
    $wf = $rv? "<font color=$fg>" : '';
    $ef = $rv? '</font>' : '';
    $hb = $hbcolor;
}

#############################################################################
###
### Color and style access functions
###

sub rv 		{ return $rv; }	# 'reverse video' headings
sub hb 		{ return $hb; }	# heading bar background
sub fg 		{ return $fg; }	# heading bar foreground 

sub tb 		{ return $tb; }	# (normal) table background
sub tbColor	{ return $tb; }

sub gb 		{ return $gb; }	# group background
sub gbColor 	{ return $gb; }

sub bodyColor	{ return $body; }
sub textColor	{ return $text; }

#############################################################################
###
### Formatting:
###

sub bodyTag {
    return "<body text=$text bgcolor=$body link=$link vlink=$vlink>\n";
}

sub logoFont {
    my ($text) = (@_);

    return "<font color=$dgreen face=$logoFace size='+2'>"
	. ($text? "$text</font>" : '');
}

sub logoFontSml {
    my ($text) = (@_);

    return "<font color=$dgreen face=$logoFace>"
	. ($text? "$text</font>" : '');
}

sub titleRow {
    my ($th, $td) = (@_);
    return "<tr bgcolor=$hb><th align='right'>$wf $th $ef</th>\n" . 
	"    <td>$wf$td$ef&nbsp;</td></tr>";
}
sub heading {
    my ($title, $help, $helpTitle) = (@_);

    return ("<table cellspacing='0' cellpadding='2' border='0'" .
		   " bgcolor=$white width='100%'>")
	. "<tr><th align='left' colspan='2' bgcolor=$hb>" 
	.          "$wf $title $ef</th>"
	.        "<td align='right' bgcolor=$hb> "
	.	 "    &nbsp; " 
	. ($help? "<a href='$help'>$wf$helpTitle$ef</a>" : "") . " </td>"
	. "</tr>\n</table>"; 
}

sub footing {
    my ($title, $link, $linkTitle) = (@_);
    my $src = '';
    if ($ENV{'EXPERIMENTAL'}) {
	$src = "/tv-src/htdocs/$Common::mypath" if (-d "$Common::root/tv-src");
	$src = "<a href='$src'>[source]</a>" if $src;
	# === $src currently unused; $Common::stgTrailer has extra line 
	#     with more space.
    }
	
    return ("<table cellspacing='0' cellpadding='2' border='0'" .
		   " bgcolor=$hb width='100%'>")
	. "<tr><td><a href='$Common::mypath'>$wf$Common::mypath [doc]$ef</a>\n"
	. "    </td>"
	. "    <td align='right' colspan='2' bgcolor=$hb>" 
	.          "$wf $title $ef"
	. ($link? "<a href='$link'>$wf$linkTitle$ef</a>" : "") . "</td>"
	. "</tr>\n</table>"; 
}

sub hangIndent {
    my ($left, $right) = (@_);
    return ("<table border='0'>\n" .
	    "  <tr><td valign='top'>$left</td>\n" .
	    "      <td valign='top'>$right</td>\n" .
	    "  </tr>\n</table>\n");
}

#############################################################################
###
### Samples:
###

### sampleTD(text, link, bg, fg)
#	Return a td element with bgcolor and text color equal to the Style's
#	body and text colors, respectively.
sub sampleTD {
    my ($txt, $url, $f, $b) = (@_);
    $f = $text unless $f;
    $b = $body unless $b;

    return "<td bgcolor=$b>" 
	. ($url? "<a href='$url'><font color=$f>$txt</font></a>"
	       : "<font color=$f>$txt</font>")
	. "</td>";
}

sub sampleRowHead {
    my ($txt, $f, $b) = (@_);
    return "<tr>" . "<th>$txt</th>"
	.  "    <th>body</th><th>text</th><th>link</th><th>vlink</th>\n"
	.  "    <th>hb</th><th>rv</th><th>tb</th><th>gb</th></tr>\n";
}

sub cn {
    my $color = shift;
    $color =~ /([0-9a-f]+)/i;
    return "<tt>$1</tt>";
}

sub sampleRow {
    my ($txt, $url, $f, $b) = (@_);  

    return "<tr>" .
	(sampleTD($txt, $url, ($rv? $body : $text), $hb) .
	 sampleTD(cn $body) . sampleTD(cn $text) . 
	 sampleTD(cn($link), '', $link)  . sampleTD(cn($vlink), '', $vlink) .
	 sampleTD(cn($hb), '', ($rv? $body : $text), $hb) .
	 sampleTD($rv, '', ($rv? $body : $text), $hb) .
	 sampleTD(cn($tb), '', '', $tb) . sampleTD(cn($gb), '', '', $gb) )
	    . "</tr>\n";
}

sub styleSample {
    my $txt = shift;

    $txt = "Current Style" unless $txt;
    return "<table border='1' bgcolor=$tb>\n" 
	. sampleRowHead($txt) . sampleRow($styleName) . "\n</table>";
}

sub styleNames {
    my @names = (keys %styles);
    return sort @names;
}


#############################################################################
'Package loaded';

