Tk::DateEntry - Drop down calendar widget for selecting dates.

    $dateentry = $parent->DateEntry (<options>);

	$parent->DateEntry->pack;

	$parent->DateEntry(-daynames=>'locale')->pack;

	use POSIX qw/strftime/;
	my @daynames=();
	foreach (0..6) {
		push @daynames,strftime("%a",0,0,0,1,1,1,$_);
	}
	$parent->DateEntry(-daynames=>\@daynames)->pack;

	my $dateentry=$parent->DateEntry
		(-weekstart=>1,
		 -daynames=>[qw/Son Man Tir Ons Tor Fre Lor/],
		 -parsecmd=>sub {
			my ($d,$m,$y) = ($_[0] =~ m/(\d*)\/(\d*)-(\d*)/);
			return ($y,$m,$d);
		 },
		 -formatcmd=>sub {
			sprintf ("%d/%d-%d",$_[2],$_[1],$_[0]);
		 }
		)->pack;

#
# DateEntry lets the user select a date from a drop-down calendar.
#
# See end of this file for documentation.
#
package Tk::DateEntry;

use vars qw($VERSION $DEBUG);

$VERSION = '1.39';

use Tk;
use strict;
use Carp;
use Time::Local;
BEGIN { eval 'use POSIX qw(strftime)'; warn $@ if $@ }

my $can_use_dcalc = 0;
if (     eval q{ use Date::Calc qw(Day_of_Week check_date); 1 }) {
    $can_use_dcalc = 1;
} elsif (eval q{ use Date::Pcalc qw(Day_of_Week check_date); 1 }) {
    $can_use_dcalc = 1;
}

require Tk::Frame;

use base qw(Tk::Frame);
Construct Tk::Widget 'DateEntry';

sub ClassInit {
    my($class, $mw) = @_;
    $class->SUPER::ClassInit($mw);
    $mw->bind($class, "<Button-1>" => 'buttonDown');
}

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

    $w->SUPER::Populate($args);

    # entry widget and arrow button
    my $e = $w->Entry;
    my $b = $w->Button(-bitmap => '@' . Tk->findINC("cbxarrow.xbm"));
    my $tl = $w->{_toplevel} = $w->Toplevel(-bd=>2,-relief=>'raised');

    $w->Advertise("entry" => $e);
    $w->Advertise("arrow" => $b);

    $tl->transient($w);
    $tl->overrideredirect(1);
    $tl->OnDestroy(sub { $w->{_status} = 'done' }); # XXX really needed?

    $b->pack(-side => "right", -padx => 0);
    $e->pack(-side => "right", -fill => 'x', -expand => 1, -padx => 0);

    # other initializations
    $b->bind("<Button-1>", [ $w => 'buttonDown' ]);
    $b->bind("<space>", [ $w => 'buttonDown' ]);
    $b->bind("<Key-Return>", [ $w => 'buttonDown' ]);
    $e->bind("<Key-Return>", [ $w => 'buttonDown' ]);
    $e->bind("<Up>",   [$w => 'rotateDay', +1, 1] );
    $e->bind("<Down>", [$w => 'rotateDay', -1, 1] );
    $e->bind("<Shift-Up>",   [$w => 'rotateDay', +1, 7] );
    $e->bind("<Shift-Down>", [$w => 'rotateDay', -1, 7] );
    $e->bind("$_",   [$w => 'rotateMonth', +1] )
	for qw(<Control-Up> <Prior>);
    $e->bind("$_", [$w => 'rotateMonth', -1] )
	for qw(<Control-Down> <Next>);
    $e->bind("<Shift-Control-Up>",   [$w => 'rotateYear', +1] );
    $e->bind("<Shift-Control-Down>", [$w => 'rotateYear', -1] );

    # XXX Not uses anymore due to problems with grab
    #$w->bind("<FocusOut>", sub { $w->popDown });

    # Create the buttons on the dropdown.
    my $fr = $w->{_frame} = $tl->Frame->pack(-anchor=>'n');

    # check whether Tk::FireButton is installed
    my $Button = eval { require Tk::FireButton; 1 } ? 'FireButton' : 'Button';

    # 1. Previous month:
    $w->{_backbutton}=$fr->$Button(-text=>'<<',-pady=>1,-padx=>1,-bd=>1,
				   -command=> ['prevMonth', $w])
	->grid(-row=>0,-column=>0);

    # 2. Label to put the monthname in:
    $w->{_monthlabel} = $fr->Label->grid(-row=>0,-column=>1,-columnspan=>5);

    # 3. Next month:
    $w->{_nextbutton}=$fr->$Button(-text=>'>>',-pady=>1,-padx=>1,-bd=>1,
				   -command=>['nextMonth', $w])
	->grid(-row=>0,-column=>6);

    # 4. Dayname labels:
    for (0..6) {
	$w->{_daylabel}->[$_] = $fr->Label->grid(-column=>$_,-row=>1);
    }

    # 5. Daybuttons. Note that we create button for six weeks, since it
    #    is possible that a month might span over six different weeks.
    #    The text on the buttons are just a dummy to force them to the
    #    correct size. When the calendar is popped up, the right text
    #    is inserted an unused buttons are gridForget'ed.
    for my $week (0..5) {
	for my $wday (0..6) {
	    $w->{_daybutton}->[$week]->[$wday] =
		$fr->Button(-bd=>1, -padx=>1, -pady=>1, -text=>'00',
			    -command => ['selectDay', $w, $week, $wday])
		    ->grid(-row=>$week+2,-column=>$wday,-sticky=>'nsew');
	}
    }
    $tl->withdraw;

    $w->{_popped} = 0;

    $w->Delegates(DEFAULT => $e);

    $w->ConfigSpecs
	(-arrowimage  => [{-image => $b}, qw/arrowImage ArrowImage/],
 	 -variable    => "-textvariable",
         -dateformat  => [qw/PASSIVE dateFormat DateFormat 1/],
	 -background  => [qw/METHOD background Background/],
# XXX should the class for these be Background?
	 -buttonbackground
           	      => [qw/METHOD buttonBackground ButtonBackground/],
	 -boxbackground
                      => [qw/METHOD boxBackground BoxBackground/],
	 -todaybackground
                      => [qw/PASSIVE todayBackground TodayBackground/],
	 -font        => [qw/DESCENDANTS font Font/],
	 -daynames    => [qw/PASSIVE daynames Daynames/,[qw/S M Tu W Th F S/]],
	 -weekstart   => [qw/PASSIVE weekstart Weekstart 0/],
	 -formatcmd   => [qw/CALLBACK formatCmd FormatCmd/,
			  ['defaultFormat',$w]],
	 -parsecmd    => [qw/CALLBACK parseCmd ParseCmd/,
			  ['defaultParse', $w]],
	 -configcmd   => [qw/CALLBACK configCmd ConfigCmd/, undef],
	 -headingfmt  => [qw/PASSIVE headingFmt HeadingFmt/, '%B %Y'],
	 -state       => [qw/METHOD state State normal/],
	 -width       => [$e, undef, undef, 10],
	 DEFAULT      => [$e] );
}

#---------------------------------------------------------------------------
# Configuration methods:
#
# -state works like the BrowseEntry's -state, in addition to 'normal'
# and 'disabled', 'readonly' forces the user to select from the dropdown.
sub state {
    my $w = shift;

    unless (@_) {
        return ($w->{'de_state'});
    } else {
        my $state = $w->{'de_state'} = shift;

	if ($state eq "readonly" ) {
	    $w->Subwidget("entry")->configure( -state => "disabled" );
	    $w->Subwidget("arrow")->configure( -state => "normal" );
	} else {
	    $w->Subwidget("entry")->configure( -state => $state );
	    $w->Subwidget("arrow")->configure( -state => $state );
	}
    }
}

# -background sets the background of the entry and arrow subwidgets.
#
sub background
{
    my $w = shift;

    unless (@_) {
        return ($w->{'de_background'});
    } else {
        my $color = $w->{'de_background'} = shift;

	foreach (qw/entry arrow/) {
	    $w->Subwidget($_)->configure(-background=>$color);
	}
    }
}

# -buttonbackground sets the background on all buttons in the widget.
#
sub buttonbackground
{
    my $w = shift;

    unless (@_) {
        return ($w->{'de_buttonbackground'});
    } else {
        my $color = $w->{'de_buttonbackground'} = shift;

	foreach (qw/_backbutton _nextbutton/) {
	    $w->{$_}->configure('-background'=>$color);
	}
    }
}

sub boxbackground
{
    my $w = shift;

    unless (@_) {
        return ($w->{'de_boxbackground'});
    } else {
        my $color = $w->{'de_boxbackground'} = shift;
	foreach (qw/_frame _toplevel _monthlabel/) {
	    $w->{$_}->configure('-background'=>$color);
	}
	foreach (@{$w->{_daylabel}}) {
	    $_->configure('-background'=>$color);
	}
    }
}

sub configure
{
    my ($w, %args) = @_;

    # Check validity of option values.
    if (defined($args{-weekstart}) &&
	($args{-weekstart} < 0 || $args{-weekstart} > 6))
    {
	carp ("-weekstart must be between 0 and 6");
	delete $args{-weekstart};  # Ignore -weekstart
    }

    if (defined($args{-dateformat}) &&
	($args{-dateformat} < 1 || $args{-dateformat} > 4))
    {
	carp ("-dateformat must be between 1 and 4");
	delete $args{-dateformat};  # Ignore -dateformat
    }


    $w->SUPER::configure(%args);

    if (defined($args{-daynames}) || defined($args{-weekstart})) {
	# Refresh the daynames heading whenever -daynames or -weekstart
	# changes.
	my $daynames;
	if ($args{-daynames} && $args{-daynames} eq 'locale' && defined &strftime) {
	    foreach (0..6) {
		push @$daynames, $w->_decode_posix_bytes(strftime("%a",0,0,0,1,1,1,$_));
	    }
	} else {
	    $daynames = $w->cget('-daynames');
	}
	my $weekstart = $w->cget('-weekstart');

	for (0..6) {
	    my $dayname = $daynames->[($_ + $weekstart)%7];
	    $dayname = $w->_bidify($dayname);
	    $w->{_daylabel}->[$_]->configure
		(-text => $dayname);
	}
    }
}

#---------------------------------------------------------------------------
# Whenever someone pushes the arrow.....

sub buttonDown
{
    my ($w) = @_;
    my $tl = $w->{_toplevel};

    return if $w->cget('-state') eq 'disabled';

    if ($w->{_popped}) {         # If already visible, pop down.
	return $w->popDown;
    }

    # Popup the widget.
    $w->popUp;

    $w->{_oldgrab} = $w->toplevel->grabSave;
    $w->grabGlobal;               # Start processing......

    $w->readContent;             # Tries to read the current content of
                                  # entry, set default if empty.

    $w->{_status} = '';

    my $configcmd = $w->cget('-configcmd');

    my ($today_d,$today_m,$today_y) = (localtime)[3,4,5];
    $today_m++;
    $today_y+=1900;

    while ($w->{_status} ne 'done') {
	# getCalendar returns a two-dimensional array, each row in the
	# array represents a week, each column the days of the week. If
	# an element has a value, the value is the day number of the month.
	#
	my $cal = $w->getCalendar;

	my $monthlabel;
	if (defined &strftime) {
	    $monthlabel = strftime($w->cget('-headingfmt'),0,0,0,1,
				   $w->{_month}-1,$w->{_year}-1900);
	    $monthlabel = $w->_decode_posix_bytes($monthlabel);
	} else {
	    $monthlabel = $w->{_month} . "/" . $w->{_year};
	}
	$monthlabel = $w->_bidify($monthlabel);
	$w->{_monthlabel}->configure(-text=>$monthlabel);

	for my $week (0..5) {
	    for my $wday (0..6) {
		my $button = $w->{_daybutton}->[$week]->[$wday];
		my $mday = $cal->[$week]->[$wday];

		if (defined($mday)) {
		    # Set the buttons text to $mday, call grid() to make
		    # sure the button is displayed.
		    #
		    my $bckg = $w->cget('-buttonbackground') ||
			       ($button->configure('-background'))[3];

		    if ($mday == $today_d &&
			$w->{_month}==$today_m &&
			$w->{_year}==$today_y)
		    {
			# Special background for TODAY.
			$bckg = $w->cget('-todaybackground') ||
			        ($button->configure('-background'))[3];
		    }
		    $button->configure(-text => sprintf ("%2d", $mday),
				       -background => $bckg);
		    $button->grid
			(-column=>$wday,-row=>$week+2,-sticky=>'nsew');
		} else {
		    # This day does not exists in the given month. Remove
		    # the button.
		    #
		    $button->gridForget;
		}

		if ($configcmd) {
		    $configcmd->Call((defined $mday
				      ? (-date => [$mday, $w->{_month}, $w->{_year}])
				      : ()
				     ),
				     -datewidget => $button,
				     -widget => $w,
				    );
		}
	    }
	}

	# Wait for something to happen...
	$w->waitVariable(\$w->{_status});
    }

    $w->popDown;
}

#-------------------------------------------------------------------
# Displays the calendar window.
#
sub popUp
{
    my ($w) = @_;

    my $e = $w->Subwidget("entry");
    my $tl = $w->{_toplevel};
    my ($x, $y);

    # When the dislayed month changes, the number of weeks displayed might
    # change (minimum four, maximum six). To keep the size of the window
    # constant, we'll first put a dummy-button in each row, then "freeze"
    # the window size. This can't be done before now, since configure(-font)
    # might cause the size to change at any time.
    #
    $tl->packPropagate(1);         # Allow resize
    foreach (0..5) {
	$w->{_daybutton}->[$_]->[0]->grid(-column=>0,-row=>($_+2));
    }
    $tl->update;                   # Calculate size, since the window
                                   # is still withdrawn, the user won't see
                                   # anything.
    $tl->packPropagate(0);         # Freeze....


    my ($th,$tw) = ($tl->reqheight, $tl->reqwidth);
    my ($ex,$ey) = ($e->rootx, $e->rooty);
    my ($eh,$ew) = ($e->height, $e->width);
    my ($rh,$rw) = ($w->vrootheight, $w->vrootwidth);

    # Calculate vertical position first.
    # Best position is below the entry widget.
    if ($ey + $eh + $th < $rh) {
	$y = $ey + $eh;
    } else {
	# Above entry.
	$y = $ey - $th;
    }
    if ($y < 1) {
	$y = 1;
    }

    # Horizontal, best position is directly below/above the entry.
    if ($ex + $tw < $rw) {
	$x = $ex;
    } else {
	$x = 1;
    }
    if ($x < 1) {
	$x = 1;
    }
    $tl->geometry(sprintf("+%d+%d",$x,$y));

    $tl->deiconify;
    $tl->raise;

    $w->Subwidget("entry")->focus;
    $w->{_popped} = 1;
}

#----------------------------------------------------------------------
# Reads the current content of the widget and parses it to retrieve the
# year/month/day. Sets default values if something is missing or is
# invalid.
#
sub readContent
{
    my ($w) = @_;
    my $e = $w->Subwidget("entry");

    # Get year/month/day from the entry widget.
    #
    my ($year,$month,$day) = $w->Callback(-parsecmd => $e->get);
    foreach ($year,$month,$day) {
	if (defined $_ && !/^\d+$/) {
	    undef $_;
	}
    }

    # Get todays date...
    my ($today_md, $today_m,$today_y) = (localtime)[3,4,5];
    $today_y+=1900;
    $today_m++;

    unless (defined($month) && $month >= 1 && $month <= 12) {
	$month = $today_m;
    }

    unless (defined($day) && $day >= 1 && $day <= 31) {
	$day = $today_md;
    }


    $year = $today_y unless defined($year);
    if ($year < 100) {
	# One or two digit year. Try to find a reasonable value for
	# century by using a "100 years window".
	my $cc = int($today_y / 100); # Try current century
	my $yyyy = sprintf "%02d%02d", $cc, $year;

	if ($yyyy > ($today_y + 50)) {
	    $yyyy -= 100;  # More than 50 years in the future, must be
	                   # prev. century
	} elsif ($yyyy < ($today_y - 50)) {
	    $yyyy += 100;  # More that 50 years ago, must be next cent.
	}
	$year = $yyyy;
    }
    unless ($year =~ m/^\d+$/) {
	$year = $today_y;
    }

    $w->{_day}   = $day;
    $w->{_month} = $month;
    $w->{_year}  = $year;
}

#--------------------------------------------------------------------
# Default date parse routine. Called unless -parsecmd is specified.
# (rememember to update check in configure() if more dateformats are
# added).
sub defaultParse
{
    my ($w, $str) = @_;

    my ($m,$d,$y);

    $_ = $w->cget('-dateformat');

    $str =~ s/\s//g;

    /^1$/ && (($m,$d,$y) = (split '/', $str));
    /^2$/ && (($y,$m,$d) = (split '/', $str));
    /^3$/ && (($d,$m,$y) = (split '/', $str));
    /^4$/ && (($y,$m,$d) = (split '-', $str));

    return ($y,$m,$d);
}

#--------------------------------------------------------------------
# Default date format routine. Called unless -formatcmd is specified.
# (rememember to update check in configure() if more dateformats are
# added).
sub defaultFormat
{
    my ($w, $y, $m, $d) = @_;

    $_=$w->cget('-dateformat');
    if (/^1$/) {
	sprintf("%02d/%02d/%04d", $m, $d, $y);
    } elsif (/^2$/) {
	sprintf("%04d/%02d/%02d", $y, $m, $d);
    } elsif (/^3$/) {
	sprintf("%02d/%02d/%04d", $d, $m, $y);
    } elsif (/^4$/) {
	sprintf("%04d-%02d-%02d", $y, $m, $d);
    }
}

#-----------------------------------------------------------------------
# Returns a calendar for the month given by $w->{_month} and {_year}.
# The calendar is returned as a 6 * 7 two-dimensional array. Each row in the
# array represents a week, each column a weekday.
#
# EXAMPLE: October 1999 (assume -weekstart => 0):
#
#  undef undef undef undef undef   1     2
#    3     4     5     6     7     8     9
#   10    11    12    13    14    15    16
#   17    18    19    20    21    22    23
#   24    25    26    27    28    29    30
#   31   undef undef undef undef undef undef
#
sub getCalendar
{
    my ($w) = @_;

    if ($can_use_dcalc) {
	return $w->getCalendarDC();
    }

    my $week=0;
    my $cal=[];

    for my $mday (1..31) {
	my ($m,$y,$wday) = eval {
	    local $SIG{'__DIE__'};
	    (localtime(timelocal(0,0,0,
				 $mday,
				 $w->{_month}-1,
				 $w->{_year})))[4..6]
	};
	last if $@;
	$m++;

	$wday = ($wday - $w->cget('-weekstart')) % 7;
	if ($m == $w->{_month}) { # Still the same month?
	    $cal->[$week]->[$wday]=$mday;
	    if ($wday == 6) {
		$week++;
	    }
	}
    }

    return $cal;
}

#--------------------
# The same as getCalendar with Date::Calc
#
sub getCalendarDC
{
    my ($w) = @_;

    my $week=0;
    my $cal=[];
    for my $mday (1..31) {
	if (check_date($w->{_year},$w->{_month},$mday)) {
	    my $wday = Day_of_Week($w->{_year},$w->{_month},$mday);
	    $wday = ($wday - $w->cget('-weekstart')) % 7;
	    $cal->[$week]->[$wday]=$mday;
	    if ($wday == 6) {
		$week++;
	    }
	}
    }
    return $cal;
}

#--------------------
# Hide the window....
#
sub popDown
{
    my ($w) = @_;
    if ($w->{_popped}) {
	$w->{_popped} = 0;
	$w->grabRelease;
	if ($w->{_oldgrab}) {
	    $w->{_oldgrab}->();
	    delete $w->{_oldgrab};
	}
	$w->{_toplevel}->withdraw;
	$w->{_status} = 'done';
    }
}


#------------------
# BUTTON CALLBACKS:
#------------------
#
# Called when a day button is pressed. Sets the entry value, pops down
# the window.
#
sub selectDay
{
    my ($w, $week, $wday) = @_;


    my $e = $w->Subwidget("entry");
    my $mday = $w->{_daybutton}->[$week]->[$wday]->cget('-text');

    if ($w->cget('-state') eq 'readonly') {
	$e->configure('-state'=>'normal');
    }
    $e->delete('0','end');
    $e->insert('end',
	       $w->Callback(-formatcmd=>$w->{_year},$w->{_month}, $mday));

    if ($w->cget('-state') eq 'readonly') {
	$e->configure('-state'=>'disabled');
    }

    $w->popDown;

}

# Increment month number (or year)
sub nextMonth
{
    my ($w) = @_;

    if ($w->{_month} == 12) {
	$w->{_year}++;
	$w->{_month} = 1;
    } else {
	$w->{_month}++;
    }
    $w->{_status} = 'new';
}

# Decrement month number (or year)
sub prevMonth
{
    my ($w) = @_;

    if ($w->{_month} == 1) {
	$w->{_year}--;
	$w->{_month} = 12;
    } else {
	$w->{_month}--;
    }
    $w->{_status} = 'new';
}

# increment or decrement the entry's day
sub rotateDay
{
    my ( $w, $dir, $step ) = @_;

    $w->readContent;
    $w->{_day} += $dir * $step;
    # depend upon timelocal() to fix up days outside of 1..31
    $w->updateDate;
}

sub rotateMonth
{
    my ( $w, $dir ) = @_;

    $w->readContent;

    $dir > 0 ? $w->nextMonth : $w->prevMonth;

    $w->updateDate;
}

sub rotateYear
{
    my ( $w, $dir ) = @_;

    $w->readContent;

    $w->{_year} += $dir;

    $w->updateDate;
}

# make the entry widget track the internal notion of the date
sub updateDate
{
    my ($w) = @_;

    if ($can_use_dcalc) {
	return $w->updateDateDC();
    }

    my ($d,$m,$y) = eval {
	local $SIG{__DIE__} = undef;
	(localtime(timelocal(0,0,0,
			     $w->{_day},
			     $w->{_month}-1,
			     $w->{_year})))[3,4,5];
    };
    unless ( $@ )
	{
	    $m++;
	    $y += 1900;
	    my $e = $w->Subwidget("entry");
	    $e->delete('0','end');
	    $e->insert('end',
		       $w->Callback(-formatcmd=>$y,$m, $d));
	}
}

sub updateDateDC
{
    my ($w) = shift;

    my ($d,$m,$y);
    if (check_date($w->{_year},$w->{_month},$w->{_day})) {
	$y = $w->{_year};
	$m = $w->{_month};
	$d = $w->{_day};
	my $e = $w->Subwidget("entry");
	$e->delete('0','end');
	$e->insert('end',
		   $w->Callback(-formatcmd=>$y,$m, $d));
    }
}

# "Stolen" from Locale::Maketext::Lexicon (called "encoding" there)
# and slightly adapted.
sub _posix_encoding {
    my $w = shift;
    if (exists $w->{_posix_encoding}) {
	return $w->{_posix_encoding};
    }

    local $^W;    # no warnings 'uninitialized', really.
    my ( $country_language, $locale_encoding );

    local $@;
    eval {
        require I18N::Langinfo;
        $locale_encoding =
          I18N::Langinfo::langinfo( I18N::Langinfo::CODESET() );
      }
      or eval {
        require Win32::OLE::NLS;
	my $lcid = Win32::OLE::NLS::GetSystemDefaultLCID();
        $locale_encoding = Win32::OLE::NLS::GetLocaleInfo($lcid, Win32::OLE::NLS::LOCALE_IDEFAULTANSICODEPAGE()); # XXX this is unchecked!
	$locale_encoding = 'cp' . $locale_encoding if $locale_encoding;
      };
    if ( !$locale_encoding ) {
        foreach my $key (qw( LANGUAGE LC_ALL LC_MESSAGES LANG )) {
            $ENV{$key} =~ /^([^.]+)\.([^.:]+)/ or next;
            ( $country_language, $locale_encoding ) = ( $1, $2 );
            last;
        }
    }
    if (   defined $locale_encoding
        && lc($locale_encoding) eq 'euc'
        && defined $country_language )
    {
        if ( $country_language =~ /^ja_JP|japan(?:ese)?$/i ) {
            $locale_encoding = 'euc-jp';
        }
        elsif ( $country_language =~ /^ko_KR|korean?$/i ) {
            $locale_encoding = 'euc-kr';
        }
        elsif ( $country_language =~ /^zh_CN|chin(?:a|ese)?$/i ) {
            $locale_encoding = 'euc-cn';
        }
        elsif ( $country_language =~ /^zh_TW|taiwan(?:ese)?$/i ) {
            $locale_encoding = 'euc-tw';
        }
    }

    $w->{_posix_encoding} = $locale_encoding;
}

sub _decode_posix_bytes {
    my($w, $string) = @_;
    my $codeset = $w->_posix_encoding;
    if ($codeset) {
	eval {
	    require Encode;
	    $string = Encode::decode($codeset, $string);
	};
	warn "Cannot decode string '$string' in codeset '$codeset': $@" if $@;
    }
    $string;
}

sub _bidify {
    my(undef, $string) = @_;
    return if !defined $string;
    eval {
	if ($string =~ m{[\p{BidiClass:R}\p{BidiClass:AL}\p{BidiClass:RLE}\p{BidiClass:RLO}]}) {
	    require Text::Bidi;
	    $string = Text::Bidi::log2vis($string);
	}
    };
    warn "Cannot align right-to-left text. $@" if $@ && $DEBUG;
    $string;
}

1;

__END__