—package
Class::Usul::TraitFor::ConnectInfo;
use
5.010001;
use
namespace::autoclean;
use
Class::Usul::File;
use
Moo::Role;
requires
qw( config )
;
# As a class method
sub
dump_config_data {
my
(
$self
,
$config
,
$db
,
$cfg_data
) =
@_
;
my
$params
=
$self
->_merge_attributes(
$config
, {
database
=>
$db
} );
return
__dump_config_data(
$params
,
$cfg_data
);
}
sub
extract_creds_from {
my
(
$self
,
$config
,
$db
,
$cfg_data
) =
@_
;
my
$params
=
$self
->_merge_attributes(
$config
, {
database
=>
$db
} );
return
__extract_creds_from(
$params
,
$cfg_data
);
}
sub
get_connect_info {
my
(
$self
,
$app
,
$params
) =
@_
;
$app
//=
$self
;
$params
//= {};
merge_attributes
$params
,
$app
->config,
$self
->config, __connect_info_attr();
my
$class
=
$params
->{class} = blessed
$self
||
$self
;
my
$key
= __get_connect_info_cache_key(
$params
);
state
$cache
//= {};
defined
$cache
->{
$key
} and
return
$cache
->{
$key
};
my
$cfg_data
= __load_config_data(
$params
);
my
$creds
= __extract_creds_from(
$params
,
$cfg_data
);
my
$dsn
=
'dbi:'
.
$creds
->{driver}.
':database='
.
$params
->{database}
.
';host='
.
$creds
->{host}.
';port='
.
$creds
->{port};
my
$password
= decrypt_from_config(
$params
,
$creds
->{password} );
my
$opts
= __get_connect_options(
$creds
);
return
$cache
->{
$key
} = [
$dsn
,
$creds
->{user},
$password
,
$opts
];
}
sub
load_config_data {
my
(
$self
,
$config
,
$db
) =
@_
;
my
$params
=
$self
->_merge_attributes(
$config
, {
database
=>
$db
} );
return
__load_config_data(
$params
);
}
# Private methods
sub
_merge_attributes {
return
merge_attributes {
class
=> blessed
$_
[ 0 ] ||
$_
[ 0 ] },
$_
[ 1 ], (
$_
[ 2 ] || {}), __connect_info_attr();
}
# Private functions
sub
__connect_info_attr {
return
[
qw( class ctlfile ctrldir database dataclass_attr extension
prefix read_secure salt seed seed_file subspace tempdir )
];
}
sub
__dump_config_data {
my
(
$params
,
$cfg_data
) =
@_
;
my
$ctlfile
= __get_credentials_file(
$params
);
my
$schema
= __get_dataclass_schema(
$params
->{dataclass_attr} );
return
$schema
->
dump
( {
data
=>
$cfg_data
,
path
=>
$ctlfile
} );
}
sub
__extract_creds_from {
my
(
$params
,
$cfg_data
) =
@_
;
my
$key
= __get_connect_info_cache_key(
$params
);
(
$cfg_data
->{credentials} and
defined
$cfg_data
->{credentials}->{
$key
})
or throw
'Path [_1] database [_2] no credentials'
,
args
=> [ __get_credentials_file(
$params
),
$key
];
return
$cfg_data
->{credentials}->{
$key
};
}
sub
__get_connect_info_cache_key {
my
$params
=
shift
;
my
$db
=
$params
->{database}
or throw
'Class [_1] has no database name'
,
args
=> [
$params
->{class} ];
return
$params
->{subspace} ?
"${db}."
.
$params
->{subspace} :
$db
;
}
sub
__get_connect_options {
my
$creds
=
shift
;
my
$uopt
=
$creds
->{unicode_option}
|| __unicode_options()->{
lc
$creds
->{driver} } || {};
return
{
AutoCommit
=>
$creds
->{auto_commit } // TRUE,
PrintError
=>
$creds
->{print_error } // FALSE,
RaiseError
=>
$creds
->{raise_error } // TRUE,
%{
$uopt
}, %{
$creds
->{database_attr} || {} }, };
}
sub
__get_credentials_file {
my
$params
=
shift
;
my
$ctlfile
=
$params
->{ctlfile};
defined
$ctlfile
and -f
$ctlfile
and
return
$ctlfile
;
my
$dir
=
$params
->{ctrldir};
my
$db
=
$params
->{database};
$dir
or throw Unspecified,
args
=> [
'ctrldir'
];
-d
$dir
or throw
'Directory [_1] not found'
,
args
=> [
$dir
];
$db
or throw
'Class [_1] has no database name'
,
args
=> [
$params
->{class} ];
return
catfile(
$dir
,
$db
.(
$params
->{extension} || CONFIG_EXTN) );
}
sub
__get_dataclass_schema {
return
Class::Usul::File->dataclass_schema(
@_
);
}
sub
__load_config_data {
my
$schema
= __get_dataclass_schema(
$_
[ 0 ]->{dataclass_attr} );
return
$schema
->load( __get_credentials_file(
$_
[ 0 ] ) );
}
sub
__unicode_options {
return
{
mysql
=> {
mysql_enable_utf8
=> TRUE },
pg
=> {
pg_enable_utf8
=> TRUE },
sqlite
=> {
sqlite_unicode
=> TRUE }, };
}
1;
=pod
=encoding utf8
=head1 Name
Class::Usul::TraitFor::ConnectInfo - Provides the DBIC connect info array ref
=head1 Synopsis
package YourClass;
use Moo;
use Class::Usul::Constants;
use Class::Usul::Types qw( NonEmptySimpleStr Object );
with 'Class::Usul::TraitFor::ConnectInfo';
has 'database' => is => 'ro', isa => NonEmptySimpleStr,
default => 'database_name';
has 'schema' => is => 'lazy', isa => Object, builder => sub {
my $self = shift; my $extra = $self->config->connect_params;
$self->schema_class->connect( @{ $self->get_connect_info }, $extra ) };
has 'schema_class' => is => 'ro', isa => NonEmptySimpleStr,
default => 'dbic_schema_class_name';
sub config { # A class method
return { ...config parameters... }
}
=head1 Description
Provides the DBIC connect info array ref
=head1 Configuration and Environment
The JSON data looks like this:
{
"credentials" : {
"schedule" : {
"driver" : "mysql",
"host" : "localhost",
"password" : "{Twofish}U2FsdGVkX1/xcBKZB1giOdQkIt8EFgfNDFGm/C+fZTs=",
"port" : "3306",
"user" : "username"
}
}
}
=head1 Subroutines/Methods
=head2 dump_config_data
$dumped_data = $self->dump_config_data( $app_config, $db, $cfg_data );
Call the L<dump method|File::DataClass::Schema/dump> to write the
configuration file back to disk
=head2 extract_creds_from
$creds = $self->extract_creds_from( $app_config, $db, $cfg_data );
Returns the credential info for the specified database and (optional)
subspace. The subspace attribute of C<$app_config> is appended
to the database name to create a unique cache key
=head2 get_connect_info
$db_info_arr = $self->get_connect_info( $app_config, $db );
Returns an array ref containing the information needed to make a
connection to a database; DSN, user id, password, and options hash
ref. The data is read from the configuration file in the config
C<ctrldir>. Multiple sets of data can be stored in the same file,
keyed by the C<$db> argument. The password is decrypted if
required
=head2 load_config_data
$cfg_data = $self->load_config_data( $app_config, $db );
Returns a hash ref of configuration file data. The path to the file
can be specified in C<< $app_config->{ctlfile} >> or it will default
to the C<$db.$extension> file in the C<< $app_config->{ctrldir} >>
directory. The C<$extension> is either C<< $app_config->{extension} >>
or C<< $self->config->{extension} >> or the default extension given
by the C<CONFIG_EXTN> constant
=head1 Diagnostics
None
=head1 Dependencies
=over 3
=item L<Moo::Role>
=item L<Class::Usul::Crypt::Util>
=item L<Unexpected>
=back
=head1 Incompatibilities
There are no known incompatibilities in this module
=head1 Bugs and Limitations
There are no known bugs in this module.
Please report problems to the address below.
Patches are welcome
=head1 Acknowledgements
Larry Wall - For the Perl programming language
=head1 Author
Peter Flanigan, C<< <pjfl@cpan.org> >>
=head1 License and Copyright
Copyright (c) 2014 Peter Flanigan. All rights reserved
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself. See L<perlartistic>
This program is distributed in the hope that it will be useful,
but WITHOUT WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE
=cut
# Local Variables:
# mode: perl
# tab-width: 3
# End: