The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.
#!/usr/bin/perl -w
# -*- perl -*-

#
# Author: Slaven Rezic
#

use strict;
use FindBin;
use lib "$FindBin::RealBin";

use Tk;
use Tk::DateEntry;
use TkTest qw(catch_grabs);

BEGIN {
    if (!eval q{
	use Test::More;
	1;
    }) {
	print "1..0 # skip: no Test::More module\n";
	exit;
    }
}

my $mw = eval { MainWindow->new };
if (!$mw) {
    print "1..0 # skip: cannot create MainWindow: $@";
    exit;
}
$mw->geometry('+1+1');

plan tests => 5;

my $date;
my $de = $mw->DateEntry(-dateformat => 4,
			-textvariable => \$date,
			-todaybackground => "green",
		       )->pack;

$mw->update; $mw->after(200);
# The used members are internals, do not use in regular programs!
$mw->after(1200, sub {
	       $de->{_daybutton}->[2]->[3]->invoke;
	   });
catch_grabs {
    $de->buttonDown;
    $mw->update;
    # This blocks until a date is clicked
    my $iso_date_qr = qr/^(\d{4})-(\d{2})-(\d{2})$/;
    like($date, $iso_date_qr, "Got ISO date");

    my($y,$m,$d) = $date =~ $iso_date_qr;
    $y+=0; # make numeric
    $m+=0;
    $d+=0;
    my(undef,undef,undef,undef,$this_month,$this_year) = localtime; $this_month++; $this_year+=1900;
    is($y, $this_year, "Expected year $this_year");
    is($m, $this_month, "Expected month $this_month");
    cmp_ok($d, ">=", 1, "Day in expected range, min");
    cmp_ok($d, "<=", 31, "Day in expected range, max");
} 5;

__END__