CXC-DB-DDL/lib/CXC/DB/DDL/Util.pm
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