File Coverage

blib/lib/Astro/App/Satpass2/FormatTime/DateTime.pm

Criterion	Covered	Total	%
statement	18	20	90.0
branch			n/a
condition			n/a
subroutine	7	7	100.0
pod			n/a
total	25	27	92.5

package Astro::App::Satpass2::FormatTime::DateTime;

use 5.008;

use strict;
use warnings;

use parent qw{
    Astro::App::Satpass2::FormatTime
};

use Astro::App::Satpass2::Utils qw{
    back_end __back_end_class_name_of_record
    has_method load_package
    __parse_class_and_args
    @CARP_NOT
};
use Astro::App::Satpass2::Locale qw{ __preferred };
use DateTime;
use DateTime::TimeZone;

our $VERSION = '0.051';

sub attribute_names {
    my ( $self ) = @_;
    return ( qw{ back_end }, $self->SUPER::attribute_names() );
}

sub _dt_class_and_args {
    my ( $self ) = @_;
    if ( $self->{_back_end} ) {
	return (
	    $self->{_back_end}{class},
	    $self->{_back_end}{arg},
	);
    } else {
	return ( 'DateTime', [] );
    }
}

sub class_name_of_record {
    my ( $self ) = @_;
    return $self->__back_end_class_name_of_record(
	$self->SUPER::class_name_of_record() );
}

sub format_datetime {
    my ( $self, $tplt, $time, $gmt ) = @_;
    $time = $self->__round_time_value( $time );
    if ( has_method( $time, $self->METHOD_USED() ) ) {
	return $self->__format_datetime( $time, $tplt );
    } else {
	ref $time
	    and $self->wail( 'Unsupported time specification' );
	my ( $class, $dt_arg ) = $self->_dt_class_and_args();
	my $dt = $class->from_epoch(
	    epoch	=> $time,
	    time_zone	=> $self->_get_zone( $gmt ),
	    locale	=> scalar __preferred(),
	    @{ $dt_arg },
	);
	return $self->__format_datetime( $dt, $tplt );
    }
}

sub init {
    my ( $self, %arg ) = @_;
    exists $arg{back_end}
	or $arg{back_end} = undef;
    return $self->SUPER::init( %arg );
}

{

    my $zone_gmt;
    my $zone_local;

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

	if ( @args ) {
	    my $zone = $args[0];
	    if ( defined $zone and $zone ne '' ) {
		if ( ! DateTime::TimeZone->is_valid_name( $zone ) ) {
		    my $zed = uc $zone;
		    DateTime::TimeZone->is_valid_name( $zed )
			or $self->wail(
			    "'$zone' is not a valid time zone name" );
		    $zone = $zed;
		}
		$self->{_tz_obj} = DateTime::TimeZone->new(
		    name => $zone );
	    } else {
		$self->{_tz_obj} = $zone_local ||=
		    DateTime::TimeZone->new( name => 'local' );
	    }
	    return $self->SUPER::tz( $zone );

	} else {
	    return $self->SUPER::tz();
	}
    }

    sub _get_zone {
	my ( $self, $gmt ) = @_;
	defined $gmt
	    or $gmt = $self->gmt();

	$gmt and return ( $zone_gmt ||= DateTime::TimeZone->new(
	    name => 'UTC' ) );

	$self->{_tz_obj} and return $self->{_tz_obj};

	my $tz = $self->tz();
	if ( defined $tz && $tz ne '' ) {
	    return ( $self->{_tz_obj} = DateTime::TimeZone->new(
		    name => $tz ) );
	} else {
	    return ( $self->{_tz_obj} = $zone_local ||=
		DateTime::TimeZone->new( name => 'local' ) );
	}

    }

}

sub __format_datetime_width_adjust_object {
    my ( $self, $obj, $name, $val, $gmt ) = @_;

    if ( $obj ) {
	$obj->set( $name => $val );
    } else {
	my ( $class, $dt_arg ) = $self->_dt_class_and_args();
	$obj = $class->new(
	    time_zone	=> $self->_get_zone( $gmt ),
	    locale	=> scalar __preferred(),
	    $name	=> $val,
	    ( 'year' eq $name ? () : ( year	=> 2020 ) ),
	    @{ $dt_arg },
	);
    }

    return $obj;
}

# my $mod_fmt = $self->__preprocess_strftime_format( $dt_obj, $fmt )
# Preprocess out all the extensions to the strftime format.
# What we're handling here is things of the form %{name:modifiers},
# where the colon and modifiers are optional.
# The modifier is a series of single-character flags followed by a field
# width. The flags are:
#  '-' - left-justify
#  '0' - zero-pad (ineffective if '-' specified)
#  't' - truncate to field width
sub __preprocess_strftime_format {
    my ( $self, $dt_obj, $fmt ) = @_;
    caller->isa( __PACKAGE__ )
	or $self->weep(
	'__preprocess_strftime_format() is private to Astro-App-Satpass2' );
    $fmt =~ s< ( % [{] ( \w+ | % ) (?: : ( [-0t]* ) ( [0-9]+ ) )? [}] ) >
	< _expand_strftime_format( $dt_obj, $1, $2, $3, $4 ) >smxge;
    return $fmt;
}

use constant CALENDAR_GREGORIAN	=> 'Gregorian';
use constant CALENDAR_JULIAN	=> 'Julian';

{
    my %special = (
	'%'		=> sub { return '%' },
	calendar_name	=> sub {
	    my ( $dt_obj ) = @_;
	    my $code;
	    $code = $dt_obj->can( 'calendar_name' )
		and return $code->( $dt_obj );
	    $code = $dt_obj->can( 'is_julian' )
		and return $code->( $dt_obj ) ?
		    CALENDAR_JULIAN :
		    CALENDAR_GREGORIAN;
	    ( ref $dt_obj ) =~ m/ \A DateTime:: (?: \w+ :: )* ( \w+ ) \z /smx
		and return "$1";
	    return CALENDAR_GREGORIAN;
	},
    );

    sub _expand_strftime_format {
	my ( $dt_obj, $all, $name, $flags, $width ) = @_;
	my $code = $special{$name} || $dt_obj->can( $name )
	    or return $all;
	my $rslt = $code->( $dt_obj );
	my %flg = map { $_ => 1 } split qr{}, defined $flags ? $flags : '';
	if ( $width ) {
	    my $tplt = '%';
	    foreach my $f ( qw{ - 0 } ) {
		$flg{$f}
		    and $tplt .= $f;
	    }
	    $tplt .= '*s';
	    $rslt = sprintf $tplt, $width, $rslt;
	    $flg{t}
		and length $rslt > $width
		and substr $rslt, $width, length $rslt, '';
	}
	return $rslt;
    }
}

sub __back_end_default {
    my ( undef, $cls ) = @_;		# Invocant ($self) unused
    return defined $cls ? $cls : 'DateTime';
}

sub __back_end_validate {
    my ( undef, $cls, @arg ) = @_;	# Invocant ($self) unused
    $cls->now( @arg );
    return;
}

1;

__END__