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 {
        @symbol{@to_keys} = $lsymbol->@{@from_keys};
    }

    # DBD specific symbols
    Hash::Util::lock_hashref( $cache->{types}{dbd} = {%symbol} );

    # add DBI's symbols.
    if ( $dbd ne 'DBI' ) {
        my $dbi   = types( 'DBI' );
        my @types = keys $dbi->%*;
        @symbol{@types} = $dbi->@{@types};
    }

    Hash::Util::lock_hash( %symbol );
    $cache->{types}{all} = \%symbol;
    return $cache->{types}{$collection};
}


# ensure that $field_class has been required prior to calling this.
my sub _mk_field ( $name, $type, $attr, $field_class ) {

    # do this here and use require to prevent import loop from
    # anything which uses CXC::DB::DDL::Field, which uses this module

    set_subname "${name}::_mk_field", sub ( $field ) {
        $field_class->new( {
            name        => $field,
            data_type   => $type,
            is_nullable => 0,
            $attr->%*,
        } );
    };

}


sub _expand_field_sub ( $, $cache, $field_class, $name, $type ) {    ## no critic( Subroutines::ProhibitManyArgs )

    my $symbols = ( ( $cache->{fields} //= {} )->{$field_class} //= {} )->{symbols} //= {};

    return "&$name", $symbols->{$name}
      if exists $symbols->{$name};

    Module::Runtime::use_module( $field_class );

    return "&$name", $symbols->{$name} = set_subname $name, sub ( %attr ) {
        _mk_field( $name, $type, \%attr, $field_class );
    };
}

sub _expand_type_class_sub ( $class, $name, $cache, $dbd, $collection = 'all' ) {

    if ( $name =~ qr/TYPE_NAMES$/ ) {
        return "&$name", $cache->{subs}{$name} //= set_subname $name, do {
            my @names = sort keys types( $dbd, $collection )->%*;
            sub { @names };
        };
    }

    # just the standard SQL ones from DBI
    if ( $name =~ qr/TYPE_VALUES$/ ) {
        return "&$name", $cache->{subs}{$name} //= set_subname $name, do {
            my $types  = types( $dbd, $collection );
            my @values = map { $types->{$_}->() } sort keys $types->%*;
            sub { @values };
        };
    }

    croak( "internal error: unexpected type sub name: $name" );
}

sub _exporter_validate_opts ( $class, $globals ) {
    init( $globals );
}

sub _exporter_expand_tag ( $class, $name, $value, $globals ) {

    # _exporter_expand_tag is called before _exporter_validate_opts,
    # so init just in case
    init( $globals );
    my $stash = $globals->{ __PACKAGE__() };
    my $dbd   = $stash->{dbd};

    # mindless copy from Exporter::Tiny::_exporter_expand_tag
    return ( $class->_exporter_merge_opts( $value, $globals, @EXPORT_OK, keys types( $dbd )->%*, ) )
      if $name eq 'all';

    return ( $class->_exporter_merge_opts( $value, $globals, keys types( $dbd )->%*, ) )
      if $name eq 'type_funcs';

    if ( $name eq 'types' ) {
        # first the standard ones
        my @symbols = map { 'SQL_' . $_ } keys types( 'DBI' )->%*;

        # and then the DBD specific ones
        push @symbols, map { 'DBD_TYPE_' . $_ } keys types( $dbd, 'dbd' )->%*
          if $dbd ne 'DBI';

        return ( $class->_exporter_merge_opts( $value, $globals, @symbols ) );
    }

    $class->SUPER::_exporter_expand_tag( $name, $value, $globals );
}

sub _exporter_expand_sub ( $class, $name, $value, $globals, $permitted ) {

    my $stash = $globals->{ __PACKAGE__() };
    my $cache = $stash->{cache};
    my $dbd   = $stash->{dbd};

    # just the standard SQL ones from DBI
    return $class->_expand_type_class_sub( $name, $cache, 'DBI', 'dbd' )
      if $name eq 'SQL_TYPE_NAMES' or $name eq 'SQL_TYPE_VALUES';

    # Just those from the DBD
    return $class->_expand_type_class_sub( $name, $cache, $dbd, 'dbd' )
      if $name eq 'DBD_TYPE_NAMES' or $name eq 'DBD_TYPE_VALUES';

    # All of 'em from DBI & from the DBD
    return $class->_expand_type_class_sub( $name, $cache, $dbd, 'all' )
      if $name eq 'TYPE_NAMES' or $name eq 'TYPE_VALUES';

    if ( $name eq 'xTYPE' ) {
        # field class may be specific to this use of Util, rather than dbd specific,
        my $field_class = Module::Runtime::use_module( $stash->{field_class} );
        return "&$name", $cache->{subs}{$name}{$field_class} //= set_subname $name, sub ( $type, %attr ) {
            _mk_field( $name, $type, \%attr, $field_class );
        };
    }

    if ( $name =~ /^(?<pfx>DBD_TYPE|SQL)_(?<type>.*)/ ) {
        $dbd = 'DBI' if $+{pfx} eq 'SQL';
        my \%types = $CACHE{$dbd}{types}{dbd};
        return "&$name", $types{ $+{type} }
          if exists $types{ $+{type} };
    }

    # $symbols is a locked hash, so can't just grab a value
    my $symbols = types( $dbd );
    if ( exists $symbols->{$name} && defined( my $sub = $symbols->{$name} ) ) {
        return $class->_expand_field_sub( $cache, $stash->{field_class}, $name, $sub->() );
    }


    $class->SUPER::_exporter_expand_sub( $name, $value, $globals, $permitted );
}


























































































































sub xFIELDS ( @fields ) {
    return fields => [ map { $_->value->( $_->key ) } pairs( @fields ) ];
}
























sub xCHECK ( $field, @values ) {
    ( check => sprintf( "$field in ( %s )", join( ', ', map { qq("$_") } @values ) ), )
}


























sub sqlt_entity_map ( $dbd, $entity ) {
    state $map = {
        +( DBD_POSTGRESQL ) => {
            producer   => 'PostgreSQL',
            db_version => 'postgres_version',
        },
        +( DBD_SYBASE ) => {
            producer   => 'Sybase',
            db_version => undef,
        },
        +( DBD_SQLITE ) => {
            producer   => 'SQLite',
            db_version => 'sqlite_version',
        },

    };

    my $entity_map = $map->{$dbd} // return undef;
    return exists $entity_map->{$entity}
      ? $entity_map->{$entity}
      : croak( "unkown entity: $entity" );
}










sub db_version( $dbh ) {

    my $dbd = $dbh->{Driver}->{Name};

    return $dbd eq DBD_POSTGRESQL
      ? $dbh->{pg_server_version}
      : $dbh->get_info( $GetInfoType{SQL_DBMS_VER} );
}

1;

#
# This file is part of CXC-DB-DDL
#
# This software is Copyright (c) 2022 by Smithsonian Astrophysical Observatory.
#
# This is free software, licensed under:
#
#   The GNU General Public License, Version 3, June 2007
#

__END__

=pod

=for :stopwords Diab Jerius Smithsonian Astrophysical Observatory TYPENAME VARCHAR xCHECK
xFIELDS xTYPE SQLT DBD dbd

=head1 NAME

CXC::DB::DDL::Util - CXC::DB::DDL utilities

=head1 VERSION

version 0.21

=head1 SYNOPSIS

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

  # import xFIELDS, xCHECK, xTYPE
  use CXC::DB::DDL::Util -schema_funcs;

  # import type function generators (e.g. INTEGER, DOUBLE )
  use CXC::DB::DDL::Util -type_funcs;

  # import types (e.g. SQL_TIMESTAMP )
  use CXC::DB::DDL::Util -types;

  use DBI;
  $ddl = CXC::DB::DDL->new( [ {
              name => 'observation',
              xFIELDS(
                  obsid       => INTEGER( is_primary_key => 1 ),
                  date        => xTYPE( [SQL_TIMESTAMP] ),
                  event_count => INTEGER,
                  exposure    => REAL,
                  obs_cycle   => INTEGER,
                  prop_cycle  => INTEGER,
              ),
          },
      ] );

=head1 DESCRIPTION

C<CXC::DB::DDL::Util> provides a DSL  to ease creation of,
amongst, others, L<CXC::DB::DDL::Field> objects.  It uses
L<Exporter::Tiny> as its base exporter, allowing renaming of exported
symbols and other things.

The heart of system is L</xFIELDS>, which takes pairs of B<<
($field_name, $type_generator) >> and returns a B<< fields => \%attr >>
pair suitable to be passed to L<CXC::DB::DDL>'s constructor.

The type generators accept any of the L<CXC::DB::DDL::Field> attribute
specifications.

Unfortunately, it is not possible to easily override the class used
to create fields.

=head2 DBD Specific Types

Some database drivers (e.g. L<DBD::Pg>) provide additional types.  For the
generic mechanism to add these see L</ADVANCED USES>.

To access the PostgreSQL types, first load the L<DBD::Pg> specific
subclass of L<CXC::DB::DDL::Field>, then pass the global B<< dbd =>
'Pg' >> option to B<CXC::DB::DDL::Util>:

  use CXC::DB::DDL::Field::Pg;
  use CXC::DB::DDL::Util { dbd => 'Pg' }, -type_funcs;

The PostgreSQL specific type function generators are now available as e.g., B<PG_JSONB>
(the B<PG_> prefix is I<not> removed):

  @fields = xFIELDS(
      segment        => INTEGER,
      pars           => PG_JSONB,
  );

The generated field objects will be in the L<CXC::DB::DDL::Field::Pg>
class.

=head2 Type constants

"Bare" type "constants" are used by L</xTYPE>; these are made available
either via explicit export or via the L</-types> option passed during
import.  The constants' values are specific to this package; do
not use them in place of the standard constants when working directly
with L<DBI>.

The standard SQL types (e.g. those exported by L<DBI>) are
available under the same names (e.g. B<SQL_INTEGER>).  The DBD specific
types are available with an added prefix of B<DBD_TYPE_>, e.g.
the L<DBD::Pg>'s B<PG_JSON> is made available as B<DBD_TYPE_PG_JSON>.

=head1 SUBROUTINES

=head2 SQL_TYPE_NAMES

=head2 SQL_TYPE_VALUES

  @type_names = SQL_TYPE_NAMES;
  @type_codes = SQL_TYPE_VALUES;

returns (in collated order) names and values of all of the DBI supported types
(without the C<SQL_> prefix)

=head2 DBD_TYPE_NAMES

=head2 DBD_TYPE_VALUES

  @type_names = DBD_TYPE_NAMES;
  @type_codes = DBD_TYPE_VALUES;

returns (in collated order) names and values of all of the DBD supported types.

=head2 TYPE_NAMES

=head2 TYPE_VALUES

  @type_names = DBD_TYPE_NAMES;
  @type_codes = DBD_TYPE_VALUES;

returns (in collated order) names and values of all of the supported types

=head2 I<TYPENAME>

I<TYPENAME> is one of the SQL types recognized by L<DBI> or by
a particular L<DBD> driver (see L</DBD Specific Types>).

See L<CXC::DB::DDL::Constants/sql_type_constants> for more information.

Called as, e.g.

   INTEGER( %attr )

these are generators which return subroutines with the following signature:

   sub ( $field_name )

which return a L<CXC::DB::DDL::Field> object with the specified SQL
datatype (in this example C<INTEGER>), field name (C<$field_name>)
and attributes (C<%attr>).

These are available for individual export or in entirety via the
C<type_funcs> tag.

They are typically used in conjunction with the L</xFIELDS>
subroutine, e.g.

  xFIELDS(
      segment        => INTEGER,
      obsid          => INTEGER( is_primary_key => 1 ),
      target_type    => VARCHAR( is_nullable => 1 ),
  )

L</xFIELDS> essentially turns this into:

  fields => [
      INTEGER()->('segment'),
      INTEGER(is_primary_key => 1 )->('obsid'),
      VARCHAR(is_nullable => 1 )->( 'target_type' ),
  ]

which is more painful to write and look at. So don't.

=head2 xTYPE

  xTYPE ( $type, %attr )

A generic form of e.g., L</INTEGER>. Type is a type constant exported
by this module (not by L<DBI> or a L<DBD> driver). It is important to
use the types provided by this package, e.g. do this:

  use CXC::DB::DDL::Util 'DBD_TYPE_PG_JSONB';

  xTYPE( DBD_TYPE_PG_JSONB, ... );

=head2 xFIELDS

   @field_spec = xFIELDS( array of  Tuple[ NonEmptyStr, CodeRef ] );

returns a list of

   fields => \@spec,

where C<@spec> generated by running

     CodeRef->(NonEmptyStr)

for each tuple.

=head2 xCHECK

DEPRECATED; use a table constraint B<type> set to the constant
L<CHECK_C|CXC::DB::DDL::Constants/CHECK_C>, as follows:

  my $table = CXC::DB::DDL::Table_>new( ...,
      constraints => [
          {
              expression => '"type" in ( "a", "b", "c" )',
              type       => CHECK_C,
          },
     ] );

DEPRECATED USE BELOW:

    $string = xCHECK( $field, @values )

generates a check constraint as a string which looks like

  $field in ( $value[0], $value[1], ...  )

=head2 sqlt_entity_map

  $sqlt_producer = sqlt_entity_map( $dbd, $entity );

Produce a producer specific entity given a C<$dbd> (typically from
C<$dbh->{Driver}{NAME}>) and an entity name to what L<SQL::Translator>
wants.  Returns B<undef> if the entity is not recognized or not supported.

Entities include

=over

=item B<producer>

The name of the SQLT Producer class.  Check for this first; if it
returns B<undef>, C<$dbd> isn't supported.

=item B<db_version>

The name of the parameter passed to the SQLT Producer class for the database version.

=back

=head2 db_version

  $version = db_version( $dbh )

Return the database server version for the passed handle.  The value
is meant to be passed to the SQLT producer.

=head1 SUPPORT

=head2 Bugs

Please report any bugs or feature requests to bug-cxc-db-ddl@rt.cpan.org  or through the web interface at: L<https://rt.cpan.org/Public/Dist/Display.html?Name=CXC-DB-DDL>

=head2 Source

Source is available at

  https://gitlab.com/djerius/cxc-db-ddl

and may be cloned from

  https://gitlab.com/djerius/cxc-db-ddl.git

=head1 SEE ALSO

Please see those modules/websites for more information related to this module.

=over 4

=item *

L<CXC::DB::DDL|CXC::DB::DDL>

=item *

L<CXC::DB::DDL::Field::Pg|CXC::DB::DDL::Field::Pg>

=back

=head1 AUTHOR

Diab Jerius <djerius@cpan.org>

=head1 COPYRIGHT AND LICENSE

This software is Copyright (c) 2022 by Smithsonian Astrophysical Observatory.

This is free software, licensed under:

  The GNU General Public License, Version 3, June 2007

=cut
