DBIx-Class-Schema-Config-0.001013/0000755000175000017500000000000013434277721016434 5ustar catalystcatalystDBIx-Class-Schema-Config-0.001013/inc/0000755000175000017500000000000013434277721017205 5ustar catalystcatalystDBIx-Class-Schema-Config-0.001013/inc/Module/0000755000175000017500000000000013434277721020432 5ustar catalystcatalystDBIx-Class-Schema-Config-0.001013/inc/Module/Install/0000755000175000017500000000000013434277721022040 5ustar catalystcatalystDBIx-Class-Schema-Config-0.001013/inc/Module/Install/Fetch.pm0000644000175000017500000000462713434277654023445 0ustar catalystcatalyst#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; DBIx-Class-Schema-Config-0.001013/inc/Module/Install/Metadata.pm0000644000175000017500000004330213434277654024125 0ustar catalystcatalyst#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) [\s|;]* /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashes delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; DBIx-Class-Schema-Config-0.001013/inc/Module/Install/Win32.pm0000644000175000017500000000340313434277654023305 0ustar catalystcatalyst#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; DBIx-Class-Schema-Config-0.001013/inc/Module/Install/WriteAll.pm0000644000175000017500000000237613434277654024136 0ustar catalystcatalyst#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; DBIx-Class-Schema-Config-0.001013/inc/Module/Install/Can.pm0000644000175000017500000000640513434277654023111 0ustar catalystcatalyst#line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # Check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # Can we locate a (the) C compiler sub can_cc { my $self = shift; if ($^O eq 'VMS') { require ExtUtils::CBuilder; my $builder = ExtUtils::CBuilder->new( quiet => 1, ); return $builder->have_compiler; } my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 245 DBIx-Class-Schema-Config-0.001013/inc/Module/Install/Makefile.pm0000644000175000017500000002743713434277654024135 0ustar catalystcatalyst#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-separated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 DBIx-Class-Schema-Config-0.001013/inc/Module/Install/Base.pm0000644000175000017500000000214713434277654023261 0ustar catalystcatalyst#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.19'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 DBIx-Class-Schema-Config-0.001013/inc/Module/Install.pm0000644000175000017500000002714513434277654022414 0ustar catalystcatalyst#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.006; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.19'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::getcwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::getcwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::getcwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $base_path = VMS::Filespec::unixify($base_path) if $^O eq 'VMS'; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( {no_chdir => 1, wanted => sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($File::Find::name); my $in_pod = 0; foreach ( split /\n/, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }}, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; binmode FH; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; binmode FH; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp { _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2012 Adam Kennedy. DBIx-Class-Schema-Config-0.001013/Changes0000644000175000017500000000740713434277061017734 0ustar catalystcatalyst0.1.13: - Add '.' to @INC so Module::Install continues to work, this time for real. 0.1.12: - Add '.' to @INC so Module::Install continues to work. 0.1.11: - Using dbh_maker in a hash to connect() will not result in connect() passing through your arguments after merging into a single hash. - Using a code ref for the first argument will now result in connect() passing through your arguments as-is. - README.pod symlink replaces pod2markdown use (YAY!) - namespace::clean used to prevent methods from leaking - Merge functionality replaced with Hash::Merge - Additional attributes passed to connect() will now overwrite the loaded configuration file. - Removed Test::MockObject as a dependency - Improved caching layer to prevent stale cache - Changed tests to use the correct password attribute - Updated Documentation 0.1.10: - Introduce a public config() getter to allow access to the loaded Config::Any object. 0.1.9: - Fix perl 5.17 hash randomisation breakage (RT#83309) 0.1.8: - Added class accessor config_files to use Config::Any's load_files method and reduce stat() calls for those who like that kind of thing. - Moved the Config::Any parser to its own private function. - DBIX_CONFIG_DIR environment allows run-time injection of a directory that contains a dbic.* file. 0.1.7: - Use File::HomeDir instead of env, thanks @ Christian Walde - CHANGELOG -> Changes - BSD License -> Perl License - README.pod -> Readme.md - Contributor Addition (Christian Walde) 0.1.6: - Once more with feeling. 0.1.5: - Re-release due to broken MANIFEST.skip and outdated README.pod 0.1.4: - Config::Any added as a requirement - Tests now use the included .perl format (No more YAML::XS requirement) - Tests changed to support DBIx::Class 0.80123 - Document Changes - Linked to tutorial - Added CONTRIBUTOR section - Thanks mst and ribasushi for the constant reviews! - Pushed to CPAN as a stable release 0.1.3: - connect() now handles passing through valid-looking DBI connect structures. - _make_config now checks for $user and $pass to be hashrefs, this adds support for structures like ->connect( 'CONFIG', { hostname => 'db.foo.com' } ); - Added tests to 01_*.t to ensure the new signatures work correctly. - Updated tests in 06_*.t to use ->connect ('CONFIG', { dbname => ":memory:" ) to be more clear, as opposed to riding ->{user} - Updated documentation to reflect the changes to the code, namely the hashref as the second argument, and the statements referring to load_credentials having responsibility to return normal DBI connect structures. - Config::Any is only loaded when it's needed. 0.1.2: - Makefile.PL depends on DBD::SQLite not DBD::SQLite3 - _make_config has a less annoying return - connection() no longer tries to block ->load_credentials, it is load_credential's responsablity to to check for credentials it should allow to fall through. - Added accessor on_credential_load, it provides access to the config structure that load_credentials creates, and expects it as the return. It can be used to make changes to the credentials, such as decrypting passwords from the config file. - A new Schema base was created for testing on_credential_load - New tests added for on_credential_load 0.1.1: - Replace SUPER:: with next::method - Don't call load_credentials unless we're actually going to load some - Move Config::Any into load_credentials to be lazy - Allow handling of a normal hashref, no ->{options} (Should make handling cleaner) - Add Testing schema for integration tests 0.1.0: - Inital Version DBIx-Class-Schema-Config-0.001013/MANIFEST0000644000175000017500000000164013434277657017576 0ustar catalystcatalystChanges inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/DBIx/Class/Schema/Config.pm Makefile.PL MANIFEST This list of files META.yml t/00_load.t t/01_pass_through.t t/02_load_credentials.t t/03_config_paths.t t/04_integration_test.t t/05_integration_plugin.t t/06_on_credential_load.t t/07_integration_config_files.t t/08_integration_env.t t/09_no_modify_config.t t/etc/config.perl t/etc/dbic.perl t/lib/DBIx/Class/Schema/Config/ConfigFiles.pm t/lib/DBIx/Class/Schema/Config/ConfigFiles/Hash.pm t/lib/DBIx/Class/Schema/Config/ENV.pm t/lib/DBIx/Class/Schema/Config/ENV/Hash.pm t/lib/DBIx/Class/Schema/Config/Plugin.pm t/lib/DBIx/Class/Schema/Config/Plugin/Hash.pm t/lib/DBIx/Class/Schema/Config/Test.pm t/lib/DBIx/Class/Schema/Config/Test/Hash.pm DBIx-Class-Schema-Config-0.001013/t/0000755000175000017500000000000013434277721016677 5ustar catalystcatalystDBIx-Class-Schema-Config-0.001013/t/00_load.t0000644000175000017500000000037413433032752020276 0ustar catalystcatalyst#!/usr/bin/perl use warnings; use strict; use Test::More; my @want_modules = qw/ DBI DBIx::Class Hash::Merge namespace::clean DBIx::Class::Schema DBIx::Class::Schema::Config /; use_ok( $_ ) for @want_modules; done_testing(); DBIx-Class-Schema-Config-0.001013/t/06_on_credential_load.t0000644000175000017500000000115313433032752023166 0ustar catalystcatalyst#!/usr/bin/perl use warnings; use strict; use Test::More; use lib 't/lib'; # Tests above t/ use lib 'lib'; # Tests inside t/ use DBIx::Class::Schema::Config::Plugin; use Data::Dumper; # Using a config file, with a plugin changing the DSN. ok my $Schema = DBIx::Class::Schema::Config::Plugin->connect('PLUGIN', { dbname => ':memory:' }), "Connection to a plugin-modified schema works."; my $expect = [ { password => '', user => '', dsn => 'dbi:SQLite:dbname=:memory:' } ]; is_deeply $Schema->storage->connect_info, $expect, "Expected schema changes happened."; done_testing; DBIx-Class-Schema-Config-0.001013/t/03_config_paths.t0000644000175000017500000000071413433032752022024 0ustar catalystcatalyst#!/usr/bin/perl use warnings; use strict; use Test::More; use base 'DBIx::Class::Schema::Config'; use File::HomeDir; is_deeply( __PACKAGE__->config_paths, [ './dbic', File::HomeDir->my_home . "/.dbic", "/etc/dbic" ], "_config_paths looks sane."); __PACKAGE__->config_paths( [ ( './this', '/var/www/that' ) ] ); is_deeply( __PACKAGE__->config_paths, [ './this', '/var/www/that' ], "_config_paths can be modified."); done_testing; DBIx-Class-Schema-Config-0.001013/t/etc/0000755000175000017500000000000013434277721017452 5ustar catalystcatalystDBIx-Class-Schema-Config-0.001013/t/etc/dbic.perl0000644000175000017500000000045213433032752021230 0ustar catalystcatalyst{ "TEST" => { "dsn" => "dbi:SQLite:dbname=:memory:", "user" => "", "password" => "", }, "PLUGIN" => { "dsn" => "dbi:SQLite:dbname=%s", "user" => "", "password" => "", }, } DBIx-Class-Schema-Config-0.001013/t/etc/config.perl0000644000175000017500000000045213433032752021574 0ustar catalystcatalyst{ "TEST" => { "dsn" => "dbi:SQLite:dbname=:memory:", "user" => "", "password" => "", }, "PLUGIN" => { "dsn" => "dbi:SQLite:dbname=%s", "user" => "", "password" => "", }, } DBIx-Class-Schema-Config-0.001013/t/01_pass_through.t0000644000175000017500000000451613433032752022070 0ustar catalystcatalyst#!/usr/bin/perl use warnings; use strict; use Test::More; use DBIx::Class::Schema::Config; my $tests = [ { put => { dsn => 'dbi:mysql:somedb', user => 'username', password => 'password', }, get => { dsn => 'dbi:mysql:somedb', user => 'username', password => 'password', }, title => "Hashref connections work.", }, { put => [ 'dbi:mysql:somedb', 'username', 'password' ], get => { dsn => 'dbi:mysql:somedb', user => 'username', password => 'password', }, title => "Array connections work.", }, { put => [ 'DATABASE' ], get => { dsn => 'DATABASE', user => undef, password => undef }, title => "DSN gets the first element name.", }, { put => [ 'dbi:mysql:somedb', 'username', 'password', { PrintError => 1 } ], get => { dsn => 'dbi:mysql:somedb', user => 'username', password => 'password', PrintError => 1, }, title => "Normal option hashes pass through.", }, { put => [ 'DATABASE', 'USERNAME', { hostname => 'hostname' } ], get => { dsn => 'DATABASE', user => 'USERNAME', hostname => 'hostname' }, title => "Ensure (string, string, hashref) format works correctly.", }, { put => [ 'DATABASE', 'USERNAME', 'PASSWORD', { hostname => 'hostname' } ], get => { dsn => 'DATABASE', user => 'USERNAME', password => 'PASSWORD', hostname => 'hostname' }, title => "Ensure (string, string, string, hashref) format works correctly.", }, { put => [ 'DATABASE', 'U', 'P', { foo => "bar" }, { hostname => 'hostname' } ], get => { dsn => 'DATABASE', user => 'U', password => 'P', foo => "bar", hostname => 'hostname' }, title => "Ensure (string, string, string, hashref, hashref) format works correctly.", }, ]; for my $test ( @$tests ) { is_deeply( DBIx::Class::Schema::Config->_make_connect_attrs( ref $test->{put} eq 'ARRAY' ? @{$test->{put}} : $test->{put} ), $test->{get}, $test->{title} ); } done_testing; DBIx-Class-Schema-Config-0.001013/t/09_no_modify_config.t0000644000175000017500000000321113433032752022671 0ustar catalystcatalyst#!/usr/bin/perl use warnings; use strict; use Test::More; use DBIx::Class::Schema::Config; { package Config::Any; $INC{"Config/Any.pm"} = __FILE__; sub load_stems { return [ { 'some_file' => { SOME_DATABASE => { dsn => 'dbi:SQLite:dbfile=:memory:', user => 'MyUser', password => 'MyPass', }, AWESOME_DB => { dsn => 'dbi:mysql:dbname=epsilon', user => 'Bravo', password => 'ShiJulIanDav', }, OPTIONS => { dsn => 'dbi:SQLite:dbfile=:memory:', user => 'Happy', password => 'User', TRACE_LEVEL => 5, } }, }, { 'some_other_file' => { SOME_DATABASE => { dsn => 'dbi:mysql:dbname=acronym', user => 'YawnyPants', password => 'WhyDoYouHateUs?', }, }, } ] } } ok my $ref = DBIx::Class::Schema::Config->config; is_deeply( $ref, "Config::Any"->load_stems, "Loaded correct data set." ); is $ref->[0]->{some_file} = undef, undef, "Changed reference returned by config."; is_deeply( DBIx::Class::Schema::Config->config, "Config::Any"->load_stems, "Changes to a ref of ::config's return does not change future invocations." ); done_testing; DBIx-Class-Schema-Config-0.001013/t/07_integration_config_files.t0000644000175000017500000000346713433032752024426 0ustar catalystcatalyst#!/usr/bin/perl use warnings; use strict; use Test::More; use lib 't/lib'; # Tests above t/ use lib 'lib'; # Tests inside t/ use DBIx::Class::Schema::Config::ConfigFiles; # Using a config file. ok my $Schema1 = DBIx::Class::Schema::Config::ConfigFiles->connect('TEST'), "Can connect to the Test Schema."; ok $Schema1->storage->dbh->do( "CREATE TABLE hash ( key text, value text )" ), "Can create table against the raw dbh."; ok $Schema1->resultset('Hash')->create( { key => "Dr", value => "Spaceman" } ), "Can write to the Test Schema."; is $Schema1->resultset('Hash')->find( { key => 'Dr' }, { key => 'key_unique' } )->value, 'Spaceman', "Can read from the Test Schema."; # Pass through of array. ok my $Schema2 = DBIx::Class::Schema::Config::ConfigFiles->connect('dbi:SQLite:dbname=:memory:', '', ''), "Can connect to the Test Schema."; ok $Schema2->storage->dbh->do( "CREATE TABLE hash ( key text, value text )" ), "Can create table against the raw dbh."; ok $Schema2->resultset('Hash')->create( { key => "Dr", value => "Spaceman" } ), "Can write to the Test Schema."; is $Schema2->resultset('Hash')->find( { key => 'Dr' }, { key => 'key_unique' } )->value, 'Spaceman', "Can read from the Test Schema."; # Pass through of hash ok my $Schema3 = DBIx::Class::Schema::Config::ConfigFiles->connect({ dsn => 'dbi:SQLite:dbname=:memory:' }), "Can connect to the Test Schema."; ok $Schema3->storage->dbh->do( "CREATE TABLE hash ( key text, value text )" ), "Can create table against the raw dbh."; ok $Schema3->resultset('Hash')->create( { key => "Dr", value => "Spaceman" } ), "Can write to the Test Schema."; is $Schema3->resultset('Hash')->find( { key => 'Dr' }, { key => 'key_unique' } )->value, 'Spaceman', "Can read from the Test Schema."; done_testing; DBIx-Class-Schema-Config-0.001013/t/08_integration_env.t0000644000175000017500000000401313433032752022554 0ustar catalystcatalyst#!/usr/bin/perl use warnings; use strict; use Test::More; use lib 't/lib'; # Tests above t/ use lib 'lib'; # Tests inside t/ # This test requires that the environment # variable is set at the DB's compile time, # as it would if you ran # $ DBIX_CONFIG_DIR="t/etc/" prove t/08* BEGIN { $ENV{'DBIX_CONFIG_DIR'} = "t/etc/"; require DBIx::Class::Schema::Config::ENV; DBIx::Class::Schema::Config::ENV->import(); } # Using a config file. ok my $Schema1 = DBIx::Class::Schema::Config::ENV->connect('TEST'), "Can connect to the Test Schema."; ok $Schema1->storage->dbh->do( "CREATE TABLE hash ( key text, value text )" ), "Can create table against the raw dbh."; ok $Schema1->resultset('Hash')->create( { key => "Dr", value => "Spaceman" } ), "Can write to the Test Schema."; is $Schema1->resultset('Hash')->find( { key => 'Dr' }, { key => 'key_unique' } )->value, 'Spaceman', "Can read from the Test Schema."; # Pass through of array. ok my $Schema2 = DBIx::Class::Schema::Config::ENV->connect('dbi:SQLite:dbname=:memory:', '', ''), "Can connect to the Test Schema."; ok $Schema2->storage->dbh->do( "CREATE TABLE hash ( key text, value text )" ), "Can create table against the raw dbh."; ok $Schema2->resultset('Hash')->create( { key => "Dr", value => "Spaceman" } ), "Can write to the Test Schema."; is $Schema2->resultset('Hash')->find( { key => 'Dr' }, { key => 'key_unique' } )->value, 'Spaceman', "Can read from the Test Schema."; # Pass through of hash ok my $Schema3 = DBIx::Class::Schema::Config::ENV->connect({ dsn => 'dbi:SQLite:dbname=:memory:' }), "Can connect to the Test Schema."; ok $Schema3->storage->dbh->do( "CREATE TABLE hash ( key text, value text )" ), "Can create table against the raw dbh."; ok $Schema3->resultset('Hash')->create( { key => "Dr", value => "Spaceman" } ), "Can write to the Test Schema."; is $Schema3->resultset('Hash')->find( { key => 'Dr' }, { key => 'key_unique' } )->value, 'Spaceman', "Can read from the Test Schema."; done_testing; DBIx-Class-Schema-Config-0.001013/t/05_integration_plugin.t0000644000175000017500000000344313433032752023265 0ustar catalystcatalyst#!/usr/bin/perl use warnings; use strict; use Test::More; use lib 't/lib'; # Tests above t/ use lib 'lib'; # Tests inside t/ use DBIx::Class::Schema::Config::Plugin; # Using a config file. ok my $Schema1 = DBIx::Class::Schema::Config::Plugin->connect('TEST'), "Can connect to the Test Schema."; ok $Schema1->storage->dbh->do( "CREATE TABLE hash ( key text, value text )" ), "Can create table against the raw dbh."; ok $Schema1->resultset('Hash')->create( { key => "Dr", value => "Spaceman" } ), "Can write to the Test Schema."; is $Schema1->resultset('Hash')->find( { key => 'Dr' }, { key => 'key_unique' } )->value, 'Spaceman', "Can read from the Test Schema."; # Pass through of array. ok my $Schema2 = DBIx::Class::Schema::Config::Plugin->connect('dbi:SQLite:dbname=:memory:', '', ''), "Can connect to the Test Schema."; ok $Schema2->storage->dbh->do( "CREATE TABLE hash ( key text, value text )" ), "Can create table against the raw dbh."; ok $Schema2->resultset('Hash')->create( { key => "Dr", value => "Spaceman" } ), "Can write to the Test Schema."; is $Schema2->resultset('Hash')->find( { key => 'Dr' }, { key => 'key_unique' } )->value, 'Spaceman', "Can read from the Test Schema."; # Pass through of hash ok my $Schema3 = DBIx::Class::Schema::Config::Plugin->connect({ dsn => 'dbi:SQLite:dbname=:memory:' }), "Can connect to the Test Schema."; ok $Schema3->storage->dbh->do( "CREATE TABLE hash ( key text, value text )" ), "Can create table against the raw dbh."; ok $Schema3->resultset('Hash')->create( { key => "Dr", value => "Spaceman" } ), "Can write to the Test Schema."; is $Schema3->resultset('Hash')->find( { key => 'Dr' }, { key => 'key_unique' } )->value, 'Spaceman', "Can read from the Test Schema."; done_testing; DBIx-Class-Schema-Config-0.001013/t/04_integration_test.t0000644000175000017500000000707113433032752022746 0ustar catalystcatalyst#!/usr/bin/perl use warnings; use strict; use Test::More; use lib 't/lib'; # Tests above t/ use lib 'lib'; # Tests inside t/ use DBIx::Class::Schema::Config::Test; # Using a config file. my $expected_config = [ { 't/etc/config.perl' => { 'TEST' => { 'password' => '', 'dsn' => 'dbi:SQLite:dbname=:memory:', 'user' => '' }, 'PLUGIN' => { 'password' => '', 'dsn' => 'dbi:SQLite:dbname=%s', 'user' => '' } } } ]; is_deeply(DBIx::Class::Schema::Config::Test->config, $expected_config, 'config from class accessor matches as expected - loaded before connect'); ok my $Schema1 = DBIx::Class::Schema::Config::Test->connect('TEST'), "Can connect to the Test Schema."; ok $Schema1->storage->dbh->do( "CREATE TABLE hash ( key text, value text )" ), "Can create table against the raw dbh."; ok $Schema1->resultset('Hash')->create( { key => "Dr", value => "Spaceman" } ), "Can write to the Test Schema."; is $Schema1->resultset('Hash')->find( { key => 'Dr' }, { key => 'key_unique' } )->value, 'Spaceman', "Can read from the Test Schema."; # Pass through of array. ok my $Schema2 = DBIx::Class::Schema::Config::Test->connect('dbi:SQLite:dbname=:memory:', '', ''), "Can connect to the Test Schema."; ok $Schema2->storage->dbh->do( "CREATE TABLE hash ( key text, value text )" ), "Can create table against the raw dbh."; ok $Schema2->resultset('Hash')->create( { key => "Dr", value => "Spaceman" } ), "Can write to the Test Schema."; is $Schema2->resultset('Hash')->find( { key => 'Dr' }, { key => 'key_unique' } )->value, 'Spaceman', "Can read from the Test Schema."; # Pass through of hash ok my $Schema3 = DBIx::Class::Schema::Config::Test->connect({ dsn => 'dbi:SQLite:dbname=:memory:' }), "Can connect to the Test Schema."; ok $Schema3->storage->dbh->do( "CREATE TABLE hash ( key text, value text )" ), "Can create table against the raw dbh."; ok $Schema3->resultset('Hash')->create( { key => "Dr", value => "Spaceman" } ), "Can write to the Test Schema."; is $Schema3->resultset('Hash')->find( { key => 'Dr' }, { key => 'key_unique' } )->value, 'Spaceman', "Can read from the Test Schema."; # Pass through of code reference. ok my $Schema4 = DBIx::Class::Schema::Config::Test->connect( sub { DBI->connect( 'dbi:SQLite:dbname=:memory:', undef, undef, { RaiseError => 1 } ) } ), "Can connect to the Test Schema."; ok $Schema4->storage->dbh->do( "CREATE TABLE hash ( key text, value text )" ), "Can create table against the raw dbh."; ok $Schema4->resultset('Hash')->create( { key => "Dr", value => "Spaceman" } ), "Can write to the Test Schema."; is $Schema4->resultset('Hash')->find( { key => 'Dr' }, { key => 'key_unique' } )->value, 'Spaceman', "Can read from the Test Schema."; # dbh_maker functions as one would expect. ok my $Schema5 = DBIx::Class::Schema::Config::Test->connect({ dbh_maker => sub { DBI->connect( 'dbi:SQLite:dbname=:memory:', undef, undef, { RaiseError => 1 } ) }, }), "Can connect to the Test Schema."; ok $Schema5->storage->dbh->do( "CREATE TABLE hash ( key text, value text )" ), "Can create table against the raw dbh."; ok $Schema5->resultset('Hash')->create( { key => "Dr", value => "Spaceman" } ), "Can write to the Test Schema."; is $Schema5->resultset('Hash')->find( { key => 'Dr' }, { key => 'key_unique' } )->value, 'Spaceman', "Can read from the Test Schema."; done_testing; DBIx-Class-Schema-Config-0.001013/t/lib/0000755000175000017500000000000013434277721017445 5ustar catalystcatalystDBIx-Class-Schema-Config-0.001013/t/lib/DBIx/0000755000175000017500000000000013434277721020233 5ustar catalystcatalystDBIx-Class-Schema-Config-0.001013/t/lib/DBIx/Class/0000755000175000017500000000000013434277721021300 5ustar catalystcatalystDBIx-Class-Schema-Config-0.001013/t/lib/DBIx/Class/Schema/0000755000175000017500000000000013434277721022500 5ustar catalystcatalystDBIx-Class-Schema-Config-0.001013/t/lib/DBIx/Class/Schema/Config/0000755000175000017500000000000013434277721023705 5ustar catalystcatalystDBIx-Class-Schema-Config-0.001013/t/lib/DBIx/Class/Schema/Config/ConfigFiles/0000755000175000017500000000000013434277721026075 5ustar catalystcatalystDBIx-Class-Schema-Config-0.001013/t/lib/DBIx/Class/Schema/Config/ConfigFiles/Hash.pm0000644000175000017500000000075213433032752027312 0ustar catalystcatalystpackage DBIx::Class::Schema::Config::ConfigFiles::Hash; use strict; use warnings; use base 'DBIx::Class'; __PACKAGE__->load_components("Core"); __PACKAGE__->table("hash"); __PACKAGE__->add_columns( "key", { data_type => "text", default_value => undef, is_nullable => 0, size => undef, }, "value", { data_type => "text", default_value => undef, is_nullable => 0, size => undef, }, ); __PACKAGE__->add_unique_constraint("key_unique", ["key"]); 1; DBIx-Class-Schema-Config-0.001013/t/lib/DBIx/Class/Schema/Config/Test/0000755000175000017500000000000013434277721024624 5ustar catalystcatalystDBIx-Class-Schema-Config-0.001013/t/lib/DBIx/Class/Schema/Config/Test/Hash.pm0000644000175000017500000000074313433032752026041 0ustar catalystcatalystpackage DBIx::Class::Schema::Config::Test::Hash; use strict; use warnings; use base 'DBIx::Class'; __PACKAGE__->load_components("Core"); __PACKAGE__->table("hash"); __PACKAGE__->add_columns( "key", { data_type => "text", default_value => undef, is_nullable => 0, size => undef, }, "value", { data_type => "text", default_value => undef, is_nullable => 0, size => undef, }, ); __PACKAGE__->add_unique_constraint("key_unique", ["key"]); 1; DBIx-Class-Schema-Config-0.001013/t/lib/DBIx/Class/Schema/Config/ENV.pm0000644000175000017500000000021513433032752024661 0ustar catalystcatalystpackage DBIx::Class::Schema::Config::ENV; use strict; use warnings; use base 'DBIx::Class::Schema::Config'; __PACKAGE__->load_classes; 1; DBIx-Class-Schema-Config-0.001013/t/lib/DBIx/Class/Schema/Config/Plugin/0000755000175000017500000000000013434277721025143 5ustar catalystcatalystDBIx-Class-Schema-Config-0.001013/t/lib/DBIx/Class/Schema/Config/Plugin/Hash.pm0000644000175000017500000000074513433032752026362 0ustar catalystcatalystpackage DBIx::Class::Schema::Config::Plugin::Hash; use strict; use warnings; use base 'DBIx::Class'; __PACKAGE__->load_components("Core"); __PACKAGE__->table("hash"); __PACKAGE__->add_columns( "key", { data_type => "text", default_value => undef, is_nullable => 0, size => undef, }, "value", { data_type => "text", default_value => undef, is_nullable => 0, size => undef, }, ); __PACKAGE__->add_unique_constraint("key_unique", ["key"]); 1; DBIx-Class-Schema-Config-0.001013/t/lib/DBIx/Class/Schema/Config/Test.pm0000644000175000017500000000030313433032752025146 0ustar catalystcatalystpackage DBIx::Class::Schema::Config::Test; use strict; use warnings; use base 'DBIx::Class::Schema::Config'; __PACKAGE__->config_paths( [ ( 't/etc/config' ) ] ); __PACKAGE__->load_classes; 1; DBIx-Class-Schema-Config-0.001013/t/lib/DBIx/Class/Schema/Config/ConfigFiles.pm0000644000175000017500000000031713433032752026424 0ustar catalystcatalystpackage DBIx::Class::Schema::Config::ConfigFiles; use strict; use warnings; use base 'DBIx::Class::Schema::Config'; __PACKAGE__->config_files( [ ( 't/etc/config.perl' ) ] ); __PACKAGE__->load_classes; 1; DBIx-Class-Schema-Config-0.001013/t/lib/DBIx/Class/Schema/Config/ENV/0000755000175000017500000000000013434277721024335 5ustar catalystcatalystDBIx-Class-Schema-Config-0.001013/t/lib/DBIx/Class/Schema/Config/ENV/Hash.pm0000644000175000017500000000074213433032752025551 0ustar catalystcatalystpackage DBIx::Class::Schema::Config::ENV::Hash; use strict; use warnings; use base 'DBIx::Class'; __PACKAGE__->load_components("Core"); __PACKAGE__->table("hash"); __PACKAGE__->add_columns( "key", { data_type => "text", default_value => undef, is_nullable => 0, size => undef, }, "value", { data_type => "text", default_value => undef, is_nullable => 0, size => undef, }, ); __PACKAGE__->add_unique_constraint("key_unique", ["key"]); 1; DBIx-Class-Schema-Config-0.001013/t/lib/DBIx/Class/Schema/Config/Plugin.pm0000644000175000017500000000060413433032752025471 0ustar catalystcatalystpackage DBIx::Class::Schema::Config::Plugin; use strict; use warnings; use base 'DBIx::Class::Schema::Config'; __PACKAGE__->config_paths( [ ( 't/etc/config' ) ] ); sub filter_loaded_credentials { my ( $class, $new, $orig ) = @_; if ( $new->{dsn} =~ /\%s/ ) { $new->{dsn} = sprintf($new->{dsn}, $orig->{dbname}); } return $new; } __PACKAGE__->load_classes; 1; DBIx-Class-Schema-Config-0.001013/t/02_load_credentials.t0000644000175000017500000001263013433032752022653 0ustar catalystcatalyst#!/usr/bin/perl use warnings; use strict; use Test::More; use DBIx::Class::Schema::Config; { package Config::Any; $INC{"Config/Any.pm"} = __FILE__; sub load_stems { return [ { 'some_file' => { SOME_DATABASE => { dsn => 'dbi:SQLite:dbfile=:memory:', user => 'MyUser', password => 'MyPass', }, AWESOME_DB => { dsn => 'dbi:mysql:dbname=epsilon', user => 'Bravo', password => 'ShiJulIanDav', }, OPTIONS => { dsn => 'dbi:SQLite:dbfile=:memory:', user => 'Happy', password => 'User', TRACE_LEVEL => 5, } }, }, { 'some_other_file' => { SOME_DATABASE => { dsn => 'dbi:mysql:dbname=acronym', user => 'YawnyPants', password => 'WhyDoYouHateUs?', }, }, } ] } } my $tests = [ { put => { dsn => 'SOME_DATABASE', user => '', password => '' }, get => { dsn => 'dbi:SQLite:dbfile=:memory:', user => 'MyUser', password => 'MyPass', }, title => "Get DB info from hashref.", }, { put => [ 'SOME_DATABASE' ], get => { dsn => 'dbi:SQLite:dbfile=:memory:', user => 'MyUser', password => 'MyPass', }, title => "Get DB info from array.", }, { put => { dsn => 'AWESOME_DB' }, get => { dsn => 'dbi:mysql:dbname=epsilon', user => 'Bravo', password => 'ShiJulIanDav', }, title => "Get DB from hashref without user and pass.", }, { put => [ 'dbi:mysql:dbname=foo', 'username', 'password' ], get => { dsn => 'dbi:mysql:dbname=foo', user => 'username', password => 'password', }, title => "Pass through of normal ->connect as array.", }, { put => { dsn => 'dbi:mysql:dbname=foo', user => 'username', password => 'password' }, get => { dsn => 'dbi:mysql:dbname=foo', user => 'username', password => 'password', }, title => "Pass through of normal ->connect as hashref.", }, { put => [ 'OPTIONS' ], get => { dsn => 'dbi:SQLite:dbfile=:memory:', user => 'Happy', password => 'User', TRACE_LEVEL => 5, }, title => "Default loading", }, { put => [ 'OPTIONS', undef, undef, { TRACE_LEVEL => 10 } ], get => { dsn => 'dbi:SQLite:dbfile=:memory:', user => 'Happy', password => 'User', TRACE_LEVEL => 10, }, title => "Override of replaced key works.", }, { put => [ 'OPTIONS', undef, undef, { TRACE_LEVEL => 10, MAGIC => 1 } ], get => { dsn => 'dbi:SQLite:dbfile=:memory:', user => 'Happy', password => 'User', TRACE_LEVEL => 10, MAGIC => 1, }, title => "Override for non-replaced key works.", }, { put => [ 'OPTIONS', { TRACE_LEVEL => 10, MAGIC => 1 } ], get => { dsn => 'dbi:SQLite:dbfile=:memory:', user => 'Happy', password => 'User', TRACE_LEVEL => 10, MAGIC => 1, }, title => "Override for non-replaced key works, without undefing", }, { put => [ 'OPTIONS', "Foobar", undef, { TRACE_LEVEL => 10 } ], get => { dsn => 'dbi:SQLite:dbfile=:memory:', user => 'Foobar', password => 'User', TRACE_LEVEL => 10, }, title => "Overriding the username works.", }, { put => [ 'OPTIONS', "Foobar", { TRACE_LEVEL => 10 } ], get => { dsn => 'dbi:SQLite:dbfile=:memory:', user => 'Foobar', password => 'User', TRACE_LEVEL => 10, }, title => "Overriding the username works without undefing password.", }, { put => [ 'OPTIONS', undef, "Foobar", { TRACE_LEVEL => 10 } ], get => { dsn => 'dbi:SQLite:dbfile=:memory:', user => 'Happy', password => 'Foobar', TRACE_LEVEL => 10, }, title => "Overriding the password works.", }, { put => [ 'OPTIONS', "BleeBaz", "Foobar", { TRACE_LEVEL => 10 } ], get => { dsn => 'dbi:SQLite:dbfile=:memory:', user => 'BleeBaz', password => 'Foobar', TRACE_LEVEL => 10, }, title => "Overriding the user and password works.", }, ]; for my $test ( @$tests ) { is_deeply( DBIx::Class::Schema::Config->load_credentials( DBIx::Class::Schema::Config->_make_connect_attrs( ref $test->{put} eq 'ARRAY' ? @{$test->{put}} : $test->{put}) ), $test->{get}, $test->{title} ); } done_testing; DBIx-Class-Schema-Config-0.001013/META.yml0000644000175000017500000000140313434277654017710 0ustar catalystcatalyst--- abstract: 'Credential Management for DBIx::Class' author: - 'Kaitlyn Parkhurst (SymKat) I<> ( Blog: L )' build_requires: Config::Any: 0.23 DBD::SQLite: 0 ExtUtils::MakeMaker: 6.36 Test::More: 0.42 configure_requires: ExtUtils::MakeMaker: 6.36 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.19' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: DBIx-Class-Schema-Config no_index: directory: - inc - t requires: Config::Any: 0.23 DBIx::Class: 0.08100 File::HomeDir: 0 Hash::Merge: 0 Storable: 0 namespace::clean: 0 perl: 5.005 resources: license: http://dev.perl.org/licenses/ version: 0.001013 DBIx-Class-Schema-Config-0.001013/lib/0000755000175000017500000000000013434277721017202 5ustar catalystcatalystDBIx-Class-Schema-Config-0.001013/lib/DBIx/0000755000175000017500000000000013434277721017770 5ustar catalystcatalystDBIx-Class-Schema-Config-0.001013/lib/DBIx/Class/0000755000175000017500000000000013434277721021035 5ustar catalystcatalystDBIx-Class-Schema-Config-0.001013/lib/DBIx/Class/Schema/0000755000175000017500000000000013434277721022235 5ustar catalystcatalystDBIx-Class-Schema-Config-0.001013/lib/DBIx/Class/Schema/Config.pm0000644000175000017500000003146613434277075024014 0ustar catalystcatalystpackage DBIx::Class::Schema::Config; use 5.005; use warnings; use strict; use base 'DBIx::Class::Schema'; use File::HomeDir; use Storable qw( dclone ); use Hash::Merge qw( merge ); use namespace::clean; our $VERSION = '0.001013'; # 0.1.13 $VERSION = eval $VERSION; sub connection { my ( $class, @info ) = @_; if ( ref($info[0]) eq 'CODE' ) { return $class->next::method( @info ); } my $attrs = $class->_make_connect_attrs(@info); # We will not load credentials for someone who uses dbh_maker, # however we will pass their request through. return $class->next::method( $attrs ) if defined $attrs->{dbh_maker}; # Take responsibility for passing through normal-looking # credentials. $attrs = $class->load_credentials($attrs) unless $attrs->{dsn} =~ /dbi:/i; return $class->next::method( $attrs ); } # Normalize arguments into a single hash. If we get a single hashref, # return it. # Check if $user and $pass are hashes to support things like # ->connect( 'CONFIG_FILE', { hostname => 'db.foo.com' } ); sub _make_connect_attrs { my ( $class, $dsn, $user, $pass, $dbi_attr, $extra_attr ) = @_; return $dsn if ref $dsn eq 'HASH'; return { dsn => $dsn, %{ref $user eq 'HASH' ? $user : { user => $user }}, %{ref $pass eq 'HASH' ? $pass : { password => $pass }}, %{$dbi_attr || {} }, %{ $extra_attr || {} } }; } # Cache the loaded configuration. sub config { my ( $class ) = @_; if ( ! $class->_config ) { $class->_config( $class->_load_config ); } return dclone( $class->_config ); } sub _load_config { my ( $class ) = @_; require Config::Any; # Only loaded if we need to load credentials. # If we have ->config_files, we'll use those and load_files # instead of the default load_stems. my %cf_opts = ( use_ext => 1 ); return @{$class->config_files} ? Config::Any->load_files({ files => $class->config_files, %cf_opts }) : Config::Any->load_stems({ stems => $class->config_paths, %cf_opts }); } sub load_credentials { my ( $class, $connect_args ) = @_; # While ->connect is responsible for returning normal-looking # credential information, we do it here as well so that it can be # independently unit tested. return $connect_args if $connect_args->{dsn} =~ /^dbi:/i; return $class->filter_loaded_credentials( $class->_find_credentials( $connect_args, $class->config ), $connect_args ); } # This will look through the data structure returned by Config::Any # and return the first instance of the database credentials it can # find. sub _find_credentials { my ( $class, $connect_args, $ConfigAny ) = @_; for my $cfile ( @$ConfigAny ) { for my $filename ( keys %$cfile ) { for my $database ( keys %{$cfile->{$filename}} ) { if ( $database eq $connect_args->{dsn} ) { return $cfile->{$filename}->{$database}; } } } } } sub get_env_vars { return $ENV{DBIX_CONFIG_DIR} . "/dbic" if exists $ENV{DBIX_CONFIG_DIR}; return (); } # Intended to be sub-classed, the default behavior is to # overwrite the loaded configuration with any specified # configuration from the connect() call, with the exception # of the DSN itself. sub filter_loaded_credentials { my ( $class, $new, $old ) = @_; local $old->{password}, delete $old->{password} unless $old->{password}; local $old->{user}, delete $old->{user} unless $old->{user}; local $old->{dsn}, delete $old->{dsn}; return merge( $old, $new ); }; __PACKAGE__->mk_classaccessor('config_paths'); __PACKAGE__->mk_classaccessor('config_files'); __PACKAGE__->mk_classaccessor('_config'); __PACKAGE__->config_paths([( get_env_vars(), './dbic', File::HomeDir->my_home . '/.dbic', '/etc/dbic')]); __PACKAGE__->config_files([ ] ); 1; =encoding UTF-8 =head1 NAME DBIx::Class::Schema::Config - Credential Management for DBIx::Class =head1 DESCRIPTION DBIx::Class::Schema::Config is a subclass of DBIx::Class::Schema that allows the loading of credentials & configuration from a file. The actual code itself would only need to know about the name used in the configuration file. This aims to make it simpler for operations teams to manage database credentials. A simple tutorial that compliments this documentation and explains converting an existing DBIx::Class Schema to use this software to manage credentials can be found at L =head1 SYNOPSIS /etc/dbic.yaml MY_DATABASE: dsn: "dbi:Pg:host=localhost;database=blog" user: "TheDoctor" password: "dnoPydoleM" TraceLevel: 1 package My::Schema use warnings; use strict; use base 'DBIx::Class::Schema::Config'; __PACKAGE__->load_namespaces; package My::Code; use warnings; use strict; use My::Schema; my $schema = My::Schema->connect('MY_DATABASE'); # arbitrary config access from anywhere in your $app my $level = My::Schema->config->{TraceLevel}; =head1 CONFIG FILES This module will load the files in the following order if they exist: =over 4 =item * C<$ENV{DBIX_CONFIG_DIR}> . '/dbic', C<$ENV{DBIX_CONFIG_DIR}> can be configured at run-time, for instance: DBIX_CONFIG_DIR="/var/local/" ./my_program.pl =item * ./dbic.* =item * ~/.dbic.* =item * /etc/dbic.* =back The files should have an extension that L recognizes, for example /etc/dbic.B. NOTE: The first available credential will be used. Therefore I in ~/.dbic.yaml will only be looked at if it was not found in ./dbic.yaml. If there are duplicates in one file (such that DATABASE is listed twice in ~/.dbic.yaml,) the first configuration will be used. =head1 CHANGE CONFIG PATH Use C<__PACKAGE__-Econfig_paths([( '/file/stub', '/var/www/etc/dbic')]);> to change the paths that are searched. For example: package My::Schema use warnings; use strict; use base 'DBIx::Class::Schema::Config'; __PACKAGE__->config_paths([( '/var/www/secret/dbic', '/opt/database' )]); The above code would have I and I searched, in that order. As above, the first credentials found would be used. This will replace the files originally searched for, not add to them. =head1 USE SPECIFIC CONFIG FILES If you would rather explicitly state the configuration files you want loaded, you can use the class accessor C instead. package My::Schema use warnings; use strict; use base 'DBIx::Class::Schema::Config'; __PACKAGE__->config_files([( '/var/www/secret/dbic.yaml', '/opt/database.yaml' )]); This will check the files, C, and C in the same way as C, however it will only check the specific files, instead of checking for each extension that L supports. You MUST use the extension that corresponds to the file type you are loading. See L for information on supported file types and extension mapping. =head1 ACCESSING THE CONFIG FILE The config file is stored via the C<__PACKAGE__-Econfig> accessor, which can be called as both a class and instance method. =head1 OVERRIDING The API has been designed to be simple to override if you have additional needs in loading DBIC configurations. =head2 Overriding Connection Configuration Simple cases where one wants to replace specific configuration tokens can be given as extra parameters in the ->connect call. For example, suppose we have the database MY_DATABASE from above: MY_DATABASE: dsn: "dbi:Pg:host=localhost;database=blog" user: "TheDoctor" password: "dnoPydoleM" TraceLevel: 1 If you’d like to replace the username with “Eccleston” and we’d like to turn PrintError off. The following connect line would achieve this: $Schema->connect(“MY_DATABASE”, “Eccleston”, undef, { PrintError => 0 } ); The name of the connection to load from the configuration file is still given as the first argument, while other arguments may be given exactly as you would for any other call to C. Historical Note: This class accepts numerous ways to connect to DBIC that would otherwise not be valid. These connection methods are discouraged but tested for and kept for compatibility with earlier versions. For valid ways of connecting to DBIC please see L =head2 filter_loaded_credentials Override this function if you want to change the loaded credentials before they are passed to DBIC. This is useful for use-cases that include decrypting encrypted passwords or making programmatic changes to the configuration before using it. sub filter_loaded_credentials { my ( $class, $loaded_credentials, $connect_args ) = @_; ... return $loaded_credentials; } C<$loaded_credentials> is the structure after it has been loaded from the configuration file. In this case, C<$loaded_credentials-E{user}> eq B and C<$loaded_credentials-E{dsn}> eq B. C<$connect_args> is the structure originally passed on C<-Econnect()> after it has been turned into a hash. For instance, C<-Econnect('DATABASE', 'USERNAME')> will result in C<$connect_args-E{dsn}> eq B and C<$connect_args-E{user}> eq B. Additional parameters can be added by appending a hashref, to the connection call, as an example, C<-Econnect( 'CONFIG', { hostname =E "db.foo.com" } );> will give C<$connect_args> a structure like C<{ dsn =E 'CONFIG', hostname =E "db.foo.com" }>. For instance, if you want to use hostnames when you make the initial connection to DBIC and are using the configuration primarily for usernames, passwords and other configuration data, you can create a config like the following: DATABASE: dsn: "DBI:mysql:database=students;host=%s;port=3306" user: "WalterWhite" password: "relykS" In your Schema class, you could include the following: package My::Schema use warnings; use strict; use base 'DBIx::Class::Schema::Config'; sub filter_loaded_credentials { my ( $class, $loaded_credentials, $connect_args ) = @_; if ( $loaded_credentials->{dsn} =~ /\%s/ ) { $loaded_credentials->{dsn} = sprintf( $loaded_credentials->{dsn}, $connect_args->{hostname}); } } __PACKAGE__->load_classes; 1; Then the connection could be done with C<$Schema-Econnect('DATABASE', { hostname => 'my.hostname.com' });> See L for more complex changes that require changing how the configuration itself is loaded. =head2 load_credentials Override this function to change the way that L loads credentials. The function takes the class name, as well as a hashref. If you take the route of having C<-Econnect('DATABASE')> used as a key for whatever configuration you are loading, I would be C<$config-E{dsn}> Some::Schema->connect( "SomeTarget", "Yuri", "Yawny", { TraceLevel => 1 } ); Would result in the following data structure as $config in C: { dsn => "SomeTarget", user => "Yuri", password => "Yawny", TraceLevel => 1, } Currently, load_credentials will NOT be called if the first argument to C<-Econnect()> looks like a valid DSN. This is determined by match the DSN with C. The function should return the same structure. For instance: package My::Schema use warnings; use strict; use base 'DBIx::Class::Schema::Config'; use LWP::Simple; use JSON # Load credentials from internal web server. sub load_credentials { my ( $class, $config ) = @_; return decode_json( get( "http://someserver.com/v1.0/database?key=somesecret&db=" . $config->{dsn} )); } __PACKAGE__->load_classes; =head1 AUTHOR Kaitlyn Parkhurst (SymKat) Isymkat@symkat.comE> ( Blog: L ) =head1 CONTRIBUTORS =over 4 =item * Matt S. Trout (mst) Imst@shadowcat.co.ukE> =item * Peter Rabbitson (ribasushi) Iribasushi@cpan.orgE> =item * Christian Walde (Mihtaldu) Iwalde.christian@googlemail.comE> =item * Dagfinn Ilmari Mannsåker (ilmari) Iilmari@ilmari.orgE> =item * Matthew Phillips (mattp) Imattp@cpan.orgE> =back =head1 COPYRIGHT AND LICENSE This library is free software and may be distributed under the same terms as perl itself. =head1 AVAILABILITY The latest version of this software is available at L =cut DBIx-Class-Schema-Config-0.001013/Makefile.PL0000644000175000017500000000127013434276747020415 0ustar catalystcatalystBEGIN { push @INC, '.' unless $INC[-1] eq '.' } use inc::Module::Install; # Define metadata name 'DBIx-Class-Schema-Config'; all_from 'lib/DBIx/Class/Schema/Config.pm'; license 'perl'; # Specific dependencies requires 'DBIx::Class' => '0.08100'; requires 'Config::Any' => '0.23'; requires 'File::HomeDir' => '0'; requires 'Hash::Merge' => '0'; requires 'namespace::clean' => '0'; requires 'Storable' => '0'; test_requires 'Test::More' => '0.42'; test_requires 'DBD::SQLite' => '0'; test_requires 'Config::Any' => '0.23'; WriteAll;