#!/usr/bin/perl -w

#
# Fsdb::Support::IPv6.pm
# Copyright (C) 2021-2025 by John Heidemann <johnh@isi.edu>
#
# This program is distributed under terms of the GNU general
# public license, version 2.  See the file COPYING
# in $dblib for details.
#

package Fsdb::Support::IPv6;

=head1 NAME

Fsdb::Support::IPv6 - ipv6-parsing helpers

=head1 SYNOPSIS

    use Fsdb::Support::IPv6;

=cut
#'


=head2 ipv6_zeroize

    $ipv6_zeroized = Fsdb::Support::IPv6::ipv6_zeroize('1:0002:3:4::');
    # result is 1:2:3:4:0:0:0:0

Normalize an IPv6 address so it has all hextets present,
with no leading zeros.

Handles any valid IPv6 address as input.

Also treats strings of hex digits without colons as IPv6 prefixes.

=cut
sub ipv6_zeroize {
    my ($s) = @_;
    if ($s !~ /:/) {
        # no :, so it must be a hex string
        # first, make it 32 bytes
        if (length($s) < 32) {
            $s = $s . "0" x (32 - length($s));
        };
        return undef if (length($s) > 32);
        # insert colons (that we will then take out below :-( )
        $s =~ s/(....)/$1:/g;
        $s =~ s/:$//;
    }
    # handle embeded IPv4
    if ($s =~ /^(.*:)(\d+)\.(\d+)\.(\d+)\.(\d+)$/) {
        $s = $1 . sprintf("%02x%02x:%02x%02x", $2, $3, $4, $5);
    };
#    if ($s !~ /::/) {
#        return $s;
#    };
    my(@double_colon_parts) = split(/::/, $s);
    return undef if ($#double_colon_parts > 1);  # multiple :: !
    my(@hextets) = split(/:/, $s);
    if ($#hextets < 7) {
        my(@full) = ();
        my($found) = undef;
        foreach (@hextets) {
            if ($_ eq '') {
                if ($found) {
                    # ::1 will return the list('', '', '1')
                    push(@full, '0');
                } else {
                    push(@full, ('0') x (8 - $#hextets));
                    $found = 1;
                };
            } elsif ($_ ne '') {
                s/^0+//g;
                $_ = '0' if ($_ eq '');   # put back singleton zero
                push (@full, $_);
            };
        };
        # 1:: returns the list ('1')
        push (@full, ('0') x (7 - $#hextets)) if (!$found);
        return join(':', @full);
    } elsif ($#hextets == 7) {
        my(@full) = ();
        foreach (@hextets) {
            s/^0+//g;
            $_ = '0' if ($_ eq '');   # put back singleton zero
            push (@full, $_);
        };
        return join(':', @full);
    } else {
        return undef;
    };                 
};

=head2 ipv6_fullhex

    $ipv6_fullhex = Fsdb::Support::IPv6::ipv6_fullhex('1:0002:3:4::');
    # result is 0001000200030004000000000000000

Rewrite an IPv6 address as a full, 128-bit, base-16 number.

=cut
sub ipv6_fullhex {
    my ($s) = ipv6_zeroize($_[0]);
    my($r) = '';
    my(@parts) = split(/:/, $s);
    return join('', map { length($_) >= 4 ? $_ : ('0' x (4 - length($_)) . $_) } @parts);
};


=head2 ipv6_normalize

    $ipv6_normal = Fsdb::Support::IPv6::ipv6_normalize('1:0002::7:0:00:8');
    # result is 1:2::7:0:0:8

Convert an IPv6 address to IETF normal form.
The input maybe has some fields 0 or leading zero,
or :: in a non-standard place.
Normalize it to remove leading zeros and replace the leftmost,
longest run of zeros with ::.

We remove any mixed IPv4/v6 addresses (IPv6 addreses that end in dotted-quads).

Also treats strings of hex digits without colons as IPv6 prefixes.

=cut
sub ipv6_normalize {
    my ($s) = @_;
    $s = ipv6_zeroize($s) if ($s =~ /::/ || $s !~ /:/);   # expand :: or hex-only
    # we must have all fields, but maybe have leading zeros and runs of zeros
    my(@hextets) = split(/:/, $s);
    return undef if ($#hextets != 7);
    my(@trimmed_hextets) = ();
    my(@zero_run);
    my($max_zero_run) = 0;
    foreach (@hextets) {
        s/^0//g;
        $_ = '0' if ($_ eq '');   # put back singleton zero
        push(@trimmed_hextets, $_);
        my($cur_zero_run) = ($_ ne '0' ? 0 : ($#zero_run == -1 ? 1 : $zero_run[$#zero_run] + 1));
        push(@zero_run, $cur_zero_run);
        $max_zero_run = $cur_zero_run if ($cur_zero_run > $max_zero_run);
    };
    # kill leftmost zero run, if any
    return join(':', @trimmed_hextets) if ($max_zero_run == 0);
    my (@zero_runned_hextets) = ();
    my $cur_zero_run = undef;
    my $found_zero_run = undef;
    foreach (0..$#trimmed_hextets) {
        if ($zero_run[$_]) {
            $cur_zero_run = $zero_run[$_];
        } else {
            if (defined($cur_zero_run)) {
                # end of a zero run
                if ($cur_zero_run == $max_zero_run && !$found_zero_run) {
                    # found the :: place!
                    $found_zero_run = 1;
                    push(@zero_runned_hextets, ($#zero_runned_hextets == -1 ? ':' : ''));
                } else {
                    push(@zero_runned_hextets, ('0') x $cur_zero_run);
                };
            };
            push(@zero_runned_hextets, $trimmed_hextets[$_]);
            $cur_zero_run = undef;
        };
    };
    # trailing zeros
    if (defined($cur_zero_run)) {
        if ($cur_zero_run == $max_zero_run && !$found_zero_run) {
            # found the :: place!
            $found_zero_run = 1;
            push(@zero_runned_hextets, ($#zero_runned_hextets == -1 ? '::' : ':'));  # trailing :
        } else {
            push(@zero_runned_hextets, ('0') x $cur_zero_run);
        };
    };
    return join (':', @zero_runned_hextets);
};

=head2 ip_fullhex_to_normal

    $ip_normal = Fsdb::Support::IPv6::ip_fullhex_to_normal('20010db8000300040005000600070008');
    # result is 2001:db8:3:4:5:6:7:8

    $ip_normal = Fsdb::Support::IPv6::ip_fullhex_to_normal('c0000201');
    # result is 192.0.2.1

Convert an IPv6 address to IETF normal form.
The input maybe has some fields 0 or leading zero,
or :: in a non-standard place.
Normalize it to remove leading zeros and replace the leftmost,
longest run of zeros with ::.

Also treats strings of hex digits without colons as IPv6 prefixes.

=cut
sub ip_fullhex_to_normal {
    my($s) = @_;
    if (length($s) <= 8) {
        my(@octets) = map { sprintf("%d", hex($_)) } unpack('(A2)*', $s);
        while ($#octets < 3) {
            push(@octets, '0');
        };
        return join('.', @octets);
    } else {
        return ipv6_normalize($s);
    };
}


=head2 _test_zero_fill

Internal testing.

=cut
sub _test_zero_fill {
    my($in, $out) = @_;
    my($trial) = ipv6_zeroize($in);
    $out //= "undef";
    $trial //= "undef";
    if ($trial eq $out) {
        print "zzf ok: $in -> $out\n";
    } else {
        print "zzf NO: $in -> $out but got $trial\n";
    };
}

=head2 _test_zero_remove

Internal testing.

=cut
sub _test_zero_remove {
    my($in, $out) = @_;
    return if (!defined($out));
    my($trial) = ipv6_normalize($in);
    $out //= "undef";
    $trial //= "undef";
    if ($trial eq $out) {
        print "zrr ok: $in -> $out\n";
    } else {
        print "zrr NO: $in -> $out but got $trial\n";
    };
}

=head2 _test_fullhex

Internal testing.

=cut
sub _test_fullhex {
    my($in, $out) = @_;
    my($trial) = ipv6_fullhex($in);
    $trial //= "undef";
    if ($trial eq $out) {
        print "fh ok: $in -> $out\n";
    } else {
        print "fh NO: $in -> $out but got $trial\n";
    };
}

=head2 _test_fullhex_to_normal

Internal testing.

=cut
sub _test_fullhex_to_normal {
    my($in, $out) = @_;
    my($trial) = ip_fullhex_to_normal($in);
    $trial //= "undef";
    if ($trial eq $out) {
        print "fhn ok: $in -> $out\n";
    } else {
        print "fhn NO: $in -> $out but got $trial\n";
    };
}

=head2 _test_both

Internal testing.

=cut
sub _test_both {
    my($in, $out) = @_;
    _test_zero_fill($in, $out);
    _test_zero_remove($out, $in);
};

=head2 _test_ipv6

Internal testing.

=cut
sub _test_ipv6 {
    _test_both("1:2:3:4:5:6:7:8", "1:2:3:4:5:6:7:8");
    _test_zero_fill("1:2:3:4:5:6:7:0", "1:2:3:4:5:6:7:0");
    _test_both("1:2:3:4:5:6:7::", "1:2:3:4:5:6:7:0");
    _test_both("1:2:3:4:5:6::",   "1:2:3:4:5:6:0:0");
    _test_zero_fill("1:002:3:4:5:6::",   "1:2:3:4:5:6:0:0");
    _test_zero_fill("1:0000:3:4:5:6::",   "1:0:3:4:5:6:0:0");
    _test_both("1:2:3:4:5::8",    "1:2:3:4:5:0:0:8");
    _test_both("1:2:3:4::8",      "1:2:3:4:0:0:0:8");
    _test_both("1:2:3:4::7:8",    "1:2:3:4:0:0:7:8");
    _test_both("1::8",            "1:0:0:0:0:0:0:8");
    _test_both("::1",             "0:0:0:0:0:0:0:1");
    _test_both("1::",             "1:0:0:0:0:0:0:0");
    _test_both("::",              "0:0:0:0:0:0:0:0");
    _test_both("1:2::6:0:0:8",    "1:2:0:0:6:0:0:8");
    # _test_zero_remove("1:2::6:0:0:8",    "1:2:0:0:6:0:0:8");
    _test_zero_fill("1:002::6:0:0:8",    "1:2:0:0:6:0:0:8");
    _test_zero_fill("1:2:0:0:6::8",    "1:2:0:0:6:0:0:8");  # technically non-compliant
    _test_zero_fill("1:2::6::8",       undef);              # ambiguous, could be 1:2:0:0:6:0:0:8, or 1:2:0:0:0:6:0:8, or other configs
    _test_fullhex("1:2:3:4:5:6:7:8", "00010002000300040005000600070008");
    _test_fullhex("1:002::6:0:0:8",  "00010002000000000006000000000008");
    _test_fullhex("1:abcd::6:0:0:8", "0001abcd000000000006000000000008");
    # missing case 2021-12-10
    _test_zero_fill("1:02:003:0004:5:6:7:8", "1:2:3:4:5:6:7:8");
    _test_zero_fill("00010002000300040005000600070008", "1:2:3:4:5:6:7:8");
    _test_zero_fill("00010002000300040000000000070008", "1:2:3:4:0:0:7:8");
    _test_zero_fill("000100020003", "1:2:3:0:0:0:0:0");
    _test_fullhex_to_normal('20010db8000300040005000600070008', '2001:db8:3:4:5:6:7:8');
    _test_fullhex_to_normal('c0000201', '192.0.2.1');
    # new case 2025-03-01: ipv4-mapped IPv6
    _test_zero_fill("::ffff:192.0.2.128",    "0:0:0:0:0:ffff:c000:280");
};

# _test_ipv6;

1;

