—

              
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.19';
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__
HideShow 284 lines of Pod
=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.19
=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.
=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