view release on metacpan or  search on metacpan

lib/CXC/DB/DDL/Util.pm  view on Meta::CPAN

package CXC::DB::DDL::Util;

# ABSTRACT: CXC::DB::DDL utilities

use v5.26;
use strict;
use warnings;
use experimental 'signatures', 'postderef', 'declared_refs';

our $VERSION = '0.21';

use List::Util      qw( pairs first );
use Sub::Util       qw( set_subname );
use Module::Runtime ();
use Import::Into;
use Digest::MD5;

use Package::Stash;
use Ref::Util  ();
use Hash::Util ();

use DBI ();
use DBI::Const::GetInfoType;

use CXC::DB::DDL::Constants -all;

use namespace::clean;

use base 'Exporter::Tiny';

use constant BASE_TYPE_PACKAGE   => __PACKAGE__ . '::Type';
use constant DEFAULT_FIELD_CLASS => 'CXC::DB::DDL::Field';

our %EXPORT_TAGS = (
    schema_funcs => [qw( xFIELDS xCHECK xTYPE  )],
    misc         => [ 'SQL_TYPE_NAMES', 'SQL_TYPE_VALUES', 'sqlt_entity_map', 'db_version' ],
);

our @EXPORT_OK = ( map { Ref::Util::is_arrayref( $_ ) ? $_->@* : () } values %EXPORT_TAGS );

my sub gen_package_name;
my sub types;

my sub croak {
    require Carp;
    goto \&Carp::croak;
}


my %CACHE = (
    'DBI' => {
        tag   => ':sql_types',
        types => {
            package => gen_package_name( 'DBI' ),
        },
        subs   => {},
        fields => {
            default => +( DEFAULT_FIELD_CLASS ),
        },
    },
);

my sub is_supported_dbd ( $dbd ) {
    my %supported;
    @supported{ 'DBI', SUPPORTED_DBDS, keys %CACHE } = ();
    return exists $supported{$dbd};
}

sub gen_package_name ( $dbd, @xtra ) {
    # create a unique class for this blend
    return join q{::}, BASE_TYPE_PACKAGE, Digest::MD5::md5_hex( $dbd // (), @xtra );
}

my sub init ( $globals ) {

    # we can reach this sub through multiple paths; only init once.
    return if exists $globals->{ __PACKAGE__() };

    # request to add support for specified DBD?
    if ( my $request = $globals->{add_dbd} ) {
        Ref::Util::is_hashref( $request )
          or croak( "add_dbd: expected the DBD entry to be a hashref, got @{[ ref $request ]} " );
        my ( $dbd, $tag, $field_class, $type_class )
          = $request->@{ 'dbd', 'tag', 'field_class', 'type_class' };

        defined( $dbd ) && defined( $tag ) && defined( $field_class )
          or croak(
            sprintf( 'add_dbd: missing dbd (%s), tag(%s), or field_class(%s)',
                map { $_ // 'undef' } ( $dbd, $tag, $field_class ), ) );

        # silently ignores attempts to redefine.  should it warn?
        if ( !exists $CACHE{$dbd} ) {
            $CACHE{$dbd} = {
                tag    => $tag,
                fields => {
                    default => $field_class,
                },
                types => {
                    class   => $type_class,
                    package => gen_package_name( $dbd ),
                },
                subs => {},
            };
        }

        # load the dbd types by default.
        $globals->{dbd} //= $dbd;
    }

    my %stash;

    # request particular dbd or fallback to generic DBI support
    my $dbd = $globals->{dbd} // 'DBI';
    Ref::Util::is_ref( $dbd )
      and croak( 'dbd: value must be a scalar' );

    defined( my $cache = $CACHE{$dbd} )
      or croak( "dbd: unsupported DBD: $dbd" );

    $stash{dbd}   = $dbd;
    $stash{cache} = $cache;

    # Field wrappers generated by mk_field
    # override field_class?
    $stash{field_class} = $globals->{field_class} // $cache->{fields}{default};
    $stash{fields}      = $cache->{fields}{ $stash{field_class} } //= {};

    $globals->{ __PACKAGE__() } = \%stash;

    return;
}

# load the types for DBI and requested DBD's into individual
# packages and create a merged hash of names and subs
# cached by a hash of the DBD names.

sub types ( $dbd, $collection = 'all' ) {

    defined( my $cache = $CACHE{$dbd} )
      or croak( "types: unsupported dbd: $dbd" );

    return $cache->{types}{$collection} if defined $cache->{types}{$collection};

    my %symbol;

    my $stash  = Package::Stash->new( $cache->{types}{package} );
    my $module = Module::Runtime::use_module( $dbd eq 'DBI' ? $dbd : "DBD::$dbd" );
    $module->import::into( $stash->name, $cache->{tag} );
    my $lsymbol   = $stash->get_all_symbols( 'CODE' );
    my @from_keys = keys $lsymbol->%*;

    # strip off SQL_ from DBI types
    my @to_keys
      = $dbd eq 'DBI'
      ? map { s/^SQL_//r } @from_keys
      : @from_keys;

    # if this is a DBD specific set of types, and an object is
    # requested, make one.  This prevents collisions when the DBD
    # type code is the same as a standard SQL_TYPE_xxxx code.
    # The class MUST alread be loaded, so we don't have to
    # worry about where it is defined (inner package, etc.)
    if ( my $type_class = $cache->{types}{class} ) {
        my %to_key;
        @to_key{@from_keys} = @to_keys;

        for my $from ( @from_keys ) {
            my $to    = $to_key{$from};
            my $value = $lsymbol->{$from}->();
            $symbol{$to} = set_subname "DBD_TYPE_$to", sub { $type_class->new( $from, $value ) };
        }
    }

    else {