package RISCOS::DrawFile::Text;
use Carp;

use strict;
use vars qw ($VERSION @ISA);
use RISCOS::Units qw(pack_transform_block unpack_transform_block
		     millipoint2draw point2draw);
require RISCOS::DrawFile::Object;
require RISCOS::Font;
use RISCOS::Colour qw(pack_colour unpack_colour);

$VERSION = 0.05;
# 0.02 Change pack template to I5i2 as x,y are *signed*
# 0.03 PrePack calls BBox, not BBoxCalc
# 0.04 if font passed to new is a font object then read its details, ignore
# xsize, ysize
# flags to strip spaces and return empty objects
# 0.05 adds Translate

@ISA = 'RISCOS::DrawFile::Object';

### use SelfLoader;
sub RISCOS::DrawFile::Text::new ($$);
sub RISCOS::DrawFile::Text::Type ;
sub RISCOS::DrawFile::Text::BBox_Calc ;
sub RISCOS::DrawFile::Text::Translate ($$$$);
sub RISCOS::DrawFile::Text::PrePack ;
sub RISCOS::DrawFile::Text::Size ;
sub RISCOS::DrawFile::Text::Pack ($$);
sub RISCOS::DrawFile::Text::ForeColour ;
sub RISCOS::DrawFile::Text::BackColour ;
sub RISCOS::DrawFile::Text::Font ;
sub RISCOS::DrawFile::Text::Text ;
sub RISCOS::DrawFile::Text::X ;
sub RISCOS::DrawFile::Text::Y ;
sub RISCOS::DrawFile::Text::W ;
sub RISCOS::DrawFile::Text::H ;
sub RISCOS::DrawFile::Text::Kern ;
1;
### __DATA__
sub new ($$) {
    my $proto = shift;
    my $class = ref($proto) || $proto;

    my ($self, $type) = $class->SUPER::new (@_);
    return $self if ref ($self) eq 'ARRAY';

    my ($flag, $strip, $bbox, $length, $fore, $back, $font, $xsize, $ysize,
	$xbase, $ybase, $text, $kern, $r2l, $trans) = (0);
    return wantarray ? () : undef unless defined $_[0];
    $strip = $_[1] || 0;
    if (ref ($_[0]) eq 'ARRAY') {
	($fore, $back, $font, $xsize, $ysize, $xbase, $ybase, $text, $kern,
	  $r2l, $trans) = @{$_[0]};
	$flag |= 1 if $kern;
	$flag |= 2 if $r2l;
	if (ref ($font) eq 'RISCOS::Font') {
	    if ($strip & 2 and $text =~ s/^( +)//) {
		$xbase += millipoint2draw $font->StringBBox($1)->[2];
	    }
	    ($font, $xsize, $ysize) = $font->Name();
	} else {
	    $ysize = $xsize unless defined $ysize;
	}
	($fore, $back) = pack_colour ($fore, $back);
	$trans = [@$trans] if defined $trans;	# Copy it.
    } else {
	# Time to unpack data
	my $data = 0;
	if (ref ($_[0]) eq 'SCALAR' or ref ($_[0]) eq 'LVALUE') {
	    # Has bounding box stripped
	    $data = ${$_[0]};
	} else {
	    ($length, @$bbox) = unpack 'x4Ii4', $_[0];
	    return undef unless length ($_[0]) == $length or $length & 3;
	    $data = substr $_[0], 24;
	}
	if ($type == 12) {
	    $data =~ s/^(.{24})(....)//s;
	    $trans = unpack_transform_block $1;
	    $flag = unpack 'I', $2;
	    # $kern = $flag & 0;
	    # $r2l = $flag & 1;
	    carp sprintf 'DrawFile object 12 (transformed text) flag is %X '
			 . '(reserved bits not zero)', $flag if $flag & ~3;
	    # Note that the low byte of this flag word is passed unmasked << 9
	    # to Font_ScanString in R2
	}
	my $style;
	($fore, $back, $style, $xsize, $ysize, $xbase, $ybase, $text)
	 = unpack 'a4a4I3i2a*', $data;
	$xsize /= 640;
	$ysize /= 640;
	$text =~ s/\0.*//s;
	if ($style) {
	    croak 'No FontTable' unless defined ${$_[2]};
	    unless (defined ($font = ${$_[2]}->FontByNumber ($style))) {
		carp "Unable to find font number $style in FontTable";
		$font = '';
	    }
	} else {
	    $font = '';
	}
    }

    $text =~ s/ *$// if $strip & 1;	# Strip trailing spaces.
    if ($strip & 2 and $text =~ s/^( +)//) {
	$xbase += millipoint2draw
	   RISCOS::Font::StringBBox([$font, $xsize, $ysize], $1)->[2];
    }
    unless (length $text) {
	return [] if $strip & 4;	# Flag set to quietly drop this
	carp 'Attempt to create zero length text object';
	return wantarray ? () : undef;
    }
    $self->{'__BBOX'} = $bbox;
    $self->{'__FONTFLAG'} = $flag;
    $self->{'__TRANSFORM'} = $trans if defined $trans;
    $self->{'__FORE'} = $fore;
    $self->{'__BACK'} = $back;
    $self->{'__FONT'} = $font;
    $self->{'__H'} = $xsize;
    $self->{'__W'} = $ysize;
    $self->{'__X'} = $xbase;
    $self->{'__Y'} = $ybase;
    $self->{'__TEXT'} = $text;

    wantarray ? ($self, $type) : $self;
}

sub Type {
    my $self = shift;
    return 12 if defined $self->{'__TRANSFORM'} or $self->{'__FONTFLAG'};
    1;
}

# erk, convert from millipoints to Draw Units
sub BBox_Calc {
    my $self = shift;
    my $bbox;
    if ($self->{'__FONT'}) {
	@$bbox #	need array context
	  = millipoint2draw
	    RISCOS::Font::StringBBox ([$self->{'__FONT'},
				       $self->{'__H'}, $self->{'__W'}],
				       $self->{'__TEXT'},
				       $self->{'__FONTFLAG'},
				       $self->{'__TRANSFORM'});
    } else { # System font
	$$bbox[0] = $$bbox[1] = 0;
	$$bbox[2] = length ($self->{'__TEXT'}) * point2draw ($self->{'__W'});
	$$bbox[3] = point2draw ($self->{'__H'});
    }
    $$bbox[0] += $self->{'__X'};
    $$bbox[1] += $self->{'__Y'};
    $$bbox[2] += $self->{'__X'};
    $$bbox[3] += $self->{'__Y'};
    # print STDERR 'was ' . join (', ', @{$self->{'__BBOX'}}) . "\n";
    # print STDERR 'now ' . join (', ', @$bbox) . "\n";
    $self->{'__BBOX'} = $bbox;
}

sub Translate ($$$$) {
    my ($self, $x, $y) = @_;
    my $bbox = $self->{'__BBOX'};
    if (defined $bbox) {
	$$bbox[0] += $x;
	$$bbox[1] += $y;
	$$bbox[2] += $x;
	$$bbox[3] += $y;
    }
    $self->{'__X'} += $x;
    $self->{'__Y'} += $y;
    ();
}

sub PrePack {
    my $self = shift;
    # hash key is font name, value is number of users.
    # only really need zero/non-zero
    ++$_[0]->{$self->{'__FONT'}};
    $self->BBox (@_);
}
sub Size {
    my $self = shift;
    # 28 for transform & flags if present
    # 28 for text colour to baseline coords
    # 24 for type, length and bbox
    # 4 for '\0' and padding.
    my $size = (($self->Type == 12) ? (28 + 28 + 24 + 4)
				 : (28 + 24 + 4))
		+ length $self->{'__TEXT'};
    $size & ~3;
}

sub Pack ($$) {
    my $self = shift;
    my $font = $_[1];
    my $type = $self->Type;
#    my ($xxx, $yyy, $XXX, $YYY) = map {pack 'i', $_} @{$self->BBox};
    $self->PackTypeSizeBBox($type)
      . (($type == 12) ? (pack_transform_block (defined $self->{'__TRANSFORM'}
						? $self->{'__TRANSFORM'}
						: (0,0,0,0,0,0))
			 . pack 'i', $self->{'__FONTFLAG'})
		      : '')
      . pack ('a4a4I3i2', $self->{'__FORE'}, $self->{'__BACK'},
		    $self->{'__FONT'} ? $font->NameToNumber ($self->{'__FONT'})
				      : 0,	# System font
		    $self->{'__H'} * 640, $self->{'__W'} * 640,
		    $self->{'__X'}, $self->{'__Y'})
      . $self->{'__TEXT'} . "\0" x (4 - (length ($self->{'__TEXT'}) & 3))
#      . "l$xxx$yyy$XXX$YYYÿÿÿÿB $xxx$YYY$XXX$YYY$XXX$yyy$xxx$yyy$xxx$YYY"
}

sub ForeColour {
    my $self = shift;
    my $old = $self->{'__FORE'};
    # Don't need to be able to pass undef
    $self->{'__FORE'} = pack_colour ($_[0]) if defined $_[0];
    unpack_colour $old;
}

sub BackColour {
    my $self = shift;
    my $old = $self->{'__BACK'};
    # Don't need to be able to pass undef
    $self->{'__BACK'} = pack_colour ($_[0]) if defined $_[0];
    unpack_colour $old;
}

sub Font {
    my $self = shift;
    my $old = $self->{'__FONT'};
    if (@_) {
	$self->{'__FONT'} = defined $_[0] ? $_[0] : '';
	undef $self->{'__BBOX'}
    }
    $old;
}

sub Text {
    my $self = shift;
    my $old = $self->{'__TEXT'};
    if (@_) {
	$self->{'__TEXT'} = $_[0];
	undef $self->{'__BBOX'}
    }
    $old;
}

sub X {
    my $self = shift;
    my $old = $self->{'__X'};
    if (@_) {
	$self->{'__X'} = $_[0];
	undef $self->{'__BBOX'}
    }
    $old;
}

sub Y {
    my $self = shift;
    my $old = $self->{'__Y'};
    if (@_) {
	$self->{'__Y'} = $_[0];
	undef $self->{'__BBOX'}
    }
    $old;
}

sub W {
    my $self = shift;
    my $old = $self->{'__W'};
    if (@_) {
	$self->{'__W'} = defined $_[0] ? $_[0] : $self->{'__H'};
	undef $self->{'__BBOX'}
    }
    $old;
}

sub H {
    my $self = shift;
    my $old = $self->{'__H'};
    if (@_) {
	$self->{'__H'} = defined $_[0] ? $_[0] : $self->{'__W'};
	undef $self->{'__BBOX'}
    }
    $old;
}

sub Kern {
    my $self = shift;
    my $old = $self->{'__FONTFLAG'};
    $old = 0 unless defined $old;
    if (@_) {
	$self->{'__FONTFLAG'} = ($old & 0xFFFFFFFE) | ($_[0] ? 1 : 0);
	undef $self->{'__BBOX'}
    }
    $old & 1;
}
1;
__END__

=head1 NAME

RISCOS::Drawfile

=head1 SYNOPSIS

=head1 DESCRIPTION

=head1 BUGS

=head1 AUTHOR

Nicholas Clark <F<nick@unfortu.net>>
