File Coverage

lib/SIRTX/Datecode.pm

Criterion	Covered	Total	%
statement	97	190	51.0
branch	60	136	44.1
condition	13	32	40.6
subroutine	12	25	48.0
pod	17	17	100.0
total	199	400	49.7

# Copyright (c) 2023-2026 Philipp Schafft

# licensed under Artistic License 2.0 (see LICENSE file)

# ABSTRACT: module for interacting with SIRTX Datecodes


package SIRTX::Datecode;

use v5.16;
use strict;
use warnings;

use Carp;

use Data::Identifier;

use parent qw(Data::Identifier::Interface::Userdata Data::Identifier::Interface::Simple Data::Identifier::Interface::Subobjects);

our $VERSION = v0.07;


sub new {
    my ($pkg, $type, $data, %opts) = @_;
    my $code;
    my $iso;

    croak 'Type or data not given' unless defined($type) && defined($data);

    if ($type eq 'from') {
        if (eval {$data->isa('SIRTX::Datecode')}) {
            $data = $data->datecode;
            $type = 'datecode';
        } elsif (eval {$data->isa('Data::Identifier') && $data->generator->eq('97b7f241-e1c5-4f02-ae3c-8e31e501e1dc')}) {
            $data = $data->request;
            $type = 'iso8601';
        } elsif (eval {$data->isa('DateTime')}) {
            if ($data->time_zone->isa('DateTime::TimeZone::Floating')) {
                $data = $data->ymd;
                $type = 'iso8601';
            } else {
                $data = $data->epoch;
                $type = 'epoch';
            }
        } elsif (eval {$data->can('epoch')}) {
            $data = $data->epoch;
            $type = 'epoch';
        } elsif ($data =~ /^[12][0-9]{3}(?:-[0-9]{2}(?:-[0-9]{2})?)?Z?$/) {
            $type = 'iso8601';
        } elsif ($data eq 'now') {
            $data = time();
            $type = 'epoch';
        } elsif ($data eq 'null') {
            $data = 0;
            $type = 'datecode';
        } else {
            croak 'Invalid data: '.$data;
        }
    }

    if ($type eq 'datecode' && $data =~ /^(0|[1-9][0-9]*)$/) {
        $code = int $data;
    } elsif ($type eq 'epoch' && $data =~ /^-?(0|[1-9][0-9]*)$/) {
        my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(int($data));
        $iso = sprintf('%04u-%02u-%02uZ', $year + 1900, $mon, $mday);
    } elsif ($type eq 'iso8601' && $data =~ /^[12][0-9]{3}(?:-[0-9]{2}(?:-[0-9]{2})?)?Z?$/) {
        $iso = $data;
    } else {
        croak 'Invalid type/data: '.$type;
    }

    croak 'Stray options passed' if scalar keys %opts;

    $code //= $pkg->_build_from_iso($iso);

    croak 'Invalid datecode value' if $code == 1;

    return bless({datecode => $code}, $pkg);
}


sub null {
    my ($pkg, @opts) = @_;

    croak 'Stray options passed' if scalar @opts;

    return state $null = __PACKAGE__->new(from => 'null');
}


sub now {
    my ($pkg, @opts) = @_;

    return $pkg->new(from => 'now', @opts);
}


sub datecode {
    my ($self, @opts) = @_;

    croak 'Stray options passed' if scalar @opts;

    return $self->{datecode};
}


sub iso8601 {
    my ($self, @opts) = @_;
    my $code = $self->{datecode};
    my ($year, $month, $day);
    my $utc;
    my $iso;

    croak 'Stray options passed' if scalar @opts;

    return $self->{iso8601} if defined $self->{iso8601};

    $utc = $code & 1;
    $code >>= 1;

    if ($code == 0) {
        return undef;
    } elsif ($code < 324) {
        $year = 1582 + $code - 1;
    } elsif ($code < 1299) {
        $code -= 324;
        $year  = int($code / 13) + 1905;
        $month =     $code % 13;
    } elsif ($code < 31714) {
        $code -= 1299;
        $year  = int($code / 385) + 1980;
        $code  =     $code % 385;
        if ($code) {
            $code -= 1;
            $month = int($code / 32) + 1;
            $day   =     $code % 32;
        }
    } elsif ($code < 32442) {
        $code -= 31714;
        $year  = int($code / 13) + 2059;
        $month =     $code % 13;
    } else {
        $year = 2114 + $code - 32441;
    }

    if ($year) {
        $self->{year} = $year;
        $iso  = sprintf('%04u', $year);

        if ($month) {
            $self->{month} = $month;
            $iso .= sprintf('-%02u', $month);
            if ($day) {
                $self->{day} = $day;
                $iso .= sprintf('-%02u', $day);
            }
        }

        $iso .= 'Z' if $utc;
    }

    return $self->{iso8601} = $iso;
}


sub as {
    my ($self, $as, %opts) = @_;

    croak 'No as given' unless defined $as;

    return $self if $as eq 'SIRTX::Datecode';

    croak 'Not supported: This is a null value' if     $self->is_null;

    if ($as eq 'DateTime') {
        my $year  = $self->year;
        my $month = $self->month;
        my $day   = $self->day;

        require DateTime;

        return DateTime->new(year => $year, month => $month, day => $day, ($self->is_utc ? (time_zone => 'UTC') : ()));
    }

    croak 'Not supported: This is not in UTC'   unless $self->is_utc;

    unless (defined $self->{'Data::Identifier'}) {
        require Data::Identifier::Generate;
        $self->{'Data::Identifier'} = Data::Identifier::Generate->date($self->iso8601);
    }

    return $self->{'Data::Identifier'} if $as eq 'Data::Identifier' && scalar(keys %opts) == 0;

    return $self->{'Data::Identifier'}->as($as, %opts);
}


sub eq {
    my ($self, $other, @opts) = @_;

    croak 'Stray options passed' if scalar @opts;

    foreach my $dc ($self, $other) {
        if (!defined($dc)) {
            $dc = __PACKAGE__->null;
        } elsif (!eval {$dc->isa(__PACKAGE__)}) {
            $dc = __PACKAGE__->new(from => $dc);
        }
    }

    return $self->datecode == $other->datecode;
}


sub cmp {
    my ($self, $other, @opts) = @_;

    croak 'Stray options passed' if scalar @opts;

    foreach my $dc ($self, $other) {
        if (!defined($dc)) {
            $dc = __PACKAGE__->null;
        } elsif (!eval {$dc->isa(__PACKAGE__)}) {
            $dc = __PACKAGE__->new(from => $dc);
        }
    }

    return $self->datecode <=> $other->datecode;
}


sub is_utc {
    my ($self, @opts) = @_;

    croak 'Stray options passed' if scalar @opts;

    return $self->{datecode} & 1;
}


sub is_floating {
    my ($self, @opts) = @_;
    return !$self->is_utc(@opts);
}


sub is_null {
    my ($self, @opts) = @_;

    croak 'Stray options passed' if scalar @opts;

    return $self->{datecode} == 0;
}


sub assert_16bit {
    my ($self, @opts) = @_;

    croak 'Stray options passed' if scalar @opts;

    unless ($self->{datecode} >= 0 && $self->{datecode} <= 0xFFFF) {
        croak 'Datecode is outside of 16 bit range';
    }

    return $self;
}


sub precision {
    my ($self, @opts) = @_;
    my $iso_len = length($self->iso8601 // '');

    croak 'Stray options passed' if scalar @opts;

    if ($iso_len <= 1) {
        return 'null';
    } elsif ($iso_len <= 5) {
        return 'year';
    } elsif ($iso_len <= 8) {
        return 'month';
    } elsif ($iso_len <= 11) {
        return 'day';
    }

    croak 'Invalid object state';
}


sub year {
    my ($self, @args) = @_;
    return $self->_get_part('year', @args);
}

sub month {
    my ($self, @args) = @_;
    return $self->_get_part('month', @args);
}

sub day {
    my ($self, @args) = @_;
    return $self->_get_part('day', @args);
}

# ---- Implementation of Data::Identifier::Interface::Simple ----

sub displayname {
    my ($self, $part, %opts) = @_;

    # compatibility
    delete $opts{default};
    delete $opts{no_defaults};

    croak 'Stray options passed' if scalar keys %opts;

    return $self->iso8601;
}

# ---- Private helpers ----

sub _build_from_iso {
    my ($pkg, $iso) = @_;
    my ($year, $month, $day, $utc) = $iso =~ /^([12][0-9]{3})(?:-([0-9]{2})(?:-([0-9]{2}))?)?(Z?)$/;
    my $code;

    $year   = int $year;
    $month  = defined($month) && length($month) ? int($month) : 0;
    $day    = defined($day)   && length($day)   ? int($day)   : 0;

    $day    = 0 unless $month;

    if ($year < 1582) {
        return undef;
    } elsif ($year >= 1582 && $year <= 1904) {
        $code = $year - 1582 + 1;
    } elsif ($year <= 1979) {
        $code = 324 + ($year - 1905) * 13 + $month;
    } elsif ($year <= 2058) {
        $code = 1299 + ($year - 1980) * 385 + ($month ? 1 + ($month - 1) * 32 : 0) + $day;
    } elsif ($year <= 2114) {
        $code = 31714 + ($year - 2059) * 13 + $month;
    } else {
        $code = 32441 + $year - 2114;
    }

    if (defined $code) {
        $code *= 2;
        $code |= $utc ? 1 : 0;
    }

    return $code;
}

sub _get_part {
    my ($self, $part, %opts) = @_;
    my $has_default = exists $opts{default};
    my $default     = delete $opts{default};

    delete $opts{no_defaults}; # compatibility

    croak 'Stray options passed' if scalar keys %opts;

    $self->iso8601; # fill cache

    return $self->{$part} if defined $self->{$part};

    return $default if $has_default;

    croak 'Value not available: '.$part;
}

1;

__END__