package ATR::Tk::BarcodeImage;

use strict;
use Tk::Derived;

use File::Temp;
use Barcode::Code128 'FNC1';
use GD 2.00; # don't need to import it, but 1.33 doesn't have copyRotate90
use Tk::Photo;

use Tk::Balloon;

our @ISA = qw(Tk::Derived Tk::Canvas);
Tk::Widget->Construct('BarcodeImage');


sub Populate {
    my ($self, $args) = @_;

    $self->SUPER::Populate($args);
# $self->ConfigSpecs();

    my $msg = "message here";
    $self->privateData->{balloon_msg} = \$msg;

    $self->barcode(undef, undef);
    $self->resize( length => delete $args->{-length} || 368,
		   width  => delete $args->{-width}  || 56,
		   border => delete $args->{-border} || 8,
		 );

    my $b = delete $args->{-balloon};
    $b->attach($self, -msg => \$msg) if $b;
}

sub _setup {
    my $self = shift;
    my %size = $self->size;

    $self->configure(-height => $size{length}, -width => $size{width});

# Vertical orientation only...
    $self->delete('backg');
    $self->createRectangle(0,0, $size{width}, $size{length},
			   -tag => 'backg',
			   -outline => undef,
			   -fill => 'black');

    $self->createRectangle($size{border}, $size{border},
			   $size{width}-$size{border}, $size{length}-$size{border},
			   -tag => 'backg',
			   -outline => undef,
			   -fill => 'white',
			  );

    # Regenerate current barcode at new size?
    $self->barcode(@{ $self->privateData->{barcode} });
}

# Return hash-pairs for (length, width, border), values in canvas pixels
sub size {%{ $_[0]->privateData->{sizes} }}

sub resize { # XXX: nb. No protection against putting too many bars in a small space
    my ($self, %pairs) = @_;
    my $S = $self->privateData->{sizes} ||= {};
    while (my ($k, $v) = each %pairs) {
	$S->{$k} = $v;
    }
    $self->_setup;
}

sub renderOnCanvas {
    my ($self, $dest, $x1, $y1, $x2, $y2) = @_;
    # we ignore (x2, y2) .. doesn't re-scale the content

    foreach my $item ($self->find('all')) {
	# All items, stacking order from the bottom
	my $type = $self->type($item);
	my @coords = $self->coords($item);
	my @config = $self->itemconfigure($item);

	for (my $i=0; $i<@coords; $i++) {
	    $coords[$i] += ($i % 2 ? $y1 : $x1);
	}
	@config = map {( $_->[0], $_->[4] )} @config;
	$dest->create($type, @coords, @config);
    }

    return 0; # don't recurse
}

=head2 barcode($barcode_number, $barcode_prefix)

Set the barcode image displayed in the label; will not regenerate the
image if it is already correct.

If called with a pair of C<undef>s, clears the barcode.

If called with no args, returns current barcode number or undef (in
scalar context); or C<($num, $pfx)> or empty list (in list context).

Errors a valid barcode can't be made.

=cut

sub barcode {
    my $self = shift;
    my $old_list = $self->privateData->{barcode};

    if (@_ == 0) {
	return () if !defined $old_list;
	return @$old_list;

    } elsif (@_ != 2) {
	die "Need two args for setting barcode";

    }
    # else...

    my ($bc_num, $bc_pfx) = @_;

    if (!defined $bc_num && !defined $bc_pfx) {
	# Want to clear the barcode
	$self->delete('bars');
	delete $self->privateData->{barcode};
	$self->_message("[barcode not yet allocated]");
	return;
    }

    # Set barcode
    $self->privateData->{barcode} = [ $bc_num, $bc_pfx ];
    my $bc_str = ATR::MicePE::Card->getBarcodeString($bc_pfx, $bc_num); # XXX: this is an abuse (as is the facility to pass the args), the string should be given us by the caller

    # Checksum letter goes into the barcode.
    #
    # This is not how EAN13 works, but that comes out as a
    # sequence of numbers and is converted.  This will return a
    # text string directly - appending the check letter will work
    # with any current software that allows manual barcode input.

    $self->delete('bars');
    my $code = $self->_barcode_image($bc_str); # "  ## #  ##"...

    my $pad = "." x 10; # 6 is not enough (barcode illegible),
                        # 10 seems to match the GD drawing code

    $code = $pad.$code.$pad;
    my $bars = length($code);

    my %size = $self->size;
    my $barLen = ($size{length} - 2*$size{border}) / $bars;

    my $width = 0; # width of current stripe
    for (my $i=0; $code ne ''; $i += $width) {
	# Get the first bar: color and width
	my ($chr) = substr($code, 0, 1);
	$width = 0;
	while ($width < length($code) && substr($code, $width, 1) eq $chr) {
	    $width ++;
	}
	substr($code, 0, $width, ""); # remove it

	# Draw canvas item
	next if $chr eq '.'; # end-padding
	my ($start, $end) = map { $size{border} +  $_ * $barLen } ($i, $i+$width);
	$self->createRectangle($size{border}, $start,
			       $size{width}-$size{border}, $end,
			       -tag => 'bars',
			       -outline => undef,
			       -fill => ($chr eq ' ' ? 'white' : 'black'),
			      )
    }

    $self->_message($bc_str);
}


sub _message {
    my ($self, $new_message) = @_;
    ${ $self->privateData->{balloon_msg} } = $new_message;
}


sub _barcode_image {
    my ($widg, $data) = @_;

    my $bc = Barcode::Code128->new();
    $bc->option(  show_text => 0 ); # don't display text under the barcode,
    # it may confuse people because it looks too much like a mating number.
    # The card can be identified by other human friendly large letters

    my $str = $bc->barcode($data); # string /^[ #]+$/ for light & dark stripes

    undef $bc;
    # Barcode::Code128 v2.00 thinks DESTROY is an invalid
    # configuration option, and therefore croaks in its own
    # destructor.  Null implementation provided below.

    return $str;
}

# Trickery to fix croaking noise, see above
BEGIN {
    no strict 'refs';
    die "About to replace Barcode::Code128::DESTROY - ok in v2.00 but this is $Barcode::Code128::VERSION"
      if *{"Barcode::Code128::DESTROY"}{CODE};
}
sub Barcode::Code128::DESTROY { }

1;
