#!/usr/bin/env perl
# uuid256.pl — reference implementation of README.md (UUID256, random layout) in Perl 5 (core modules only).
#
#   perl uuid256.pl                    # self-tests + exact duplicate check over 10,000,000 ids
#   perl uuid256.pl -n 2000000 -i 3    # 2e6 ids with 3 planted duplicates (proves detection)
#   perl uuid256.pl -g [count]         # just print one (or count) new ids, nothing else
#
#   require './uuid256.pl';                          # (or paste the Uuid256 package into your module)
#   my $id  = Uuid256::generate();                   # 32-byte binary string, §5.1: OS CSPRNG, ver=4 / var=10 applied
#   my $txt = Uuid256::to_canonical($id);            # §3.1: "0001020304050607-08090a0b-4c0d0e0f-90111213-1415161718191a1b1c1d1e1f"
#   my $b   = Uuid256::parse($txt);                  # §6: strict, dies with "uuid256: ..." on error; parse($txt, 0) is lenient
#
# Randomness (§5.2): read from /dev/urandom — the OS CSPRNG. (Perl's core has no CSPRNG module; on a
# platform without /dev/urandom install Crypt::URandom and swap it into os_random.)
# Bulk check: one /dev/urandom read for all ids, §4 applied to each, then the 32-byte ids are sorted and
# neighbours compared.  Exact, O(n log n), ~120 B of RAM per id.
use strict;
use warnings;
use Time::HiRes qw(time);

package Uuid256;
use strict;
use warnings;

use constant { BYTES => 32, TEXT_LEN => 68, VERSION => 0x4 };
our $STRICT_RE = qr/\A[0-9a-f]{16}-[0-9a-f]{8}-4[0-9a-f]{7}-[89ab][0-9a-f]{7}-[0-9a-f]{24}\z/;
our $NIL = "\x00" x BYTES;                                    # §8
our $MAX = "\xff" x BYTES;

# §5.2 — n bytes from the OS cryptographically secure random source.
sub os_random {
    my ($n) = @_;
    open(my $fh, '<:raw', '/dev/urandom') or die "uuid256: cannot open /dev/urandom: $!";
    my $buf = '';
    while (length($buf) < $n) {
        my $got = sysread($fh, $buf, $n - length($buf), length($buf));
        die "uuid256: /dev/urandom read failed: $!" unless defined $got && $got > 0;
    }
    close $fh;
    return $buf;
}

# §4 — force version nibble (byte 12) and variant bits (byte 16), in place, at offset $off (default 0).
sub set_ver_var {
    my ($off) = $_[1] // 0;
    substr($_[0], $off + 12, 1) = chr((ord(substr($_[0], $off + 12, 1)) & 0x0F) | (VERSION << 4));   # hex digit 24 = '4'
    substr($_[0], $off + 16, 1) = chr((ord(substr($_[0], $off + 16, 1)) & 0x3F) | 0x80);             # hex digit 32 in [89ab]
    return $_[0];
}

# §5.1 — one id straight from the OS CSPRNG (32-byte binary string, big-endian).
sub generate {
    my $b = os_random(BYTES);
    set_ver_var($b);
    return $b;
}

# §6 — ver == 4 && var == 10.
sub is_strict {
    my ($b) = @_;
    return length($b) == BYTES && (ord(substr($b, 12, 1)) >> 4) == VERSION && (ord(substr($b, 16, 1)) >> 6) == 0b10;
}

# §3.1 — canonical text: 16-8-8-8-24, lowercase, 68 chars.
sub to_canonical {
    my ($b) = @_;
    die "uuid256: value must be exactly 32 bytes\n" unless length($b) == BYTES;
    my $h = unpack('H*', $b);                                  # 64 lowercase hex digits
    return join('-', substr($h, 0, 16), substr($h, 16, 8), substr($h, 24, 8), substr($h, 32, 8), substr($h, 40, 24));
}

# §6 — parse canonical (68) or compact (64) form, any case; dies with a "uuid256: ..." message on error.
sub parse {
    my ($s, $strict) = @_;
    $strict = 1 unless defined $strict;
    $s = lc $s;
    if (length($s) == TEXT_LEN) {
        die "uuid256: hyphen at wrong position\n" unless substr($s, 16, 1) eq '-' && substr($s, 25, 1) eq '-' && substr($s, 34, 1) eq '-' && substr($s, 43, 1) eq '-';
        $s =~ tr/-//d;
    } elsif (length($s) != 64) {
        die "uuid256: wrong length\n";
    }
    die "uuid256: invalid character\n" unless $s =~ /\A[0-9a-f]{64}\z/;
    my $b = pack('H*', $s);
    die "uuid256: unsupported version/variant\n" if $strict && !is_strict($b);
    return $b;
}

package main;

# ---------------------------------------------------------------------------
# Self-tests (spec §11 vectors, §3.2/§6 parser rules, live generation)
# ---------------------------------------------------------------------------
sub rejects { my ($s, $strict) = @_; my $ok = eval { Uuid256::parse($s, $strict); 1 }; return !$ok; }

sub self_test {
    my $fails = 0;
    my @vectors = (
        ['000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f', '0001020304050607-08090a0b-4c0d0e0f-90111213-1415161718191a1b1c1d1e1f'],
        ['fffefdfcfbfaf9f8f7f6f5f4f3f2f1f0efeeedecebeae9e8e7e6e5e4e3e2e1e0', 'fffefdfcfbfaf9f8-f7f6f5f4-43f2f1f0-afeeedec-ebeae9e8e7e6e5e4e3e2e1e0'],
    );
    for my $i (0 .. $#vectors) {
        my ($raw, $expected) = @{ $vectors[$i] };
        my $b = pack('H*', $raw);
        Uuid256::set_ver_var($b);
        my $txt = Uuid256::to_canonical($b);
        my $ok = $txt eq $expected && Uuid256::is_strict($b)
              && Uuid256::parse($txt) eq $b && Uuid256::parse(uc $txt) eq $b && $txt =~ $Uuid256::STRICT_RE
              && !rejects($raw, 0) && rejects($raw, 1);                            # raw compact: lenient ok, strict rejects
        printf "  spec §11 vector %d: %s  %s\n", $i + 1, $ok ? 'PASS' : 'FAIL', $txt;
        $fails++ unless $ok;
    }
    my $nil_txt = Uuid256::to_canonical($Uuid256::NIL);
    my $ok = rejects('0001020304050607_08090a0b-4c0d0e0f-90111213-1415161718191a1b1c1d1e1f', 1)
          && rejects('0001020304050607-08090a0b-4c0d0e0f-90111213-1415161718191a1b1c1d1e1', 1)
          && rejects('0001020304050607-08090a0b-4c0d0e0f-90111213-1415161718191a1b1c1d1e1g', 1)
          && rejects($nil_txt, 1) && !rejects($nil_txt, 0) && Uuid256::parse($nil_txt, 0) eq $Uuid256::NIL
          && Uuid256::to_canonical($Uuid256::MAX) eq join('-', 'f' x 16, 'f' x 8, 'f' x 8, 'f' x 8, 'f' x 24);
    printf "  parser rules (§3.2/§6):  %s\n", $ok ? 'PASS' : 'FAIL';
    $fails++ unless $ok;
    for (1 .. 3) {
        my $b = Uuid256::generate();
        my $txt = Uuid256::to_canonical($b);
        my $ok2 = Uuid256::is_strict($b) && $txt =~ $Uuid256::STRICT_RE && Uuid256::parse($txt) eq $b;
        printf "  generate(): %s  %s\n", $txt, $ok2 ? 'ok' : 'BAD';
        $fails++ unless $ok2;
    }
    return $fails;
}

# ---------------------------------------------------------------------------
# Bulk exact duplicate check
# ---------------------------------------------------------------------------
sub commas { my $v = reverse shift; $v =~ s/(\d{3})(?=\d)/$1,/g; return scalar reverse $v; }

sub main {
    my @args = @_;
    my ($n, $planted) = (10_000_000, 0);
    if (@args >= 2 && ($args[0] eq '-p' || $args[0] eq '-P')) {                # parse mode: -p strict, -P lenient
        my $b = eval { Uuid256::parse($args[1], $args[0] eq '-p') };
        if (defined $b) { print "ok ", unpack('H*', $b), "\n"; return 0; }
        my %kind = ('wrong length' => 'length', 'hyphen at wrong position' => 'hyphen', 'invalid character' => 'char', 'unsupported version/variant' => 'version');
        (my $msg = $@) =~ s/^uuid256: //; chomp $msg;
        print "error ", ($kind{$msg} // 'unknown'), "\n"; return 1;
    }
    while (@args) {
        my $a = shift @args;
        if ($a eq '-g') {                                                        # just print ids: -g [count]
            my $count = (@args && $args[0] =~ /\A\d+\z/) ? shift @args : 1;      # -g N: exactly N (0 allowed); junk → 1
            print Uuid256::to_canonical(Uuid256::generate()), "\n" for 1 .. $count;
            return 0;
        }
        elsif ($a eq '-n' && @args) { $n = shift @args; }
        elsif ($a eq '-i' && @args) { $planted = shift @args; }
        else { print "usage: perl uuid256.pl [-g [count]] [-n count] [-i planted_dups]\n"; return 2; }
    }
    if ($n !~ /\A\d+\z/ || $planted !~ /\A\d+\z/ || $n < 2 || $planted > int($n / 2)) { print "-n must be an integer >= 2 and -i an integer at most n/2\n"; return 2; }

    print "UUID256 reference implementation (Perl) — README.md (256-bit random, 16-8-8-8-24 text)\n\n";
    print "Self-tests:\n";
    if (self_test() > 0) { print "  self-test FAILED — aborting\n"; return 1; }

    my $k = 100_000;
    my $t0 = time;
    Uuid256::generate() for 1 .. $k;
    my $per_call = (time - $t0) / $k;
    printf "\ngenerate() per-call cost: %.2f µs → %.2f M ids/s single-threaded (1e9 ids would take ~%.0f min just to generate; opening /dev/urandom per call dominates)\n",
        $per_call * 1e6, 1 / $per_call / 1e6, 1e9 * $per_call / 60;

    printf "\nBulk exact duplicate check: n=%s ids, planted duplicates=%d\n", commas($n), $planted;
    $t0 = time;
    my $buf = Uuid256::os_random($n * Uuid256::BYTES);                          # §5.2, one read
    for (my $p = 0; $p < length($buf); $p += Uuid256::BYTES) { Uuid256::set_ver_var($buf, $p); }   # §4
    my $t1 = time;
    # planted duplicates: id[dst] := id[src] — sources evenly spaced over the lower half, each mirrored
    # into the upper half, so all 2K positions are distinct and no source is itself a target (K <= n/2).
    my $plant_step = $planted ? int(int($n / 2) / $planted) : 0;
    for my $kk (0 .. $planted - 1) {
        my $src = $plant_step * $kk;
        my $dst = $n - 1 - $src;
        substr($buf, $dst * 32, 32) = substr($buf, $src * 32, 32);
        printf "  planted: id[%s] := id[%s]\n", commas($dst), commas($src);
    }
    my $bad = 0;
    for (my $p = 0; $p < length($buf); $p += 32) {
        $bad++ if (ord(substr($buf, $p + 12, 1)) >> 4) != Uuid256::VERSION || (ord(substr($buf, $p + 16, 1)) >> 6) != 0b10;
    }
    my @ids = unpack('(a32)*', $buf);                                            # exact: sort 32-byte binary strings
    my @order = sort { $ids[$a] cmp $ids[$b] } 0 .. $n - 1;
    my @dups;
    for my $x (1 .. $#order) {
        my ($a, $b) = ($order[$x - 1], $order[$x]);
        next unless $ids[$a] eq $ids[$b];
        push @dups, $a < $b ? [$a, $b, $ids[$a]] : [$b, $a, $ids[$a]];
    }
    my $t2 = time;
    printf "  DUPLICATE  id[%s] == id[%s]  %s\n", commas($_->[0]), commas($_->[1]), Uuid256::to_canonical($_->[2]) for @dups;
    my $step = $n / 1000 > 1 ? int($n / 1000) : 1;
    my $rt_ok = 0;
    for (my $i = 0; $i < $n; $i += $step) { my $id = $ids[$i]; $rt_ok++ if Uuid256::parse(Uuid256::to_canonical($id)) eq $id; }

    print "\n==== RESULT ====\n";
    printf "ids generated:                   %s   (/dev/urandom + §4 in %.1fs; sort+scan in %.1fs)\n", commas($n), $t1 - $t0, $t2 - $t1;
    printf "version/variant violations:      %s\n", commas($bad);
    printf "text round-trips (sampled):      %s ok\n", commas($rt_ok);
    printf "FULL 256-bit DUPLICATES:         %s%s\n", commas(scalar @dups),
        $planted ? sprintf('   (planted: %d — %s)', $planted, @dups == $planted ? 'all detected' : 'COUNT MISMATCH') : '';
    printf "  → no duplicates among %s ids\n", commas($n) unless @dups;
    my $log2p = 2 * log($n) / log(2) - 251;
    printf "expected P(any collision) §5.3:  n²/2²⁵¹ ≈ 2^%.1f ≈ %.1e\n", $log2p, 2**$log2p;
    return @dups == $planted ? 0 : 1;
}

exit(main(@ARGV)) unless caller;
1;