File Coverage

blib/lib/DBIx/QuickORM/Type/UUID.pm

Criterion	Covered	Total	%
statement	80	89	89.8
branch	29	44	65.9
condition	10	25	40.0
subroutine	18	19	94.7
pod	0	9	0.0
total	137	186	73.6

package DBIx::QuickORM::Type::UUID;
use strict;
use warnings;

our $VERSION = '0.000019';

use Role::Tiny::With qw/with/;
with 'DBIx::QuickORM::Role::Type';

use DBIx::QuickORM::Util qw/parse_conflate_args/;

use Scalar::Util qw/blessed/;
use UUID qw/uuid7 parse unparse/;
use Carp qw/croak/;

sub new { uuid7() }

sub qorm_inflate {
    my $params = parse_conflate_args(@_);
    my $val    = $params->{value} or return undef;
    my $class  = $params->{class} // __PACKAGE__;

    return undef unless defined $val;

    return $class->looks_like_uuid($val) // $class->looks_like_bin($val) // croak "'$val' does not look like a UUID";
}

sub qorm_deflate {
    my $params   = parse_conflate_args(@_);
    my $val      = $params->{value}    or return undef;
    my $affinity = $params->{affinity} or croak "Could not determine affinity";
    my $class    = $params->{class} // __PACKAGE__;

    if (my $uuid = $class->looks_like_uuid($val)) {
        return $uuid if $affinity eq 'string';

        my $b;
        parse($val, $b);
        return $b;
    }

    if (my $uuid = $class->looks_like_bin($val)) {
        return $val if $affinity eq 'binary';
        return $uuid;
    }

    croak "'$val' does not look like a uuid";
}

sub qorm_compare {
    my $class = shift;
    my ($a, $b) = @_;

    $a = $class->qorm_inflate($a);
    $b = $class->qorm_inflate($b);

    my $da = defined($a);
    my $db = defined($b);

    return $a cmp $b if $da && $db;
    return 0 unless $da || $db;
    return 1;
}

sub qorm_affinity {
    my $class = shift;
    my %params = @_;

    if (my $sql_type = $params{sql_type}) {
        return 'string' if lc($sql_type) eq 'uuid';
        return 'binary' if $sql_type =~ m/(bin(ary)?|bytea?|blob)/i;
    }

    if (my $dialect = $params{dialect}) {
        return 'string' if $dialect->supports_type('uuid');
    }

    return 'string';
}

sub qorm_sql_type {
    my $self = shift;
    my ($dialect) = @_;

    if (my $stype = $dialect->supports_type('uuid')) {
        return $stype;
    }

    # Document how to set up binary(16)
    # Basically use the post_column hook in Autofill
    return 'VARCHAR(36)';
}

sub looks_like_bin {
    my $in = pop;
    use bytes;
    return undef unless length($in) == 16;
    my $s;
    unparse($in, $s);
    return $s;
}

sub looks_like_uuid {
    my $in = pop;
    return $in if $in && $in =~ m/^[A-F0-9]{8}-[A-F0-9]{4}-[A-F0-9]{4}-[A-F0-9]{4}-[A-F0-9]{12}$/i;
    return undef;
}

sub qorm_register_type {
    my $self = shift;
    my ($types, $affinities) = @_;

    my $class = ref($self) || $self;

    $types->{uuid} //= $class;

    push @{$affinities->{binary}} => sub {
        my %params = @_;
        return $class if $params{name}    =~ m/uuid/i;
        return $class if $params{db_name} =~ m/uuid/i;
        return;
    };

    push @{$affinities->{string}} => sub {
        my %params = @_;
        return $class if $params{name}    =~ m/uuid/i;
        return $class if $params{db_name} =~ m/uuid/i;
        return;
    };
}

1;