package ATR::Tk::Font;

use warnings;
use strict;

# not a Tk::Derived, the Tk::Font doesn't look like it will play nicely with that
use base 'Tk::Font';


=head1 NAME

ATR::Tk::Font - a thin subclass of Tk::Font to help with fractional
sizes

=head1 DESCRIPTION

AFAICS, Tk 800.024 can't show fractional point size fonts under X11,
and we don't try to make it do that.

We do store the fractional font size the user requested, and provide
an easy way to generate a C<-fontmap> list for use with
C<Tk::Canvas-E<gt>postscript(...)>.

This is only useful for named fonts, because the others don't appear
in C<$mw-E<gt>fontNames>.

=head1 CAVEATS

The calculations a widget does to figure out its size will be based on
the underlying allocated X11 (or other) font, and done in C where we
can't change the result.

The widget user will have to force a resize to the fractional font
size.

=cut

# $Id: Font.pm,v 1.5 2005/04/13 14:02:55 mca Exp $

#----------------------------------------------------------------------------
#
# Tk::Font overrides

# Comes after Tk::Font's Construct(), so we take control of font creation.
# Scary stuff.
{
    local $SIG{__WARN__} = sub {}; # hide "Subroutine Tk::Widget::Font redefined" message
    Construct Tk::Widget 'Font';
}


# sub Name
#   nb. SUPER::Name dies in list context, appears to be a bug...


sub new {
    # SUPER::new does the work, we just need to sniff off '-size'
    # Args can be given in various ways...
    my $pkg  = shift;
    my $w    = shift;
    my @args = @_;

    my $me = $pkg->SUPER::new($w, @args);
    $me->fracsize($me->SUPER::configure('-size'));

#warn "DBG:Made font '$args[0]'\n";
    if (@args > 1) {
	while (@_) {
	    my $k = shift;
	    my $v = shift;
	    if ($k eq '-size' || $k eq 'size') {
		$me->fracsize($v);
	    }
	}
    }

    return $me;
}


sub configure {
    my ($self, @args) = @_;
    if (@args == 1) {
	if ($args[0] eq '-size') {
	    # read fractional size
	    return $self->fracsize;
	}
    } elsif (@args == 0) {
	# read all configs
	my %config = $self->SUPER::configure;
	$config{-size} = $self->fracsize;
	return %config;
    } elsif (@args > 1 && 0 == @args % 2) {
	# configure pair(s)
	my %args = @args;
	$self->fracsize($args{-size}) if defined $args{-size};
    } else {
	local $" = ", ";
	warn "Unknown style of $self->configure(@args)\n";
    }

    return $self->SUPER::configure(@args);
}


#----------------------------------------------------------------------------
#
# Add-ons

# The Scalar::Util::reftype of these objects is SCALAR,
# so we can't tack on a bit of data.  Put it in here.
my %fracsize;

sub fracsize {
    my $self = shift;
    if (@_) { 
	$fracsize{$self} = shift;
    } else {
	return $fracsize{$self} || 0;
    }
}


# Tidy up when it goes
sub DESTROY {
    my $self = shift;
#warn "DBG:font gone $self : ".(eval { $self->Name } || '[gone]')."\n";
    delete $fracsize{$self};
    $self->SUPER::DESTROY;
}


# Returns (fontname => [ Family, fracsize])
sub makeFontmap {
    my $self = shift;
    my $name = $self->Name; # must be scalar

    my $psfont; # modified by next call
    my $pssize = $self->PostscriptFontName($psfont);
    my $fsize = $self->fracsize;

#warn "DBG: fontmap: $name => [ $psfont, $fsize ($pssize) ], screen=".$self->actual('-size')."\n";
    return ($name => [ $psfont, $fsize ]);
}


#----------------------------------------------------------------------------
#
# Scaled sizes.  The Tk code ignores these, so method overrides would
# be confusing to the API user

# Same as 'metrics', but scaled for the intended fractional font size
sub fracMetrics {
    my ($self, @args) = @_;
    my $fracScale = $self->fracRatio;
    my %m = $self->metrics;
    foreach my $k (keys %m) {
	next if $k eq '-fixed'; # don't scale the boolean!
	$m{$k} *= $fracScale;
    }
    return $m{$args[0]} if @args == 1;
    return @m{@args} if @args;
    return %m;
}

sub fracRatio {
    my $self = shift;
    return $self->fracsize / $self->actual('-size');
}

# Same as 'measure', but scaled for the intended fractional font size
sub fracMeasure {
    my ($self, $text) = @_;
    return $self->fracRatio * $self->measure($text);
}

1;
