# Copyright (c) 2025 Löwenfelsen UG (haftungsbeschränkt)

# 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);

our $VERSION = v0.01;


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

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

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

    if ($type eq 'datecode' && $data =~ /^(0|[1-9][0-9]*)$/) {
        my $code = int $data;
        return bless(\$code, $pkg);
    } 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;

    return $pkg->_build_from_iso($iso);
}


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

    croak 'Stray options passed' if scalar @opts;

    return ${$self};
}


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

    croak 'Stray options passed' if scalar @opts;

    $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) {
        $iso  = sprintf('%04u', $year);

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

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

    return $iso;
}

# ---- 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 : 0) + ($month - 1) * 32 + $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 bless(\$code, $pkg);
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

SIRTX::Datecode - module for interacting with SIRTX Datecodes

=head1 VERSION

version v0.01

=head1 SYNOPSIS

    use SIRTX::Datecode;

This module provides support to convert between different date formats and SIRTX datecodes.
SIRTX datecodes allow to encode dates in the range of years 1582 to 2440 into just 16 bits
by using a variable precision. They also allow for numeric ordering over their full range.

This package inherits from L<Data::Identifier::Interface::Userdata>.

=head1 METHODS

=head2 new

    my SIRTX::Datecode $dc = SIRTX::Datecode->new($type => $value [, %opts ]);

Creates a new datecode object using C<$type> and C<$value>.

The following types are defined:

=over

=item C<iso8601>

An ISO-8601 date string (C<YYYY-MM-DD>, C<YYYY-MM>, or C<YYYY>, all optionally suffixed with C<Z>).

=item C<datecode>

A datecode value (as integer).

=back

The special value C<from> is also supported as C<$type>.
If C<from> is used an object can be passed that is automatically converted.
In addition if the value is not reference (object) it is tried to be parsed as per C<iso8601>.
The special value C<now> can be used to create an object for the current time.

Currently no options are defined.

=head2 datecode

    my $datecode = $dc->datecode;

Returns the datecode as an integer date code.

=head2 iso8601

    my $iso8601 = $dc->iso8601;

Returns the datecode as an ISO-8601 date string.

=head1 AUTHOR

Löwenfelsen UG (haftungsbeschränkt) <support@loewenfelsen.net>

=head1 COPYRIGHT AND LICENSE

This software is Copyright (c) 2025 by Löwenfelsen UG (haftungsbeschränkt) <support@loewenfelsen.net>.

This is free software, licensed under:

  The Artistic License 2.0 (GPL Compatible)

=cut
