@@ -1,33 +0,0 @@
-use strict;
-use warnings;
-use Module::Build;
-
-my $builder = Module::Build->new(
- module_name => 'SQL::Abstract::More',
- license => 'perl',
- dist_author => q{Laurent Dami <laurent.dami@justice.ge.ch>},
- dist_version_from => 'lib/SQL/Abstract/More.pm',
- requires => {
- 'MRO::Compat' => 0,
- 'SQL::Abstract' => 1.73,
- 'Params::Validate' => 0,
- 'Scalar::Does' => 0,
- 'parent' => 0,
- 'namespace::clean' => 0,
- },
- build_requires => {
- 'Test::More' => 0,
- 'Test::Exception' => 0,
- 'SQL::Abstract::Test' => 0,
- },
-
- add_to_cleanup => [ 'SQL-Abstract-More-*' ],
- create_makefile_pl => 'traditional',
- meta_merge => {
- resources => {
- repository => 'https://github.com/damil/SQL-Abstract-More',
- }
- },
-);
-
-$builder->create_build_script();
@@ -1,5 +1,34 @@
Revision history for SQL-Abstract-More
+1.23 13.08.2014
+ - bug fix, v1.22 no longer accepted syntax x|alias when x has length 1
+
+1.22 09.08.2014
+ - avoid interference of '|' for column aliases with builtin DBMS operators
+ - also accept new() args as a hashref
+ - run the whole SQLA test suite against SQLAM
+
+1.21 20.04.2014
+ - fix missing test dependency
+ - switch to Module::Install
+
+1.20 18.04.2014
+ - support for -order_by/-limit in update() and delete() (MySQL accepts that!)
+ - -limit => 0 is no longer ignored
+
+1.19 01.02.2014
+ - better implementation for bind values within join specifications
+
+1.18 31.01.2014
+ - added support for bind values (as quoted strings) within join specifications
+
+1.17 22.07.2013
+ - fixed incorrect treatment of -limit for "RowNum" dialect (used by Oracle)
+
+1.16 16.07.2013
+ - fixed doc for join() (description of the return value)
+ - fix for RT 86895 (incorrect treatment of -order_by / -group_by)
+
1.15 18.04.2013
- bind values with types : dropped syntax [$value, \%type] because of
conflicts with "OR" clauses of shape [$condition1, \%condition2]; so
@@ -1,11 +1,25 @@
-Build.PL
-Changes
-MANIFEST
-README
-lib/SQL/Abstract/More.pm
-t/01-sql_abstract_more.t
-t/02-order-by.t
-t/pod.t
-Makefile.PL
-META.yml
-META.json
+Changes
+inc/Module/AutoInstall.pm
+inc/Module/Install.pm
+inc/Module/Install/AutoInstall.pm
+inc/Module/Install/Base.pm
+inc/Module/Install/Can.pm
+inc/Module/Install/Fetch.pm
+inc/Module/Install/Include.pm
+inc/Module/Install/Makefile.pm
+inc/Module/Install/Metadata.pm
+inc/Module/Install/Win32.pm
+inc/Module/Install/WriteAll.pm
+lib/SQL/Abstract/More.pm
+Makefile.PL
+MANIFEST This list of files
+META.yml
+README
+t/01-sql_abstract_more.t
+t/02-order-by.t
+t/03-join_with_constants.t
+t/99_sqla_tests.t
+t/lib/UsurpSQLA.pm
+t/pod.t
+t/rt_084972.t
+t/rt_086895.t
@@ -1,56 +0,0 @@
-{
- "abstract" : "extension of SQL::Abstract with more constructs and more flexible API",
- "author" : [
- "Laurent Dami <laurent.dami@justice.ge.ch>"
- ],
- "dynamic_config" : 1,
- "generated_by" : "Module::Build version 0.4004, CPAN::Meta::Converter version 2.120921",
- "license" : [
- "perl_5"
- ],
- "meta-spec" : {
- "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
- "version" : "2"
- },
- "name" : "SQL-Abstract-More",
- "prereqs" : {
- "build" : {
- "requires" : {
- "SQL::Abstract::Test" : "0",
- "Test::Exception" : "0",
- "Test::More" : "0"
- }
- },
- "configure" : {
- "requires" : {
- "Module::Build" : "0.40"
- }
- },
- "runtime" : {
- "requires" : {
- "MRO::Compat" : "0",
- "Params::Validate" : "0",
- "SQL::Abstract" : "1.73",
- "Scalar::Does" : "0",
- "namespace::clean" : "0",
- "parent" : "0"
- }
- }
- },
- "provides" : {
- "SQL::Abstract::More" : {
- "file" : "lib/SQL/Abstract/More.pm",
- "version" : "1.15"
- }
- },
- "release_status" : "stable",
- "resources" : {
- "license" : [
- "http://dev.perl.org/licenses/"
- ],
- "repository" : {
- "url" : "https://github.com/damil/SQL-Abstract-More"
- }
- },
- "version" : "1.15"
-}
@@ -1,24 +1,29 @@
---
abstract: 'extension of SQL::Abstract with more constructs and more flexible API'
author:
- - 'Laurent Dami <laurent.dami@justice.ge.ch>'
+ - 'Laurent Dami, C<< <laurent.dami at justice.ge.ch> >>'
+ - 'Laurent Dami <dami@cpan.org>'
build_requires:
+ ExtUtils::MakeMaker: 6.59
+ List::MoreUtils: 0
SQL::Abstract::Test: 0
Test::Exception: 0
Test::More: 0
configure_requires:
- Module::Build: 0.40
+ ExtUtils::MakeMaker: 6.59
+ Module::Install: 0
+distribution_type: module
dynamic_config: 1
-generated_by: 'Module::Build version 0.4004, CPAN::Meta::Converter version 2.120921'
-license: perl
+generated_by: 'Module::Install version 1.08'
+license: artistic2
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
name: SQL-Abstract-More
-provides:
- SQL::Abstract::More:
- file: lib/SQL/Abstract/More.pm
- version: 1.15
+no_index:
+ directory:
+ - inc
+ - t
requires:
MRO::Compat: 0
Params::Validate: 0
@@ -26,7 +31,10 @@ requires:
Scalar::Does: 0
namespace::clean: 0
parent: 0
+ perl: 5.8.0
resources:
- license: http://dev.perl.org/licenses/
- repository: https://github.com/damil/SQL-Abstract-More
-version: 1.15
+ bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=SQL-Abstract-More
+ homepage: https://metacpan.org/author/DAMI
+ license: http://www.perlfoundation.org/artistic_license_2_0
+ repository: git://github.com/damil/SQL-Abstract-More.git
+version: 1.23
@@ -1,22 +1,45 @@
-# Note: this file was auto-generated by Module::Build::Compat version 0.4004
-use ExtUtils::MakeMaker;
-WriteMakefile
-(
- 'NAME' => 'SQL::Abstract::More',
- 'VERSION_FROM' => 'lib/SQL/Abstract/More.pm',
- 'PREREQ_PM' => {
- 'MRO::Compat' => 0,
- 'Params::Validate' => 0,
- 'SQL::Abstract' => '1.73',
- 'SQL::Abstract::Test' => 0,
- 'Scalar::Does' => 0,
- 'Test::Exception' => 0,
- 'Test::More' => 0,
- 'namespace::clean' => 0,
- 'parent' => 0
- },
- 'INSTALLDIRS' => 'site',
- 'EXE_FILES' => [],
- 'PL_FILES' => {}
-)
-;
+use 5.008;
+use strict;
+use warnings FATAL => 'all';
+use inc::Module::Install;
+
+name 'SQL-Abstract-More';
+all_from 'lib/SQL/Abstract/More.pm';
+author q{Laurent Dami <dami@cpan.org>};
+license 'artistic2';
+
+perl_version 5.008;
+
+tests_recursive('t');
+
+resources (
+ homepage => 'https://metacpan.org/author/DAMI',
+ license => 'http://www.perlfoundation.org/artistic_license_2_0',
+ repository => 'git://github.com/damil/SQL-Abstract-More.git',
+ bugtracker => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=SQL-Abstract-More',
+);
+
+configure_requires (
+ 'Module::Install' => 0,
+);
+
+test_requires (
+ 'Test::More' => 0,
+ 'Test::Exception' => 0,
+ 'SQL::Abstract::Test' => 0,
+ 'List::MoreUtils' => 0,
+);
+
+
+requires (
+ 'MRO::Compat' => 0,
+ 'SQL::Abstract' => 1.73,
+ 'Params::Validate' => 0,
+ 'Scalar::Does' => 0,
+ 'parent' => 0,
+ 'namespace::clean' => 0,
+);
+
+install_as_cpan;
+auto_install;
+WriteAll;
@@ -0,0 +1,930 @@
+#line 1
+package Module::AutoInstall;
+
+use strict;
+use Cwd ();
+use File::Spec ();
+use ExtUtils::MakeMaker ();
+
+use vars qw{$VERSION};
+BEGIN {
+ $VERSION = '1.08';
+}
+
+# special map on pre-defined feature sets
+my %FeatureMap = (
+ '' => 'Core Features', # XXX: deprecated
+ '-core' => 'Core Features',
+);
+
+# various lexical flags
+my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $InstallDepsTarget, $HasCPANPLUS );
+my (
+ $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps,
+ $UpgradeDeps
+);
+my ( $PostambleActions, $PostambleActionsNoTest, $PostambleActionsUpgradeDeps,
+ $PostambleActionsUpgradeDepsNoTest, $PostambleActionsListDeps,
+ $PostambleActionsListAllDeps, $PostambleUsed, $NoTest);
+
+# See if it's a testing or non-interactive session
+_accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN );
+_init();
+
+sub _accept_default {
+ $AcceptDefault = shift;
+}
+
+sub _installdeps_target {
+ $InstallDepsTarget = shift;
+}
+
+sub missing_modules {
+ return @Missing;
+}
+
+sub do_install {
+ __PACKAGE__->install(
+ [
+ $Config
+ ? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
+ : ()
+ ],
+ @Missing,
+ );
+}
+
+# initialize various flags, and/or perform install
+sub _init {
+ foreach my $arg (
+ @ARGV,
+ split(
+ /[\s\t]+/,
+ $ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || ''
+ )
+ )
+ {
+ if ( $arg =~ /^--config=(.*)$/ ) {
+ $Config = [ split( ',', $1 ) ];
+ }
+ elsif ( $arg =~ /^--installdeps=(.*)$/ ) {
+ __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) );
+ exit 0;
+ }
+ elsif ( $arg =~ /^--upgradedeps=(.*)$/ ) {
+ $UpgradeDeps = 1;
+ __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) );
+ exit 0;
+ }
+ elsif ( $arg =~ /^--default(?:deps)?$/ ) {
+ $AcceptDefault = 1;
+ }
+ elsif ( $arg =~ /^--check(?:deps)?$/ ) {
+ $CheckOnly = 1;
+ }
+ elsif ( $arg =~ /^--skip(?:deps)?$/ ) {
+ $SkipInstall = 1;
+ }
+ elsif ( $arg =~ /^--test(?:only)?$/ ) {
+ $TestOnly = 1;
+ }
+ elsif ( $arg =~ /^--all(?:deps)?$/ ) {
+ $AllDeps = 1;
+ }
+ }
+}
+
+# overrides MakeMaker's prompt() to automatically accept the default choice
+sub _prompt {
+ goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault;
+
+ my ( $prompt, $default ) = @_;
+ my $y = ( $default =~ /^[Yy]/ );
+
+ print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] ';
+ print "$default\n";
+ return $default;
+}
+
+# the workhorse
+sub import {
+ my $class = shift;
+ my @args = @_ or return;
+ my $core_all;
+
+ print "*** $class version " . $class->VERSION . "\n";
+ print "*** Checking for Perl dependencies...\n";
+
+ my $cwd = Cwd::cwd();
+
+ $Config = [];
+
+ my $maxlen = length(
+ (
+ sort { length($b) <=> length($a) }
+ grep { /^[^\-]/ }
+ map {
+ ref($_)
+ ? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} )
+ : ''
+ }
+ map { +{@args}->{$_} }
+ grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} }
+ )[0]
+ );
+
+ # We want to know if we're under CPAN early to avoid prompting, but
+ # if we aren't going to try and install anything anyway then skip the
+ # check entirely since we don't want to have to load (and configure)
+ # an old CPAN just for a cosmetic message
+
+ $UnderCPAN = _check_lock(1) unless $SkipInstall || $InstallDepsTarget;
+
+ while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) {
+ my ( @required, @tests, @skiptests );
+ my $default = 1;
+ my $conflict = 0;
+
+ if ( $feature =~ m/^-(\w+)$/ ) {
+ my $option = lc($1);
+
+ # check for a newer version of myself
+ _update_to( $modules, @_ ) and return if $option eq 'version';
+
+ # sets CPAN configuration options
+ $Config = $modules if $option eq 'config';
+
+ # promote every features to core status
+ $core_all = ( $modules =~ /^all$/i ) and next
+ if $option eq 'core';
+
+ next unless $option eq 'core';
+ }
+
+ print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n";
+
+ $modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' );
+
+ unshift @$modules, -default => &{ shift(@$modules) }
+ if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward combatability
+
+ while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) {
+ if ( $mod =~ m/^-(\w+)$/ ) {
+ my $option = lc($1);
+
+ $default = $arg if ( $option eq 'default' );
+ $conflict = $arg if ( $option eq 'conflict' );
+ @tests = @{$arg} if ( $option eq 'tests' );
+ @skiptests = @{$arg} if ( $option eq 'skiptests' );
+
+ next;
+ }
+
+ printf( "- %-${maxlen}s ...", $mod );
+
+ if ( $arg and $arg =~ /^\D/ ) {
+ unshift @$modules, $arg;
+ $arg = 0;
+ }
+
+ # XXX: check for conflicts and uninstalls(!) them.
+ my $cur = _version_of($mod);
+ if (_version_cmp ($cur, $arg) >= 0)
+ {
+ print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n";
+ push @Existing, $mod => $arg;
+ $DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
+ }
+ else {
+ if (not defined $cur) # indeed missing
+ {
+ print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n";
+ }
+ else
+ {
+ # no need to check $arg as _version_cmp ($cur, undef) would satisfy >= above
+ print "too old. ($cur < $arg)\n";
+ }
+
+ push @required, $mod => $arg;
+ }
+ }
+
+ next unless @required;
+
+ my $mandatory = ( $feature eq '-core' or $core_all );
+
+ if (
+ !$SkipInstall
+ and (
+ $CheckOnly
+ or ($mandatory and $UnderCPAN)
+ or $AllDeps
+ or $InstallDepsTarget
+ or _prompt(
+ qq{==> Auto-install the }
+ . ( @required / 2 )
+ . ( $mandatory ? ' mandatory' : ' optional' )
+ . qq{ module(s) from CPAN?},
+ $default ? 'y' : 'n',
+ ) =~ /^[Yy]/
+ )
+ )
+ {
+ push( @Missing, @required );
+ $DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
+ }
+
+ elsif ( !$SkipInstall
+ and $default
+ and $mandatory
+ and
+ _prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', )
+ =~ /^[Nn]/ )
+ {
+ push( @Missing, @required );
+ $DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
+ }
+
+ else {
+ $DisabledTests{$_} = 1 for map { glob($_) } @tests;
+ }
+ }
+
+ if ( @Missing and not( $CheckOnly or $UnderCPAN) ) {
+ require Config;
+ my $make = $Config::Config{make};
+ if ($InstallDepsTarget) {
+ print
+"*** To install dependencies type '$make installdeps' or '$make installdeps_notest'.\n";
+ }
+ else {
+ print
+"*** Dependencies will be installed the next time you type '$make'.\n";
+ }
+
+ # make an educated guess of whether we'll need root permission.
+ print " (You may need to do that as the 'root' user.)\n"
+ if eval '$>';
+ }
+ print "*** $class configuration finished.\n";
+
+ chdir $cwd;
+
+ # import to main::
+ no strict 'refs';
+ *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
+
+ return (@Existing, @Missing);
+}
+
+sub _running_under {
+ my $thing = shift;
+ print <<"END_MESSAGE";
+*** Since we're running under ${thing}, I'll just let it take care
+ of the dependency's installation later.
+END_MESSAGE
+ return 1;
+}
+
+# Check to see if we are currently running under CPAN.pm and/or CPANPLUS;
+# if we are, then we simply let it taking care of our dependencies
+sub _check_lock {
+ return unless @Missing or @_;
+
+ if ($ENV{PERL5_CPANM_IS_RUNNING}) {
+ return _running_under('cpanminus');
+ }
+
+ my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING};
+
+ if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) {
+ return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS');
+ }
+
+ require CPAN;
+
+ if ($CPAN::VERSION > '1.89') {
+ if ($cpan_env) {
+ return _running_under('CPAN');
+ }
+ return; # CPAN.pm new enough, don't need to check further
+ }
+
+ # last ditch attempt, this -will- configure CPAN, very sorry
+
+ _load_cpan(1); # force initialize even though it's already loaded
+
+ # Find the CPAN lock-file
+ my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" );
+ return unless -f $lock;
+
+ # Check the lock
+ local *LOCK;
+ return unless open(LOCK, $lock);
+
+ if (
+ ( $^O eq 'MSWin32' ? _under_cpan() : <LOCK> == getppid() )
+ and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore'
+ ) {
+ print <<'END_MESSAGE';
+
+*** Since we're running under CPAN, I'll just let it take care
+ of the dependency's installation later.
+END_MESSAGE
+ return 1;
+ }
+
+ close LOCK;
+ return;
+}
+
+sub install {
+ my $class = shift;
+
+ my $i; # used below to strip leading '-' from config keys
+ my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } );
+
+ my ( @modules, @installed );
+ while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) {
+
+ # grep out those already installed
+ if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) {
+ push @installed, $pkg;
+ }
+ else {
+ push @modules, $pkg, $ver;
+ }
+ }
+
+ if ($UpgradeDeps) {
+ push @modules, @installed;
+ @installed = ();
+ }
+
+ return @installed unless @modules; # nothing to do
+ return @installed if _check_lock(); # defer to the CPAN shell
+
+ print "*** Installing dependencies...\n";
+
+ return unless _connected_to('cpan.org');
+
+ my %args = @config;
+ my %failed;
+ local *FAILED;
+ if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) {
+ while (<FAILED>) { chomp; $failed{$_}++ }
+ close FAILED;
+
+ my @newmod;
+ while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) {
+ push @newmod, ( $k => $v ) unless $failed{$k};
+ }
+ @modules = @newmod;
+ }
+
+ if ( _has_cpanplus() and not $ENV{PERL_AUTOINSTALL_PREFER_CPAN} ) {
+ _install_cpanplus( \@modules, \@config );
+ } else {
+ _install_cpan( \@modules, \@config );
+ }
+
+ print "*** $class installation finished.\n";
+
+ # see if we have successfully installed them
+ while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
+ if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) {
+ push @installed, $pkg;
+ }
+ elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) {
+ print FAILED "$pkg\n";
+ }
+ }
+
+ close FAILED if $args{do_once};
+
+ return @installed;
+}
+
+sub _install_cpanplus {
+ my @modules = @{ +shift };
+ my @config = _cpanplus_config( @{ +shift } );
+ my $installed = 0;
+
+ require CPANPLUS::Backend;
+ my $cp = CPANPLUS::Backend->new;
+ my $conf = $cp->configure_object;
+
+ return unless $conf->can('conf') # 0.05x+ with "sudo" support
+ or _can_write($conf->_get_build('base')); # 0.04x
+
+ # if we're root, set UNINST=1 to avoid trouble unless user asked for it.
+ my $makeflags = $conf->get_conf('makeflags') || '';
+ if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) {
+ # 0.03+ uses a hashref here
+ $makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST};
+
+ } else {
+ # 0.02 and below uses a scalar
+ $makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' )
+ if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } );
+
+ }
+ $conf->set_conf( makeflags => $makeflags );
+ $conf->set_conf( prereqs => 1 );
+
+
+
+ while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) {
+ $conf->set_conf( $key, $val );
+ }
+
+ my $modtree = $cp->module_tree;
+ while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
+ print "*** Installing $pkg...\n";
+
+ MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall;
+
+ my $success;
+ my $obj = $modtree->{$pkg};
+
+ if ( $obj and _version_cmp( $obj->{version}, $ver ) >= 0 ) {
+ my $pathname = $pkg;
+ $pathname =~ s/::/\\W/;
+
+ foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) {
+ delete $INC{$inc};
+ }
+
+ my $rv = $cp->install( modules => [ $obj->{module} ] );
+
+ if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) {
+ print "*** $pkg successfully installed.\n";
+ $success = 1;
+ } else {
+ print "*** $pkg installation cancelled.\n";
+ $success = 0;
+ }
+
+ $installed += $success;
+ } else {
+ print << ".";
+*** Could not find a version $ver or above for $pkg; skipping.
+.
+ }
+
+ MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall;
+ }
+
+ return $installed;
+}
+
+sub _cpanplus_config {
+ my @config = ();
+ while ( @_ ) {
+ my ($key, $value) = (shift(), shift());
+ if ( $key eq 'prerequisites_policy' ) {
+ if ( $value eq 'follow' ) {
+ $value = CPANPLUS::Internals::Constants::PREREQ_INSTALL();
+ } elsif ( $value eq 'ask' ) {
+ $value = CPANPLUS::Internals::Constants::PREREQ_ASK();
+ } elsif ( $value eq 'ignore' ) {
+ $value = CPANPLUS::Internals::Constants::PREREQ_IGNORE();
+ } else {
+ die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n";
+ }
+ push @config, 'prereqs', $value;
+ } elsif ( $key eq 'force' ) {
+ push @config, $key, $value;
+ } elsif ( $key eq 'notest' ) {
+ push @config, 'skiptest', $value;
+ } else {
+ die "*** Cannot convert option $key to CPANPLUS version.\n";
+ }
+ }
+ return @config;
+}
+
+sub _install_cpan {
+ my @modules = @{ +shift };
+ my @config = @{ +shift };
+ my $installed = 0;
+ my %args;
+
+ _load_cpan();
+ require Config;
+
+ if (CPAN->VERSION < 1.80) {
+ # no "sudo" support, probe for writableness
+ return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) )
+ and _can_write( $Config::Config{sitelib} );
+ }
+
+ # if we're root, set UNINST=1 to avoid trouble unless user asked for it.
+ my $makeflags = $CPAN::Config->{make_install_arg} || '';
+ $CPAN::Config->{make_install_arg} =
+ join( ' ', split( ' ', $makeflags ), 'UNINST=1' )
+ if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } );
+
+ # don't show start-up info
+ $CPAN::Config->{inhibit_startup_message} = 1;
+
+ # set additional options
+ while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) {
+ ( $args{$opt} = $arg, next )
+ if $opt =~ /^(?:force|notest)$/; # pseudo-option
+ $CPAN::Config->{$opt} = $arg;
+ }
+
+ if ($args{notest} && (not CPAN::Shell->can('notest'))) {
+ die "Your version of CPAN is too old to support the 'notest' pragma";
+ }
+
+ local $CPAN::Config->{prerequisites_policy} = 'follow';
+
+ while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
+ MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall;
+
+ print "*** Installing $pkg...\n";
+
+ my $obj = CPAN::Shell->expand( Module => $pkg );
+ my $success = 0;
+
+ if ( $obj and _version_cmp( $obj->cpan_version, $ver ) >= 0 ) {
+ my $pathname = $pkg;
+ $pathname =~ s/::/\\W/;
+
+ foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) {
+ delete $INC{$inc};
+ }
+
+ my $rv = do {
+ if ($args{force}) {
+ CPAN::Shell->force( install => $pkg )
+ } elsif ($args{notest}) {
+ CPAN::Shell->notest( install => $pkg )
+ } else {
+ CPAN::Shell->install($pkg)
+ }
+ };
+
+ $rv ||= eval {
+ $CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, )
+ ->{install}
+ if $CPAN::META;
+ };
+
+ if ( $rv eq 'YES' ) {
+ print "*** $pkg successfully installed.\n";
+ $success = 1;
+ }
+ else {
+ print "*** $pkg installation failed.\n";
+ $success = 0;
+ }
+
+ $installed += $success;
+ }
+ else {
+ print << ".";
+*** Could not find a version $ver or above for $pkg; skipping.
+.
+ }
+
+ MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall;
+ }
+
+ return $installed;
+}
+
+sub _has_cpanplus {
+ return (
+ $HasCPANPLUS = (
+ $INC{'CPANPLUS/Config.pm'}
+ or _load('CPANPLUS::Shell::Default')
+ )
+ );
+}
+
+# make guesses on whether we're under the CPAN installation directory
+sub _under_cpan {
+ require Cwd;
+ require File::Spec;
+
+ my $cwd = File::Spec->canonpath( Cwd::cwd() );
+ my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} );
+
+ return ( index( $cwd, $cpan ) > -1 );
+}
+
+sub _update_to {
+ my $class = __PACKAGE__;
+ my $ver = shift;
+
+ return
+ if _version_cmp( _version_of($class), $ver ) >= 0; # no need to upgrade
+
+ if (
+ _prompt( "==> A newer version of $class ($ver) is required. Install?",
+ 'y' ) =~ /^[Nn]/
+ )
+ {
+ die "*** Please install $class $ver manually.\n";
+ }
+
+ print << ".";
+*** Trying to fetch it from CPAN...
+.
+
+ # install ourselves
+ _load($class) and return $class->import(@_)
+ if $class->install( [], $class, $ver );
+
+ print << '.'; exit 1;
+
+*** Cannot bootstrap myself. :-( Installation terminated.
+.
+}
+
+# check if we're connected to some host, using inet_aton
+sub _connected_to {
+ my $site = shift;
+
+ return (
+ ( _load('Socket') and Socket::inet_aton($site) ) or _prompt(
+ qq(
+*** Your host cannot resolve the domain name '$site', which
+ probably means the Internet connections are unavailable.
+==> Should we try to install the required module(s) anyway?), 'n'
+ ) =~ /^[Yy]/
+ );
+}
+
+# check if a directory is writable; may create it on demand
+sub _can_write {
+ my $path = shift;
+ mkdir( $path, 0755 ) unless -e $path;
+
+ return 1 if -w $path;
+
+ print << ".";
+*** You are not allowed to write to the directory '$path';
+ the installation may fail due to insufficient permissions.
+.
+
+ if (
+ eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt(
+ qq(
+==> Should we try to re-execute the autoinstall process with 'sudo'?),
+ ((-t STDIN) ? 'y' : 'n')
+ ) =~ /^[Yy]/
+ )
+ {
+
+ # try to bootstrap ourselves from sudo
+ print << ".";
+*** Trying to re-execute the autoinstall process with 'sudo'...
+.
+ my $missing = join( ',', @Missing );
+ my $config = join( ',',
+ UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
+ if $Config;
+
+ return
+ unless system( 'sudo', $^X, $0, "--config=$config",
+ "--installdeps=$missing" );
+
+ print << ".";
+*** The 'sudo' command exited with error! Resuming...
+.
+ }
+
+ return _prompt(
+ qq(
+==> Should we try to install the required module(s) anyway?), 'n'
+ ) =~ /^[Yy]/;
+}
+
+# load a module and return the version it reports
+sub _load {
+ my $mod = pop; # method/function doesn't matter
+ my $file = $mod;
+ $file =~ s|::|/|g;
+ $file .= '.pm';
+ local $@;
+ return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 );
+}
+
+# report version without loading a module
+sub _version_of {
+ my $mod = pop; # method/function doesn't matter
+ my $file = $mod;
+ $file =~ s|::|/|g;
+ $file .= '.pm';
+ foreach my $dir ( @INC ) {
+ next if ref $dir;
+ my $path = File::Spec->catfile($dir, $file);
+ next unless -e $path;
+ require ExtUtils::MM_Unix;
+ return ExtUtils::MM_Unix->parse_version($path);
+ }
+ return undef;
+}
+
+# Load CPAN.pm and it's configuration
+sub _load_cpan {
+ return if $CPAN::VERSION and $CPAN::Config and not @_;
+ require CPAN;
+
+ # CPAN-1.82+ adds CPAN::Config::AUTOLOAD to redirect to
+ # CPAN::HandleConfig->load. CPAN reports that the redirection
+ # is deprecated in a warning printed at the user.
+
+ # CPAN-1.81 expects CPAN::HandleConfig->load, does not have
+ # $CPAN::HandleConfig::VERSION but cannot handle
+ # CPAN::Config->load
+
+ # Which "versions expect CPAN::Config->load?
+
+ if ( $CPAN::HandleConfig::VERSION
+ || CPAN::HandleConfig->can('load')
+ ) {
+ # Newer versions of CPAN have a HandleConfig module
+ CPAN::HandleConfig->load;
+ } else {
+ # Older versions had the load method in Config directly
+ CPAN::Config->load;
+ }
+}
+
+# compare two versions, either use Sort::Versions or plain comparison
+# return values same as <=>
+sub _version_cmp {
+ my ( $cur, $min ) = @_;
+ return -1 unless defined $cur; # if 0 keep comparing
+ return 1 unless $min;
+
+ $cur =~ s/\s+$//;
+
+ # check for version numbers that are not in decimal format
+ if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) {
+ if ( ( $version::VERSION or defined( _load('version') )) and
+ version->can('new')
+ ) {
+
+ # use version.pm if it is installed.
+ return version->new($cur) <=> version->new($min);
+ }
+ elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) )
+ {
+
+ # use Sort::Versions as the sorting algorithm for a.b.c versions
+ return Sort::Versions::versioncmp( $cur, $min );
+ }
+
+ warn "Cannot reliably compare non-decimal formatted versions.\n"
+ . "Please install version.pm or Sort::Versions.\n";
+ }
+
+ # plain comparison
+ local $^W = 0; # shuts off 'not numeric' bugs
+ return $cur <=> $min;
+}
+
+# nothing; this usage is deprecated.
+sub main::PREREQ_PM { return {}; }
+
+sub _make_args {
+ my %args = @_;
+
+ $args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing }
+ if $UnderCPAN or $TestOnly;
+
+ if ( $args{EXE_FILES} and -e 'MANIFEST' ) {
+ require ExtUtils::Manifest;
+ my $manifest = ExtUtils::Manifest::maniread('MANIFEST');
+
+ $args{EXE_FILES} =
+ [ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ];
+ }
+
+ $args{test}{TESTS} ||= 't/*.t';
+ $args{test}{TESTS} = join( ' ',
+ grep { !exists( $DisabledTests{$_} ) }
+ map { glob($_) } split( /\s+/, $args{test}{TESTS} ) );
+
+ my $missing = join( ',', @Missing );
+ my $config =
+ join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
+ if $Config;
+
+ $PostambleActions = (
+ ($missing and not $UnderCPAN)
+ ? "\$(PERL) $0 --config=$config --installdeps=$missing"
+ : "\$(NOECHO) \$(NOOP)"
+ );
+
+ my $deps_list = join( ',', @Missing, @Existing );
+
+ $PostambleActionsUpgradeDeps =
+ "\$(PERL) $0 --config=$config --upgradedeps=$deps_list";
+
+ my $config_notest =
+ join( ',', (UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config}),
+ 'notest', 1 )
+ if $Config;
+
+ $PostambleActionsNoTest = (
+ ($missing and not $UnderCPAN)
+ ? "\$(PERL) $0 --config=$config_notest --installdeps=$missing"
+ : "\$(NOECHO) \$(NOOP)"
+ );
+
+ $PostambleActionsUpgradeDepsNoTest =
+ "\$(PERL) $0 --config=$config_notest --upgradedeps=$deps_list";
+
+ $PostambleActionsListDeps =
+ '@$(PERL) -le "print for @ARGV" '
+ . join(' ', map $Missing[$_], grep $_ % 2 == 0, 0..$#Missing);
+
+ my @all = (@Missing, @Existing);
+
+ $PostambleActionsListAllDeps =
+ '@$(PERL) -le "print for @ARGV" '
+ . join(' ', map $all[$_], grep $_ % 2 == 0, 0..$#all);
+
+ return %args;
+}
+
+# a wrapper to ExtUtils::MakeMaker::WriteMakefile
+sub Write {
+ require Carp;
+ Carp::croak "WriteMakefile: Need even number of args" if @_ % 2;
+
+ if ($CheckOnly) {
+ print << ".";
+*** Makefile not written in check-only mode.
+.
+ return;
+ }
+
+ my %args = _make_args(@_);
+
+ no strict 'refs';
+
+ $PostambleUsed = 0;
+ local *MY::postamble = \&postamble unless defined &MY::postamble;
+ ExtUtils::MakeMaker::WriteMakefile(%args);
+
+ print << "." unless $PostambleUsed;
+*** WARNING: Makefile written with customized MY::postamble() without
+ including contents from Module::AutoInstall::postamble() --
+ auto installation features disabled. Please contact the author.
+.
+
+ return 1;
+}
+
+sub postamble {
+ $PostambleUsed = 1;
+ my $fragment;
+
+ $fragment .= <<"AUTO_INSTALL" if !$InstallDepsTarget;
+
+config :: installdeps
+\t\$(NOECHO) \$(NOOP)
+AUTO_INSTALL
+
+ $fragment .= <<"END_MAKE";
+
+checkdeps ::
+\t\$(PERL) $0 --checkdeps
+
+installdeps ::
+\t$PostambleActions
+
+installdeps_notest ::
+\t$PostambleActionsNoTest
+
+upgradedeps ::
+\t$PostambleActionsUpgradeDeps
+
+upgradedeps_notest ::
+\t$PostambleActionsUpgradeDepsNoTest
+
+listdeps ::
+\t$PostambleActionsListDeps
+
+listalldeps ::
+\t$PostambleActionsListAllDeps
+
+END_MAKE
+
+ return $fragment;
+}
+
+1;
+
+__END__
+
+#line 1193
@@ -0,0 +1,93 @@
+#line 1
+package Module::Install::AutoInstall;
+
+use strict;
+use Module::Install::Base ();
+
+use vars qw{$VERSION @ISA $ISCORE};
+BEGIN {
+ $VERSION = '1.08';
+ @ISA = 'Module::Install::Base';
+ $ISCORE = 1;
+}
+
+sub AutoInstall { $_[0] }
+
+sub run {
+ my $self = shift;
+ $self->auto_install_now(@_);
+}
+
+sub write {
+ my $self = shift;
+ $self->auto_install(@_);
+}
+
+sub auto_install {
+ my $self = shift;
+ return if $self->{done}++;
+
+ # Flatten array of arrays into a single array
+ my @core = map @$_, map @$_, grep ref,
+ $self->build_requires, $self->requires;
+
+ my @config = @_;
+
+ # We'll need Module::AutoInstall
+ $self->include('Module::AutoInstall');
+ require Module::AutoInstall;
+
+ my @features_require = Module::AutoInstall->import(
+ (@config ? (-config => \@config) : ()),
+ (@core ? (-core => \@core) : ()),
+ $self->features,
+ );
+
+ my %seen;
+ my @requires = map @$_, map @$_, grep ref, $self->requires;
+ while (my ($mod, $ver) = splice(@requires, 0, 2)) {
+ $seen{$mod}{$ver}++;
+ }
+ my @build_requires = map @$_, map @$_, grep ref, $self->build_requires;
+ while (my ($mod, $ver) = splice(@build_requires, 0, 2)) {
+ $seen{$mod}{$ver}++;
+ }
+ my @configure_requires = map @$_, map @$_, grep ref, $self->configure_requires;
+ while (my ($mod, $ver) = splice(@configure_requires, 0, 2)) {
+ $seen{$mod}{$ver}++;
+ }
+
+ my @deduped;
+ while (my ($mod, $ver) = splice(@features_require, 0, 2)) {
+ push @deduped, $mod => $ver unless $seen{$mod}{$ver}++;
+ }
+
+ $self->requires(@deduped);
+
+ $self->makemaker_args( Module::AutoInstall::_make_args() );
+
+ my $class = ref($self);
+ $self->postamble(
+ "# --- $class section:\n" .
+ Module::AutoInstall::postamble()
+ );
+}
+
+sub installdeps_target {
+ my ($self, @args) = @_;
+
+ $self->include('Module::AutoInstall');
+ require Module::AutoInstall;
+
+ Module::AutoInstall::_installdeps_target(1);
+
+ $self->auto_install(@args);
+}
+
+sub auto_install_now {
+ my $self = shift;
+ $self->auto_install(@_);
+ Module::AutoInstall::do_install();
+}
+
+1;
@@ -0,0 +1,83 @@
+#line 1
+package Module::Install::Base;
+
+use strict 'vars';
+use vars qw{$VERSION};
+BEGIN {
+ $VERSION = '1.08';
+}
+
+# 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
@@ -0,0 +1,154 @@
+#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.08';
+ @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;
+ 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 236
@@ -0,0 +1,93 @@
+#line 1
+package Module::Install::Fetch;
+
+use strict;
+use Module::Install::Base ();
+
+use vars qw{$VERSION @ISA $ISCORE};
+BEGIN {
+ $VERSION = '1.08';
+ @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;
@@ -0,0 +1,34 @@
+#line 1
+package Module::Install::Include;
+
+use strict;
+use Module::Install::Base ();
+
+use vars qw{$VERSION @ISA $ISCORE};
+BEGIN {
+ $VERSION = '1.08';
+ @ISA = 'Module::Install::Base';
+ $ISCORE = 1;
+}
+
+sub include {
+ shift()->admin->include(@_);
+}
+
+sub include_deps {
+ shift()->admin->include_deps(@_);
+}
+
+sub auto_include {
+ shift()->admin->auto_include(@_);
+}
+
+sub auto_include_deps {
+ shift()->admin->auto_include_deps(@_);
+}
+
+sub auto_include_dependent_dists {
+ shift()->admin->auto_include_dependent_dists(@_);
+}
+
+1;
@@ -0,0 +1,418 @@
+#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.08';
+ @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-seperated 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> };
+
+ $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
@@ -0,0 +1,722 @@
+#line 1
+package Module::Install::Metadata;
+
+use strict 'vars';
+use Module::Install::Base ();
+
+use vars qw{$VERSION @ISA $ISCORE};
+BEGIN {
+ $VERSION = '1.08';
+ @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<lt>}{<}g;
+ $author =~ s{E<gt>}{>}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 hashs
+ 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;
@@ -0,0 +1,64 @@
+#line 1
+package Module::Install::Win32;
+
+use strict;
+use Module::Install::Base ();
+
+use vars qw{$VERSION @ISA $ISCORE};
+BEGIN {
+ $VERSION = '1.08';
+ @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;
@@ -0,0 +1,63 @@
+#line 1
+package Module::Install::WriteAll;
+
+use strict;
+use Module::Install::Base ();
+
+use vars qw{$VERSION @ISA $ISCORE};
+BEGIN {
+ $VERSION = '1.08';
+ @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;
@@ -0,0 +1,470 @@
+#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.005;
+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.08';
+
+ # 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::cwd();
+ my $sym = "${who}::AUTOLOAD";
+ $sym->{$cwd} = sub {
+ my $pwd = Cwd::cwd();
+ 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::cwd()) eq $base_path ) {
+ delete $args{prefix};
+ }
+ return $args{_self} if $args{_self};
+
+ $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( 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($subpath . '.pm');
+ my $in_pod = 0;
+ foreach ( split //, $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;
+}
+
+# Done in evals to avoid confusing Perl::MinimumVersion
+eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
+sub _read {
+ local *FH;
+ open( FH, '<', $_[0] ) or die "open($_[0]): $!";
+ my $string = do { local $/; <FH> };
+ close FH or die "close($_[0]): $!";
+ return $string;
+}
+END_NEW
+sub _read {
+ local *FH;
+ open( FH, "< $_[0]" ) or die "open($_[0]): $!";
+ my $string = do { local $/; <FH> };
+ close FH or die "close($_[0]): $!";
+ return $string;
+}
+END_OLD
+
+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;
+}
+
+# Done in evals to avoid confusing Perl::MinimumVersion
+eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
+sub _write {
+ local *FH;
+ open( FH, '>', $_[0] ) or die "open($_[0]): $!";
+ foreach ( 1 .. $#_ ) {
+ print FH $_[$_] or die "print($_[0]): $!";
+ }
+ close FH or die "close($_[0]): $!";
+}
+END_NEW
+sub _write {
+ local *FH;
+ open( FH, "> $_[0]" ) or die "open($_[0]): $!";
+ foreach ( 1 .. $#_ ) {
+ print FH $_[$_] or die "print($_[0]): $!";
+ }
+ close FH or die "close($_[0]): $!";
+}
+END_OLD
+
+# _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.
@@ -1,1679 +1,1776 @@
-package SQL::Abstract::More;
-use strict;
-use warnings;
-
-use SQL::Abstract 1.73;
-use parent 'SQL::Abstract';
-use MRO::Compat;
-use mro 'c3'; # implements next::method
-
-use Params::Validate qw/validate SCALAR SCALARREF CODEREF ARRAYREF HASHREF
- UNDEF BOOLEAN/;
-use Scalar::Util qw/blessed/;
-use Scalar::Does qw/does/;
-use Carp;
-use namespace::clean;
-
-our $VERSION = '1.15';
-
-# builtin methods for "Limit-Offset" dialects
-my %limit_offset_dialects = (
- LimitOffset => sub {my ($self, $limit, $offset) = @_;
- $offset ||= 0;
- return "LIMIT ? OFFSET ?", $limit, $offset;},
- LimitXY => sub {my ($self, $limit, $offset) = @_;
- $offset ||= 0;
- return "LIMIT ?, ?", $offset, $limit;},
- LimitYX => sub {my ($self, $limit, $offset) = @_;
- $offset ||= 0;
- return "LIMIT ?, ?", $limit, $offset;},
- RowNum => sub {
- my ($self, $limit, $offset) = @_;
- # HACK below borrowed from SQL::Abstract::Limit. Not perfect, though,
- # because it brings back an additional column. Should borrow from
- # DBIx::Class::SQLMaker::LimitDialects, which does the proper job ...
- # but it says : "!!! THIS IS ALSO HORRIFIC !!! /me ashamed"; so
- # I'll only take it as last resort; still exploring other ways.
- # See also L<DBIx::DataModel> : within that ORM an additional layer is
- # added to take advantage of Oracle scrollable cursors.
- my $sql = "SELECT * FROM ("
- . "SELECT subq_A.*, ROWNUM rownum__index FROM (%s) subq_A "
- . "WHERE ROWNUM <= ?"
- . ") subq_B WHERE rownum__index >= ?";
-
- no warnings 'uninitialized'; # in case $limit or $offset is undef
- # row numbers start at 1
- return $sql, $offset + $limit + 1, $offset + 1;
- },
- );
-
-# builtin join operators with associated sprintf syntax
-my %common_join_syntax = (
- '<=>' => '%s INNER JOIN %s ON %s',
- '=>' => '%s LEFT OUTER JOIN %s ON %s',
- '<=' => '%s RIGHT JOIN %s ON %s',
- '==' => '%s NATURAL JOIN %s',
-);
-my %right_assoc_join_syntax = %common_join_syntax;
-s/JOIN %s/JOIN (%s)/ foreach values %right_assoc_join_syntax;
-
-# specification of parameters accepted by the new() method
-my %params_for_new = (
- table_alias => {type => SCALAR|CODEREF, default => '%s AS %s'},
- column_alias => {type => SCALAR|CODEREF, default => '%s AS %s'},
- limit_offset => {type => SCALAR|CODEREF, default => 'LimitOffset'},
- join_syntax => {type => HASHREF, default =>
- \%common_join_syntax},
- join_assoc_right => {type => BOOLEAN, default => 0},
- max_members_IN => {type => SCALAR, optional => 1},
- sql_dialect => {type => SCALAR, optional => 1},
-);
-
-# builtin collection of parameters, for various databases
-my %sql_dialects = (
- MsAccess => { join_assoc_right => 1,
- join_syntax => \%right_assoc_join_syntax},
- BasisJDBC => { column_alias => "%s %s",
- max_members_IN => 255 },
- MySQL_old => { limit_offset => "LimitXY" },
- Oracle => { limit_offset => "RowNum",
- max_members_IN => 999,
- table_alias => '%s %s',
- column_alias => '%s %s', },
-);
-
-
-# operators for compound queries
-my @set_operators = qw/union union_all intersect minus except/;
-
-# specification of parameters accepted by select, insert, update, delete
-my %params_for_select = (
- -columns => {type => SCALAR|ARRAYREF, default => '*'},
- -from => {type => SCALAR|SCALARREF|ARRAYREF},
- -where => {type => SCALAR|ARRAYREF|HASHREF, optional => 1},
- (map {-$_ => {type => ARRAYREF, optional => 1}} @set_operators),
- -group_by => {type => SCALAR|ARRAYREF, optional => 1},
- -having => {type => SCALAR|ARRAYREF|HASHREF, optional => 1,
- depends => '-group_by'},
- -order_by => {type => SCALAR|ARRAYREF|HASHREF, optional => 1},
- -page_size => {type => SCALAR, optional => 1},
- -page_index => {type => SCALAR, optional => 1,
- depends => '-page_size'},
- -limit => {type => SCALAR, optional => 1},
- -offset => {type => SCALAR, optional => 1,
- depends => '-limit'},
- -for => {type => SCALAR|UNDEF, optional => 1},
- -want_details => {type => BOOLEAN, optional => 1},
-);
-my %params_for_insert = (
- -into => {type => SCALAR},
- -values => {type => SCALAR|ARRAYREF|HASHREF},
- -returning => {type => SCALAR|ARRAYREF|HASHREF, optional => 1},
-);
-my %params_for_update = (
- -table => {type => SCALAR},
- -set => {type => HASHREF},
- -where => {type => SCALAR|ARRAYREF|HASHREF, optional => 1},
-);
-my %params_for_delete = (
- -from => {type => SCALAR},
- -where => {type => SCALAR|ARRAYREF|HASHREF, optional => 1},
-);
-
-
-#----------------------------------------------------------------------
-# object creation
-#----------------------------------------------------------------------
-
-sub new {
- my ($class, %params) = @_;
-
- # extract params for this subclass
- my %more_params;
- foreach my $key (keys %params_for_new) {
- $more_params{$key} = delete $params{$key} if exists $params{$key};
- }
-
- # import params from SQL dialect, if any
- my $dialect = delete $more_params{sql_dialect};
- if ($dialect) {
- my $dialect_params = $sql_dialects{$dialect}
- or croak "no such sql dialect: $dialect";
- $more_params{$_} ||= $dialect_params->{$_} foreach keys %$dialect_params;
- }
-
- # check parameters
- my @more_params = %more_params;
- my $more_self = validate(@more_params, \%params_for_new);
-
- # call parent constructor
- my $self = $class->next::method(%params);
-
- # inject into $self
- $self->{$_} = $more_self->{$_} foreach keys %$more_self;
-
- # arguments supplied as scalars are transformed into coderefs
- ref $self->{column_alias} or $self->_make_AS_through_sprintf('column_alias');
- ref $self->{table_alias} or $self->_make_AS_through_sprintf('table_alias');
- ref $self->{limit_offset} or $self->_choose_LIMIT_OFFSET_dialect;
-
- # regex for parsing join specifications
- my @join_ops = sort {length($b) <=> length($a) || $a cmp $b}
- keys %{$self->{join_syntax}};
- my $joined_ops = join '|', map quotemeta, @join_ops;
- $self->{join_regex} = qr[
- ^ # initial anchor
- ($joined_ops)? # $1: join operator (i.e. '<=>', '=>', etc.))
- ([[{])? # $2: opening '[' or '{'
- (.*?) # $3: content of brackets
- []}]? # closing ']' or '}'
- $ # final anchor
- ]x;
-
- return $self;
-}
-
-#----------------------------------------------------------------------
-# the select method
-#----------------------------------------------------------------------
-
-sub select {
- my $self = shift;
-
- # if got positional args, this is not our job, just delegate to the parent
- return $self->next::method(@_) if !&_called_with_named_args;
-
- # declare variables and parse arguments;
- my ($join_info, %aliased_columns);
- my %args = validate(@_, \%params_for_select);
-
- # compute join info if the datasource is a join
- if (ref $args{-from} eq 'ARRAY' && $args{-from}[0] eq '-join') {
- my @join_args = @{$args{-from}};
- shift @join_args; # drop initial '-join'
- $join_info = $self->join(@join_args);
- $args{-from} = \($join_info->{sql});
- }
-
- # reorganize columns; initial members starting with "-" are extracted
- # into a separate list @post_select, later re-injected into the SQL
- my @cols = ref $args{-columns} ? @{$args{-columns}} : $args{-columns};
- my @post_select;
- push @post_select, shift @cols while @cols && $cols[0] =~ s/^-//;
- foreach my $col (@cols) {
- # extract alias, if any (recognized as "column|alias")
- ($col, my $alias) = split /\|/, $col, 2;
- if ($alias) {
- $aliased_columns{$alias} = $col;
- $col = $self->column_alias($col, $alias);
- }
- }
- $args{-columns} = \@cols;
-
- # reorganize pagination
- if ($args{-page_index} || $args{-page_size}) {
- not exists $args{$_} or croak "-page_size conflicts with $_"
- for qw/-limit -offset/;
- $args{-limit} = $args{-page_size};
- if ($args{-page_index}) {
- $args{-offset} = ($args{-page_index} - 1) * $args{-page_size};
- }
- }
-
- # -order_by : translate +/- prefixes into SQL ASC/DESC; see _order_by()
-
- # generate initial ($sql, @bind)
- my @old_API_args = @args{qw/-from -columns -where -order_by/};
- my ($sql, @bind) = $self->next::method(@old_API_args);
- unshift @bind, @{$join_info->{bind}} if $join_info;
-
- # add @post_select clauses if needed (for ex. -distinct)
- my $post_select = join " ", @post_select;
- $sql =~ s[^SELECT ][SELECT $post_select ]i if $post_select;
-
- # add set operators (UNION, INTERSECT, etc) if needed
- foreach my $set_op (@set_operators) {
- if ($args{-$set_op}) {
- my %sub_args = @{$args{-$set_op}};
- $sub_args{$_} ||= $args{$_} for qw/-columns -from/;
- my ($sql1, @bind1) = $self->select(%sub_args);
- (my $sql_op = uc($set_op)) =~ s/_/ /g;
- $sql =~ s/(ORDER BY|$)/ $sql_op $sql1 $1/;
- push @bind, @bind1;
- }
- }
-
- # add GROUP BY/HAVING if needed
- if ($args{-group_by}) {
- my $sql_grp = $self->where(undef, $args{-group_by});
- $sql_grp =~ s/\bORDER\b/GROUP/;
- if ($args{-having}) {
- my ($sql_having, @bind_having) = $self->where($args{-having});
- $sql_having =~ s/\bWHERE\b/HAVING/;
- $sql_grp .= " $sql_having";
- push @bind, @bind_having;
- }
- $sql =~ s[ORDER BY|$][$sql_grp $&]i;
- }
-
- # add LIMIT/OFFSET if needed
- if ($args{-limit}) {
- my ($limit_sql, @limit_bind)
- = $self->limit_offset(@args{qw/-limit -offset/});
- $sql = $limit_sql =~ /%s/ ? sprintf $limit_sql, $sql
- : "$sql $limit_sql";
- push @bind, @limit_bind;
- }
-
- # add FOR if needed
- $sql .= " FOR $args{-for}" if $args{-for};
-
- if ($args{-want_details}) {
- return {sql => $sql,
- bind => \@bind,
- aliased_tables => ($join_info && $join_info->{aliased_tables}),
- aliased_columns => \%aliased_columns };
- }
- else {
- return ($sql, @bind);
- }
-}
-
-#----------------------------------------------------------------------
-# insert, update and delete methods
-#----------------------------------------------------------------------
-
-sub insert {
- my $self = shift;
-
- my @old_API_args;
- my $returning_into;
-
- if (&_called_with_named_args) {
- # extract named args and translate to old SQLA API
- my %args = validate(@_, \%params_for_insert);
- @old_API_args = @args{qw/-into -values/};
-
- # if present, "-returning" may be a scalar, arrayref or hashref; the latter
- # is interpreted as .. RETURNING ... INTO ...
- if (my $returning = $args{-returning}) {
- if (does($returning, 'HASH')) {
- my @keys = sort keys %$returning
- or croak "-returning => {} : the hash is empty";
- push @old_API_args, {returning => \@keys};
- $returning_into = [@{$returning}{@keys}];
- }
- else {
- push @old_API_args, {returning => $returning};
- }
- }
- }
- else {
- @old_API_args = @_;
- }
-
- # get results from parent method
- my ($sql, @bind) = $self->next::method(@old_API_args);
-
- # inject more stuff if using Oracle's "RETURNING ... INTO ..."
- if ($returning_into) {
- $sql .= ' INTO ' . join(", ", ("?") x @$returning_into);
- push @bind, @$returning_into;
- }
-
- return ($sql, @bind);
-}
-
-
-sub update {
- my $self = shift;
-
- my @old_API_args;
- if (&_called_with_named_args) {
- my %args = validate(@_, \%params_for_update);
- @old_API_args = @args{qw/-table -set -where/};
- }
- else {
- @old_API_args = @_;
- }
-
- # return $self->next::method(@old_API_args);
- return $self->_overridden_update(@old_API_args);
-}
-
-
-
-sub delete {
- my $self = shift;
-
- my @old_API_args;
- if (&_called_with_named_args) {
- my %args = validate(@_, \%params_for_delete);
- @old_API_args = @args{qw/-from -where/};
- }
- else {
- @old_API_args = @_;
- }
-
- return $self->next::method(@old_API_args);
-}
-
-
-
-#----------------------------------------------------------------------
-# other public methods
-#----------------------------------------------------------------------
-
-# same pattern for 3 invocation methods
-foreach my $attr (qw/table_alias column_alias limit_offset/) {
- no strict 'refs';
- *{$attr} = sub {
- my $self = shift;
- my $method = $self->{$attr}; # grab reference to method body
- $self->$method(@_); # invoke
- };
-}
-
-# invocation method for 'join'
-sub join {
- my $self = shift;
-
- # start from the right if right-associative
- @_ = reverse @_ if $self->{join_assoc_right};
-
- # shift first single item (a table) before reducing pairs (op, table)
- my $combined = shift;
- $combined = $self->_parse_table($combined) unless ref $combined;
-
- # reduce pairs (op, table)
- while (@_) {
- # shift 2 items : next join specification and next table
- my $join_spec = shift;
- my $table_spec = shift or croak "join(): improper number of operands";
-
- $join_spec = $self->_parse_join_spec($join_spec) unless ref $join_spec;
- $table_spec = $self->_parse_table($table_spec) unless ref $table_spec;
- $combined = $self->_single_join($combined, $join_spec, $table_spec);
- }
-
- return $combined; # {sql=> .., bind => [..], aliased_tables => {..}}
-}
-
-
-# utility for merging several "where" clauses
-sub merge_conditions {
- my $self = shift;
- my %merged;
-
- foreach my $cond (@_) {
- if (does($cond, 'HASH')) {
- foreach my $col (sort keys %$cond) {
- $merged{$col} = $merged{$col} ? [-and => $merged{$col}, $cond->{$col}]
- : $cond->{$col};
- }
- }
- elsif (does($cond, 'ARRAY')) {
- $merged{-nest} = $merged{-nest} ? {-and => [$merged{-nest}, $cond]}
- : $cond;
- }
- elsif ($cond) {
- $merged{$cond} = \"";
- }
- }
- return \%merged;
-}
-
-# utility for calling either bind_param or bind_param_inout
-our $INOUT_MAX_LEN = 99; # chosen arbitrarily; see L<DBI/bind_param_inout>
-sub bind_params {
- my ($self, $sth, @bind) = @_;
- $sth->isa('DBI::st') or croak "sth argument is not a DBI statement handle";
- foreach my $i (0 .. $#bind) {
- my $val = $bind[$i];
- my $ref = ref $val || '';
- if ($ref eq 'SCALAR') {
- # a scalarref is interpreted as an INOUT parameter
- $sth->bind_param_inout($i+1, $val, $INOUT_MAX_LEN);
- }
- elsif ($ref eq 'ARRAY' and
- my ($bind_meth, @args) = $self->is_bind_value_with_type($val)) {
- # either 'bind_param' or 'bind_param_inout', with 2 or 3 args
- $sth->$bind_meth($i+1, @args);
- }
- else {
- # other cases are passed directly to DBI::bind_param
- $sth->bind_param($i+1, $val);
- }
- }
-}
-
-sub is_bind_value_with_type {
- my ($self, $val) = @_;
-
- # compatibility with DBIx::Class syntax of shape [\%args => $val],
- # see L<DBIx::Class::ResultSet/"DBIC BIND VALUES">
- if ( @$val == 2
- && does($val->[0], 'HASH')
- && grep {$val->[0]{$_}} qw/dbd_attrs sqlt_size
- sqlt_datatype dbic_colname/) {
- my $args = $val->[0];
- if (my $attrs = $args->{dbd_attrs}) {
- return (bind_param => $val->[1], $attrs);
- }
- elsif (my $size = $args->{sqlt_size}) {
- return (bind_param_inout => $val, $size);
- }
- # other options like 'sqlt_datatype', 'dbic_colname' are not supported
- else {
- croak "unsupported options for bind type : "
- . CORE::join(", ", sort keys %$args);
- }
-
- # NOTE : the following DBIx::Class shortcuts are not supported
- # [ $name => $val ] === [ { dbic_colname => $name }, $val ]
- # [ \$dt => $val ] === [ { sqlt_datatype => $dt }, $val ]
- # [ undef, $val ] === [ {}, $val ]
- }
-
- # in all other cases, this is not a bind value with type
- return ();
-}
-
-
-
-
-#----------------------------------------------------------------------
-# private utility methods for 'join'
-#----------------------------------------------------------------------
-
-sub _parse_table {
- my ($self, $table) = @_;
-
- # extract alias, if any (recognized as "table|alias")
- ($table, my $alias) = split /\|/, $table, 2;
-
- # build a table spec
- return {
- sql => $self->table_alias($table, $alias),
- bind => [],
- name => ($alias || $table),
- aliased_tables => {$alias ? ($alias => $table) : ()},
- };
-}
-
-
-sub _parse_join_spec {
- my ($self, $join_spec) = @_;
-
- # parse the join specification
- $join_spec
- or croak "empty join specification";
- my ($op, $bracket, $cond_list) = ($join_spec =~ $self->{join_regex})
- or croak "incorrect join specification : $join_spec\n$self->{join_regex}";
- $op ||= '<=>';
- $bracket ||= '{';
- $cond_list ||= '';
-
- # find join syntax corresponding to the join operator
- $self->{join_syntax}{$op}
- or croak "unknown join operator : $op";
-
- # accumulate conditions as pairs ($left => \"$op $right")
- my @conditions;
- foreach my $cond (split /,/, $cond_list) {
- # parse the comparison operator (left and right operands + cmp op)
- my ($left, $cmp, $right) = split /([<>=!^]{1,2})/, $cond
- or croak "can't parse join condition: $cond";
-
- # if operands are not qualified by table/alias name, add placeholders
- $left = "%1\$s.$left" unless $left =~ /\./;
- $right = "%2\$s.$right" unless $right =~ /\./;
-
- # add this pair into the list
- push @conditions, $left, {$cmp => {-ident => $right}};
- }
-
- # list becomes an arrayref or hashref (for SQLA->where())
- my $join_on = $bracket eq '[' ? [@conditions] : {@conditions};
-
- # return a new join spec
- return {operator => $op,
- condition => $join_on};
-}
-
-sub _single_join {
- my $self = shift;
-
- # if right-associative, restore proper left-right order in pair
- @_ = reverse @_ if $self->{join_assoc_right};
- my ($left, $join_spec, $right) = @_;
-
- # compute the "ON" clause (assuming it contains '%1$s', '%2$s' for
- # left/right tables)
- my ($sql, @bind) = $self->where($join_spec->{condition});
- $sql =~ s/^\s*WHERE\s+//;
- $sql = sprintf $sql, $left->{name}, $right->{name};
-
- # assemble all elements
- my $syntax = $self->{join_syntax}{$join_spec->{operator}};
- $sql = sprintf $syntax, $left->{sql}, $right->{sql}, $sql;
- unshift @bind, @{$left->{bind}}, @{$right->{bind}};
-
- # build result and return
- my %result = (sql => $sql, bind => \@bind);
- $result{name} = ($self->{join_assoc_right} ? $left : $right)->{name};
- $result{aliased_tables} = $left->{aliased_tables};
- foreach my $alias (keys %{$right->{aliased_tables}}) {
- $result{aliased_tables}{$alias} = $right->{aliased_tables}{$alias};
- }
-
- return \%result;
-}
-
-
-#----------------------------------------------------------------------
-# override of parent's "_order_by"
-#----------------------------------------------------------------------
-
-sub _order_by {
- my ($self, $order) = @_;
-
- # force scalar into an arrayref
- $order = [$order] if not ref $order;
-
- if (ref $order eq 'ARRAY') {
- my @clone = @$order; # because we will modify items
-
- # '-' and '+' prefixes are translated into {-desc/asc => } hashrefs
- foreach my $item (@clone) {
- next if !$item or ref $item;
- $item =~ s/^-// and $item = {-desc => $item} and next;
- $item =~ s/^\+// and $item = {-asc => $item};
- }
- $order = \@clone;
- }
-
- return $self->next::method($order);
-}
-
-
-
-
-#----------------------------------------------------------------------
-# override of parent's "_where_field_IN"
-#----------------------------------------------------------------------
-
-sub _where_field_IN {
- my ($self, $k, $op, $vals) = @_;
-
- my $max_members_IN = $self->{max_members_IN};
- if ($max_members_IN && does($vals, 'ARRAY')
- && @$vals > $max_members_IN) {
- my @vals = @$vals;
- my @slices;
- while (my @slice = splice(@vals, 0, $max_members_IN)) {
- push @slices, \@slice;
- }
- my @clauses = map {{-$op, $_}} @slices;
- my $connector = $op =~ /^not/i ? '-and' : '-or';
- unshift @clauses, $connector;
- my ($sql, @bind) = $self->where({$k => \@clauses});
- $sql =~ s/\s*where\s*\((.*)\)/$1/i;
- return ($sql, @bind);
- }
- else {
- $vals = [@$vals] if blessed $vals; # because SQLA dies on blessed arrayrefs
- return $self->next::method($k, $op, $vals);
- }
-}
-
-#----------------------------------------------------------------------
-# override of parent's methods for decoding arrayrefs
-#----------------------------------------------------------------------
-
-sub _where_hashpair_ARRAYREF {
- my ($self, $k, $v) = @_;
-
- if ($self->is_bind_value_with_type($v)) {
- $self->_assert_no_bindtype_columns;
- my $sql = CORE::join ' ', $self->_convert($self->_quote($k)),
- $self->_sqlcase($self->{cmp}),
- $self->_convert('?');
- my @bind = ($v);
- return ($sql, @bind);
- }
- else {
- return $self->next::method($k, $v);
- }
-}
-
-
-sub _where_field_op_ARRAYREF {
- my ($self, $k, $op, $vals) = @_;
-
- if ($self->is_bind_value_with_type($vals)) {
- $self->_assert_no_bindtype_columns;
- my $sql = CORE::join ' ', $self->_convert($self->_quote($k)),
- $self->_sqlcase($op),
- $self->_convert('?');
- my @bind = ($vals);
- return ($sql, @bind);
- }
- else {
- return $self->next::method($k, $op, $vals);
- }
-}
-
-sub _assert_no_bindtype_columns {
- my ($self) = @_;
- $self->{bindtype} ne 'columns'
- or croak 'values of shape [$val, \%type] are not compatible'
- . 'with ...->new(bindtype => "columns")';
-}
-
-
-
-sub _insert_values {
- # unfortunately, we can't just override the ARRAYREF part, so the whole
- # parent method is copied here
- my ($self, $data) = @_;
-
- my (@values, @all_bind);
- foreach my $column (sort keys %$data) {
- my $v = $data->{$column};
-
- $self->_SWITCH_refkind($v, {
-
- ARRAYREF => sub {
- if ($self->{array_datatypes}
- || $self->is_bind_value_with_type($v)) {
- # if array datatype are activated or this is a [$val, \%type] struct
- push @values, '?';
- push @all_bind, $self->_bindtype($column, $v);
- }
- else {
- # otherwise, literal SQL with bind
- my ($sql, @bind) = @$v;
- $self->_assert_bindval_matches_bindtype(@bind);
- push @values, $sql;
- push @all_bind, @bind;
- }
- },
-
- ARRAYREFREF => sub { # literal SQL with bind
- my ($sql, @bind) = @${$v};
- $self->_assert_bindval_matches_bindtype(@bind);
- push @values, $sql;
- push @all_bind, @bind;
- },
-
- # THINK : anything useful to do with a HASHREF ?
- HASHREF => sub { # (nothing, but old SQLA passed it through)
- #TODO in SQLA >= 2.0 it will die instead
- SQL::Abstract::belch("HASH ref as bind value in insert is not supported");
- push @values, '?';
- push @all_bind, $self->_bindtype($column, $v);
- },
-
- SCALARREF => sub { # literal SQL without bind
- push @values, $$v;
- },
-
- SCALAR_or_UNDEF => sub {
- push @values, '?';
- push @all_bind, $self->_bindtype($column, $v);
- },
-
- });
-
- }
-
- my $sql = $self->_sqlcase('values')." ( ".CORE::join(", ", @values)." )";
- return ($sql, @all_bind);
-}
-
-
-
-sub _overridden_update {
- # unfortunately, we can't just override the ARRAYREF part, so the whole
- # parent method is copied here
-
- my $self = shift;
- my $table = $self->_table(shift);
- my $data = shift || return;
- my $where = shift;
-
- # first build the 'SET' part of the sql statement
- my (@set, @all_bind);
- SQL::Abstract::puke("Unsupported data type specified to \$sql->update")
- unless ref $data eq 'HASH';
-
- for my $k (sort keys %$data) {
- my $v = $data->{$k};
- my $r = ref $v;
- my $label = $self->_quote($k);
-
- $self->_SWITCH_refkind($v, {
- ARRAYREF => sub {
- if ($self->{array_datatypes}
- || $self->is_bind_value_with_type($v)) {
- push @set, "$label = ?";
- push @all_bind, $self->_bindtype($k, $v);
- }
- else { # literal SQL with bind
- my ($sql, @bind) = @$v;
- $self->_assert_bindval_matches_bindtype(@bind);
- push @set, "$label = $sql";
- push @all_bind, @bind;
- }
- },
- ARRAYREFREF => sub { # literal SQL with bind
- my ($sql, @bind) = @${$v};
- $self->_assert_bindval_matches_bindtype(@bind);
- push @set, "$label = $sql";
- push @all_bind, @bind;
- },
- SCALARREF => sub { # literal SQL without bind
- push @set, "$label = $$v";
- },
- HASHREF => sub {
- my ($op, $arg, @rest) = %$v;
-
- SQL::Abstract::puke(
- 'Operator calls in update must be in the form { -op => $arg }'
- ) if (@rest or not $op =~ /^\-(.+)/);
-
- local $self->{_nested_func_lhs} = $k;
- my ($sql, @bind) = $self->_where_unary_op ($1, $arg);
-
- push @set, "$label = $sql";
- push @all_bind, @bind;
- },
- SCALAR_or_UNDEF => sub {
- push @set, "$label = ?";
- push @all_bind, $self->_bindtype($k, $v);
- },
- });
- }
-
- # generate sql
- my $sql = $self->_sqlcase('update') . " $table " . $self->_sqlcase('set ')
- . CORE::join ', ', @set;
-
- if ($where) {
- my($where_sql, @where_bind) = $self->where($where);
- $sql .= $where_sql;
- push @all_bind, @where_bind;
- }
-
- return wantarray ? ($sql, @all_bind) : $sql;
-}
-
-
-
-
-#----------------------------------------------------------------------
-# method creations through closures
-#----------------------------------------------------------------------
-
-sub _make_AS_through_sprintf {
- my ($self, $attribute) = @_;
- my $syntax = $self->{$attribute};
- $self->{$attribute} = sub {
- my ($self, $name, $alias) = @_;
- return $alias ? sprintf($syntax, $name, $alias) : $name;
- };
-}
-
-sub _choose_LIMIT_OFFSET_dialect {
- my $self = shift;
- my $dialect = $self->{limit_offset};
- my $method = $limit_offset_dialects{$dialect}
- or croak "no such limit_offset dialect: $dialect";
- $self->{limit_offset} = $method;
-};
-
-
-#----------------------------------------------------------------------
-# utility to decide if the method was called with named or positional args
-#----------------------------------------------------------------------
-
-sub _called_with_named_args {
- return $_[0] && !ref $_[0] && substr($_[0], 0, 1) eq '-';
-}
-
-
-1; # End of SQL::Abstract::More
-
-__END__
-
-=head1 NAME
-
-SQL::Abstract::More - extension of SQL::Abstract with more constructs and more flexible API
-
-=head1 DESCRIPTION
-
-Generates SQL from Perl datastructures. This is a subclass of
-L<SQL::Abstract>, fully compatible with the parent class, but with
-some additions :
-
-=over
-
-=item *
-
-additional SQL constructs like C<-union>, C<-group_by>, C<join>, etc.
-
-=item *
-
-methods take arguments as named parameters instead of positional parameters,
-so that various SQL fragments are more easily identified
-
-=item *
-
-values passed to C<select>, C<insert> or C<update> can directly incorporate
-information about datatypes, in the form of arrayrefs of shape
-C<< [{dbd_attrs => \%type}, $value] >>
-
-=back
-
-
-This module was designed for the specific needs of
-L<DBIx::DataModel>, but is published as a standalone distribution,
-because it may possibly be useful for other needs.
-
-=head1 SYNOPSIS
-
- my $sqla = SQL::Abstract::More->new();
- my ($sql, @bind);
-
- # ex1: named parameters, select DISTINCT, ORDER BY, LIMIT/OFFSET
- ($sql, @bind) = $sqla->select(
- -columns => [-distinct => qw/col1 col2/],
- -from => 'Foo',
- -where => {bar => {">" => 123}},
- -order_by => [qw/col1 -col2 +col3/], # BY col1, col2 DESC, col3 ASC
- -limit => 100,
- -offset => 300,
- );
-
- # ex2: column aliasing, join
- ($sql, @bind) = $sqla->select(
- -columns => [ qw/Foo.col_A|a Bar.col_B|b /],
- -from => [-join => qw/Foo fk=pk Bar /],
- );
-
- # ex3: INTERSECT (or similar syntax for UNION)
- ($sql, @bind) = $sqla->select(
- -columns => [qw/col1 col2/],
- -from => 'Foo',
- -where => {col1 => 123},
- -intersect => [ -columns => [qw/col3 col4/],
- -from => 'Bar',
- -where => {col3 => 456},
- ],
- );
-
- # ex4: passing datatype specifications
- ($sql, @bind) = $sqla->select(
- -from => 'Foo',
- -where => {bar => [{dbd_attrs => {ora_type => ORA_XMLTYPE}}, $xml]},
- );
- my $sth = $dbh->prepare($sql);
- $sqla->bind_params($sth, @bind);
- $sth->execute;
-
- # merging several criteria
- my $merged = $sqla->merge_conditions($cond_A, $cond_B, ...);
- ($sql, @bind) = $sqla->select(..., -where => $merged, ..);
-
- # insert / update / delete
- ($sql, @bind) = $sqla->insert(
- -into => $table,
- -values => {col => $val, ...},
- );
- ($sql, @bind) = $sqla->update(
- -table => $table,
- -set => {col => $val, ...},
- -where => \%conditions,
- );
- ($sql, @bind) = $sqla->delete (
- -from => $table
- -where => \%conditions,
- );
-
-=head1 CLASS METHODS
-
-=head2 new
-
- my $sqla = SQL::Abstract::More->new(%options);
-
-where C<%options> may contain any of the options for the parent
-class (see L<SQL::Abstract/new>), plus the following :
-
-=over
-
-=item table_alias
-
-A L<sprintf> format description for generating table aliasing clauses.
-The default is C<%s AS %s>.
-Can also be supplied as a method coderef (see L</"Overriding methods">).
-
-=item column_alias
-
-A L<sprintf> format description for generating column aliasing clauses.
-The default is C<%s AS %s>.
-Can also be supplied as a method coderef.
-
-=item limit_offset
-
-Name of a "limit-offset dialect", which can be one of
-C<LimitOffset>, C<LimitXY>, C<LimitYX> or C<RowNum>;
-see L<SQL::Abstract::Limit> for an explation of those dialects.
-Here, unlike the L<SQL::Abstract::Limit> implementation,
-limit and offset values are treated as regular values,
-with placeholders '?' in the SQL; values are postponed to the
-C<@bind> list.
-
-The argument can also be a coderef (see below
-L</"Overriding methods">). That coderef takes C<$self, $limit, $offset>
-as arguments, and should return C<($sql, @bind)>. If C<$sql> contains
-C<%s>, it is treated as a L<sprintf> format string, where the original
-SQL is injected into C<%s>.
-
-
-=item join_syntax
-
-A hashref where keys are abreviations for join
-operators to be used in the L</join> method, and
-values are associated SQL clauses with placeholders
-in L<sprintf> format. The default is described
-below under the L</join> method.
-
-=item join_assoc_right
-
-A boolean telling if multiple joins should be associative
-on the right or on the left. Default is false (i.e. left-associative).
-
-=item max_members_IN
-
-An integer specifying the maximum number of members in a "IN" clause.
-If the number of given members is greater than this maximum,
-C<SQL::Abstract::More> will automatically split it into separate
-clauses connected by 'OR' (or connected by 'AND' if used with the
-C<-not_in> operator).
-
- my $sqla = SQL::Abstract::More->new(max_members_IN => 3);
- ($sql, @bind) = $sqla->select(
- -from => 'Foo',
- -where => {foo => {-in => [1 .. 5]}},
- bar => {-not_in => [6 .. 10]}},
- );
- # .. WHERE ( (foo IN (?,?,?) OR foo IN (?, ?))
- # AND (bar NOT IN (?,?,?) AND bar NOT IN (?, ?)) )
-
-
-=item sql_dialect
-
-This is actually a "meta-argument" : it injects a collection
-of regular arguments, tuned for a specific SQL dialect.
-Dialects implemented so far are :
-
-=over
-
-=item MsAccess
-
-For Microsoft Access. Overrides the C<join> syntax to be right-associative.
-
-=item BasisJDBC
-
-For Livelink Collection Server (formerly "Basis"), accessed
-through a JDBC driver. Overrides the C<column_alias> syntax.
-Sets C<max_members_IN> to 255.
-
-=item MySQL_old
-
-For old versions of MySQL. Overrides the C<limit_offset> syntax.
-Recent versions of MySQL do not need that because they now
-implement the regular "LIMIT ? OFFSET ?" ANSI syntax.
-
-=item Oracle
-
-For Oracle. Overrides the C<limit_offset> to use the "RowNum" dialect
-(beware, this injects an additional column C<rownum__index> into your
-resultset). Also sets C<max_members_IN> to 999.
-
-=back
-
-=back
-
-=head3 Overriding methods
-
-Several arguments to C<new()> can be references to method
-implementations instead of plain scalars : this allows you to
-completely redefine a behaviour without the need to subclass. Just
-supply a regular method body as a code reference : for example, if you
-need another implementation for LIMIT-OFFSET, you could write
-
- my $sqla = SQL::Abstract::More->new(
- limit_offset => sub {
- my ($self, $limit, $offset) = @_;
- defined $limit or die "NO LIMIT!"; #:-)
- $offset ||= 0;
- my $last = $offset + $limit;
- return ("ROWS ? TO ?", $offset, $last); # ($sql, @bind)
- });
-
-
-=head1 INSTANCE METHODS
-
-=head2 select
-
- # positional parameters, directly passed to the parent class
- ($sql, @bind) = $sqla->select($table, $columns, $where, $order);
-
- # named parameters, handled in this class
- ($sql, @bind) = $sqla->select(
- -columns => \@columns,
- # OR: -columns => [-distinct => @columns],
- -from => $table || \@joined_tables,
- -where => \%where,
- -union => [ %select_subargs ], # OR -intersect, -minus, etc
- -order_by => \@order,
- -group_by => \@group_by,
- -having => \%having_criteria,
- -limit => $limit, -offset => $offset,
- # OR: -page_size => $size, -page_index => $index,
- -for => $purpose,
- );
-
- my $details = $sqla->select(..., want_details => 1);
- # keys in %$details: sql, bind, aliased_tables, aliased_columns
-
-If called with positional parameters, as in L<SQL::Abstract>,
-C<< select() >> just forwards the call to the parent class. Otherwise, if
-called with named parameters, as in the example above, some additional
-SQL processing is performed.
-
-The following named arguments can be specified :
-
-=over
-
-=item C<< -columns => \@columns >>
-
-C<< \@columns >> is a reference to an array
-of SQL column specifications (i.e. column names,
-C<*> or C<table.*>, functions, etc.).
-
-A '|' in a column is translated into a column aliasing clause:
-this is convenient when
-using perl C<< qw/.../ >> operator for columns, as in
-
- -columns => [ qw/table1.longColumn|t1lc table2.longColumn|t2lc/ ]
-
-SQL column aliasing is then generated through the L</column_alias> method.
-
-Initial items in C<< @columns >> that start with a minus sign
-are shifted from the array, i.e. they are not considered as column
-names, but are re-injected later into the SQL (without the minus sign),
-just after the C<SELECT> keyword. This is especially useful for
-
- $sqla->select(..., -columns => [-DISTINCT => @columns], ...);
-
-However, it may also be useful for other purposes, like
-vendor-specific SQL variants :
-
- # MySQL features
- ->select(..., -columns => [-STRAIGHT_JOIN => @columns], ...);
- ->select(..., -columns => [-SQL_SMALL_RESULT => @columns], ...);
-
- # Oracle hint
- ->select(..., -columns => ["-/*+ FIRST_ROWS (100) */" => @columns], ...);
-
-The argument to C<-columns> can also be a string instead of
-an arrayref, like for example
-C<< "c1 AS foobar, MAX(c2) AS m_c2, COUNT(c3) AS n_c3" >>;
-however this is mainly for backwards compatibility. The
-recommended way is to use the arrayref notation as explained above :
-
- -columns => [ qw/ c1|foobar MAX(c2)|m_c2 COUNT(c3)|n_c3 / ]
-
-If omitted, C<< -columns >> takes '*' as default argument.
-
-=item C<< -from => $table || \@joined_tables >>
-
-
-=item C<< -where => $criteria >>
-
-Like in L<SQL::Abstract>, C<< $criteria >> can be
-a plain SQL string like C<< "col1 IN (3, 5, 7, 11) OR col2 IS NOT NULL" >>;
-but in most cases, it will rather be a reference to a hash or array of
-conditions that will be translated into SQL clauses, like
-for example C<< {col1 => 'val1', col2 => 'val2'} >>.
-The structure of that hash or array can be nested to express complex
-boolean combinations of criteria; see
-L<SQL::Abstract/"WHERE CLAUSES"> for a detailed description.
-
-When using hashrefs or arrayrefs, leaf values can be "bind values with types";
-see the L</"BIND VALUES WITH TYPES"> section below.
-
-=item C<< -union => [ %select_subargs ] >>
-
-=item C<< -union_all => [ %select_subargs ] >>
-
-=item C<< -intersect => [ %select_subargs ] >>
-
-=item C<< -except => [ %select_subargs ] >>
-
-=item C<< -minus => [ %select_subargs ] >>
-
-generates a compound query using set operators such as C<UNION>,
-C<INTERSECT>, etc. The argument C<%select_subargs> contains a nested
-set of parameters like for the main select (i.e. C<-columns>,
-C<-from>, C<-where>, etc.); however, arguments C<-columns> and
-C<-from> can be omitted, in which case they will be copied from the
-main select(). Several levels of set operators can be nested.
-
-=item C<< -group_by => "string" >> or C<< -group_by => \@array >>
-
-adds a C<GROUP BY> clause in the SQL statement. Grouping columns are
-specified either by a plain string or by an array of strings.
-
-=item C<< -having => "string" >> or C<< -having => \%criteria >>
-
-adds a C<HAVING> clause in the SQL statement (only makes
-sense together with a C<GROUP BY> clause).
-This is like a C<-where> clause, except that the criteria
-are applied after grouping has occured.
-
-
-=item C<< -order_by => \@order >>
-
-C<< \@order >> is a reference to a list
-of columns for sorting. Columns can
-be prefixed by '+' or '-' for indicating sorting directions,
-so for example C<< -orderBy => [qw/-col1 +col2 -col3/] >>
-will generate the SQL clause
-C<< ORDER BY col1 DESC, col2 ASC, col3 DESC >>.
-
-Column names C<asc> and C<desc> are treated as exceptions to this
-rule, in order to preserve compatibility with L<SQL::Abstract>.
-So C<< -orderBy => [-desc => 'colA'] >> yields
-C<< ORDER BY colA DESC >> and not C<< ORDER BY desc DEC, colA >>.
-Any other syntax supported by L<SQL::Abstract> is also
-supported here; see L<SQL::Abstract/"ORDER BY CLAUSES"> for examples.
-
-The whole C<< -order_by >> parameter can also be a plain SQL string
-like C<< "col1 DESC, col3, col2 DESC" >>.
-
-=item C<< -page_size => $page_size >>
-
-specifies how many rows will be retrieved per "page" of data.
-Default is unlimited (or more precisely the maximum
-value of a short integer on your system).
-When specified, this parameter automatically implies C<< -limit >>.
-
-=item C<< -page_index => $page_index >>
-
-specifies the page number (starting at 1). Default is 1.
-When specified, this parameter automatically implies C<< -offset >>.
-
-=item C<< -limit => $limit >>
-
-limit to the number of rows that will be retrieved.
-Automatically implied by C<< -page_size >>.
-
-=item C<< -offset => $offset >>
-
-Automatically implied by C<< -page_index >>.
-Defaults to 0.
-
-=item C<< -for => $clause >>
-
-specifies an additional clause to be added at the end of the SQL statement,
-like C<< -for => 'READ ONLY' >> or C<< -for => 'UPDATE' >>.
-
-=item C<< -want_details => 1 >>
-
-If true, the return value will be a hashref instead of the usual
-C<< ($sql, @bind) >>. The hashref contains the following keys :
-
-=over
-
-=item sql
-
-generated SQL
-
-=item bind
-
-bind values
-
-=item aliased_tables
-
-a hashref of C<< {table_alias => table_name} >> encountered while
-parsing the C<-from> parameter.
-
-=item aliased_columns
-
-a hashref of C<< {column_alias => column_name} >> encountered while
-parsing the C<-columns> parameter.
-
-=back
-
-
-=back
-
-
-
-=head2 insert
-
- # positional parameters, directly passed to the parent class
- ($sql, @bind) = $sqla->insert($table, \@values || \%fieldvals, \%options);
-
- # named parameters, handled in this class
- ($sql, @bind) = $sqla->insert(
- -into => $table,
- -values => {col => $val, ...},
- -returning => $return_structure,
- );
-
-Like for L</select>, values assigned to columns can have associated
-SQL types; see L</"BIND VALUES WITH TYPES">.
-
-Named parameters to the C<insert()> method are just syntactic sugar
-for better readability of the client's code. Parameters
-C<-into> and C<-values> are passed verbatim to the parent method.
-Parameter C<-returning> is optional and only
-supported by some database vendors (see L<SQL::Abstract/insert>);
-if the C<$return_structure> is
-
-=over
-
-=item *
-
-a scalar or an arrayref, it is passed directly to the parent method
-
-=item *
-
-a hashref, it is interpreted as a SQL clause "RETURNING .. INTO ..",
-as required in particular by Oracle. Hash keys are field names, and
-hash values are references to variables that will receive the
-results. Then it is the client code's responsability
-to use L<DBD::Oracle/bind_param_inout> for binding the variables
-and retrieving the results, but the L</bind_params> method in the
-present module is there for help. Example:
-
- ($sql, @bind) = $sqla->insert(
- -into => $table,
- -values => {col => $val, ...},
- -returning => {key_col => \my $generated_key},
- );
-
- my $sth = $dbh->prepare($sql);
- $sqla->bind_params($sth, @bind);
- $sth->execute;
- print "The new key is $generated_key";
-
-=back
-
-
-=head2 update
-
- # positional parameters, directly passed to the parent class
- ($sql, @bind) = $sqla->update($table, \%fieldvals, \%where);
-
- # named parameters, handled in this class
- ($sql, @bind) = $sqla->update(
- -table => $table,
- -set => {col => $val, ...},
- -where => \%conditions,
- );
-
-This works in the same spirit as the L</insert> method above.
-Named parameters to the C<update()> method are just syntactic sugar
-for better readability of the client's code; they are passed verbatim
-to the parent method.
-
-
-=head2 delete
-
- # positional parameters, directly passed to the parent class
- ($sql, @bind) = $sqla->delete($table, \%where);
-
- # named parameters, handled in this class
- ($sql, @bind) = $sqla->delete (
- -from => $table
- -where => \%conditions,
- );
-
-Named parameters to the C<delete()> method are just syntactic sugar
-for better readability of the client's code; they are passed verbatim
-to the parent method.
-
-
-=head2 table_alias
-
- my $sql = $sqla->table_alias($table_name, $alias);
-
-Returns the SQL fragment for aliasing a table.
-If C<$alias> is empty, just returns C<$table_name>.
-
-=head2 column_alias
-
-Like C<table_alias>, but for column aliasing.
-
-=head2 limit_offset
-
- ($sql, @bind) = $sqla->limit_offset($limit, $offset);
-
-Generates C<($sql, @bind)> for a LIMIT-OFFSET clause.
-
-=head2 join
-
- ($sql, @bind) = $sqla->join(
- <table0> <join_1> <table_1> ... <join_n> <table_n>
- );
-
-Generates C<($sql, @bind)> for a JOIN clause, taking as input
-a collection of joined tables with their join conditions.
-The following example gives an idea of the available syntax :
-
- ($sql, @bind) = $sqla->join(qw[
- Table1|t1 ab=cd Table2|t2
- <=>{ef>gh,ij<kl} Table3
- =>{t1.mn=op} Table4
- ]);
-
-This will generate
-
- Table1 AS t1 INNER JOIN Table2 AS t2 ON t1.ab=t2.cd
- INNER JOIN Table3 ON t2.ef>Table3.gh
- AND t2.ij<Table3.kl
- LEFT JOIN Table4 ON t1.mn=Table4.op
-
-More precisely, the arguments to C<join()> should be a list
-containing an odd number of elements, where the odd positions
-are I<table specifications> and the even positions are
-I<join specifications>.
-
-=head3 Table specifications
-
-A table specification for join is a string containing
-the table name, possibly followed by a vertical bar
-and an alias name. For example C<Table1> or C<Table1|t1>
-are valid table specifications.
-
-These are converted into internal hashrefs with keys
-C<sql>, C<bind>, C<name>, C<aliased_tables>, like this :
-
- {
- sql => "Table1 AS t1"
- bind => [],
- name => "t1"
- aliased_tables => {"t1" => "Table1"}
- }
-
-Such hashrefs can be passed directly as arguments,
-instead of the simple string representation.
-
-=head3 Join specifications
-
-A join specification is a string containing
-an optional I<join operator>, possibly followed
-by a pair of curly braces or square brackets
-containing the I<join conditions>.
-
-Default builtin join operators are
-C<< <=> >>, C<< => >>, C<< <= >>, C<< == >>,
-corresponding to the following
-SQL JOIN clauses :
-
- '<=>' => '%s INNER JOIN %s ON %s',
- '=>' => '%s LEFT OUTER JOIN %s ON %s',
- '<=' => '%s RIGHT JOIN %s ON %s',
- '==' => '%s NATURAL JOIN %s',
-
-This operator table can be overridden through
-the C<join_syntax> parameter of the L</new> method.
-
-The join conditions is a comma-separated list
-of binary column comparisons, like for example
-
- {ab=cd,Table1.ef<Table2.gh}
-
-Table names may be explicitly given using dot notation,
-or may be implicit, in which case they will be filled
-automatically from the names of operands on the
-left-hand side and right-hand side of the join.
-
-In accordance with L<SQL::Abstract> common conventions,
-if the list of comparisons is within curly braces, it will
-become an C<AND>; if it is within square brackets, it will
-become an C<OR>.
-
-Join specifications expressed as strings
-are converted into internal hashrefs with keys
-C<operator> and C<condition>, like this :
-
- {
- operator => '<=>',
- condition => { '%1$s.ab' => {'=' => {-ident => '%2$s.cd'}},
- '%1$s.ef' => {'=' => {-ident => 'Table2.gh'}}},
- }
-
-The C<operator> is a key into the C<join_syntax> table; the associated
-value is a sprinf format string, with placeholders for the left and
-right operands, and the join condition. The C<condition> is a
-structure suitable for being passed as argument to
-L<SQL::Abstract/where>. Places where the names of left/right tables
-(or their aliases) are expected should be expressed as sprintf
-placeholders, i.e. respectively C<%1$s> and C<%2$s>. In most cases
-the right-hand side of the condition should B<not> belong to
-the C<@bind> list, so this is why we need to use the C<-ident> operator
-from L<SQL::Abstract>.
-
-Hashrefs for join specifications as shown above can be passed directly
-as arguments, instead of the simple string representation.
-
-=head2 merge_conditions
-
- my $conditions = $sqla->merge_conditions($cond_A, $cond_B, ...);
-
-This utility method takes a list of "C<where>" conditions and
-merges all of them in a single hashref. For example merging
-
- ( {a => 12, b => {">" => 34}},
- {b => {"<" => 56}, c => 78} )
-
-produces
-
- {a => 12, b => [-and => {">" => 34}, {"<" => 56}], c => 78});
-
-
-=head2 bind_params
-
- $sqla->bind_params($sth, @bind);
-
-For each C<$value> in C<@bind>:
-
-=over
-
-=item *
-
-if the value is a scalarref, call
-
- $sth->bind_param_inout($index, $value, $INOUT_MAX_LEN)
-
-(see L<DBI/bind_param_inout>). C<$INOUT_MAX_LEN> defaults to
-99, which should be good enough for most uses; should you need another value,
-you can change it by setting
-
- local $SQL::Abstract::More::INOUT_MAX_LEN = $other_value;
-
-=item *
-
-if the value is an arrayref that matches L</is_bind_value_with_type>,
-then call the method and arguments returned by L</is_bind_value_with_type>.
-
-=item *
-
-for all other cases, call
-
- $sth->bind_param($index, $value);
-
-=back
-
-This method is useful either as a convenience for Oracle
-statements of shape C<"INSERT ... RETURNING ... INTO ...">
-(see L</insert> method above), or as a way to indicate specific
-datatypes to the database driver.
-
-==head2 is_bind_value_with_type
-
- my ($method, @args) = $sqla->is_bind_value_with_type($value);
-
-
-If C<$value> is a ref to a pair C<< [\%args, $orig_value] >> :
-
-
-=over
-
-=item *
-
-if C<%args> is of shape C<< {dbd_attrs => \%sql_type} >>,
-then return C<< ('bind_param', $orig_value, \%sql_type) >>.
-
-=item *
-
-if C<%args> is of shape C<< {sqlt_size => $num} >>,
-then return C<< ('bind_param_inout', $orig_value, $num) >>.
-
-=back
-
-Otherwise, return C<()>.
-
-
-
-=head1 BIND VALUES WITH TYPES
-
-At places where L<SQL::Abstract> would expect a plain value,
-C<SQL::Abstract::More> also accepts a pair, i.e. an arrayref of 2
-elements, where the first element is a type specification, and the
-second element is the value. This is convenient when the DBD driver needs
-additional information about the values used in the statement.
-
-The usual type specification is a hashref C<< {dbd_attrs => \%type} >>,
-where C<\%type> is passed directly as third argument to
-L<DBI/bind_param>, and therefore is specific to the DBD driver.
-
-Another form of type specification is C<< {sqlt_size => $num} >>,
-where C<$num> will be passed as buffer size to L<DBI/bind_param_inout>.
-
-Here are some examples
-
- ($sql, @bind) = $sqla->insert(
- -into => 'Foo',
- -values => {bar => [{dbd_attrs => {ora_type => ORA_XMLTYPE}}]},
- );
- ($sql, @bind) = $sqla->select(
- -from => 'Foo',
- -where => {d_begin => {">" => [{dbd_attrs => {ora_type => ORA_DATE}},
- $some_date]}},
- );
-
-
-When using this feature, the C<@bind> array will contain references
-that cannot be passed directly to L<DBI> methods; so you should use
-L</bind_params> from the present module to perform the appropriate
-bindings before executing the statement.
-
-
-=head1 TODO
-
-Future versions may include some of these features :
-
-=over
-
-=item *
-
-support for C<WITH> initial clauses, and C<WITH RECURSIVE>.
-
-=item *
-
-suport for Oracle-specific syntax for recursive queries
-(START_WITH, PRIOR, CONNECT_BY NOCYCLE, CONNECT SIBLINGS, etc.)
-
-=item *
-
-support for INSERT variants
-
- INSERT .. DEFAULT VALUES
- INSERT .. VALUES(), VALUES()
-
-=item *
-
-support for MySQL C<LOCK_IN_SHARE_MODE>
-
-=item *
-
-new constructor option
-
- ->new(..., select_implicitly_for => $string, ...)
-
-This would provide a default values for the C<-for> parameter.
-
-=back
-
-=head1 AUTHOR
-
-Laurent Dami, C<< <laurent.dami at justice.ge.ch> >>
-
-=head1 BUGS
-
-Please report any bugs or feature requests to C<bug-sql-abstract-more at rt.cpan.org>, or through
-the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=SQL-Abstract-More>. I will be notified, and then you'll
-automatically be notified of progress on your bug as I make changes.
-
-
-=head1 SUPPORT
-
-You can find documentation for this module with the perldoc command.
-
- perldoc SQL::Abstract::More
-
-
-You can also look for information at:
-
-=over 4
-
-=item RT: CPAN's request tracker
-
-L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=SQL-Abstract-More>
-
-=item AnnoCPAN: Annotated CPAN documentation
-
-L<http://annocpan.org/dist/SQL-Abstract-More>
-
-=item CPAN Ratings
-
-L<http://cpanratings.perl.org/d/SQL-Abstract-More>
-
-=item MetaCPAN
-
-L<https://metacpan.org/module/SQL::Abstract::More>
-
-=back
-
-
-=head1 LICENSE AND COPYRIGHT
-
-Copyright 2011, 2012 Laurent Dami.
-
-This program is free software; you can redistribute it and/or modify it
-under the terms of either: the GNU General Public License as published
-by the Free Software Foundation; or the Artistic License.
-
-See http://dev.perl.org/licenses/ for more information.
-
-=cut
-
-
+package SQL::Abstract::More;
+use strict;
+use warnings;
+
+use SQL::Abstract 1.73;
+use parent 'SQL::Abstract';
+use MRO::Compat;
+use mro 'c3'; # implements next::method
+
+use Params::Validate qw/validate SCALAR SCALARREF CODEREF ARRAYREF HASHREF
+ UNDEF BOOLEAN/;
+use Scalar::Util qw/blessed/;
+use Scalar::Does qw/does/;
+use Carp;
+use namespace::clean;
+
+our $VERSION = '1.23';
+
+# builtin methods for "Limit-Offset" dialects
+my %limit_offset_dialects = (
+ LimitOffset => sub {my ($self, $limit, $offset) = @_;
+ $offset ||= 0;
+ return "LIMIT ? OFFSET ?", $limit, $offset;},
+ LimitXY => sub {my ($self, $limit, $offset) = @_;
+ $offset ||= 0;
+ return "LIMIT ?, ?", $offset, $limit;},
+ LimitYX => sub {my ($self, $limit, $offset) = @_;
+ $offset ||= 0;
+ return "LIMIT ?, ?", $limit, $offset;},
+ RowNum => sub {
+ my ($self, $limit, $offset) = @_;
+ # HACK below borrowed from SQL::Abstract::Limit. Not perfect, though,
+ # because it brings back an additional column. Should borrow from
+ # DBIx::Class::SQLMaker::LimitDialects, which does the proper job ...
+ # but it says : "!!! THIS IS ALSO HORRIFIC !!! /me ashamed"; so
+ # I'll only take it as last resort; still exploring other ways.
+ # See also L<DBIx::DataModel> : within that ORM an additional layer is
+ # added to take advantage of Oracle scrollable cursors.
+ my $sql = "SELECT * FROM ("
+ . "SELECT subq_A.*, ROWNUM rownum__index FROM (%s) subq_A "
+ . "WHERE ROWNUM <= ?"
+ . ") subq_B WHERE rownum__index >= ?";
+
+ no warnings 'uninitialized'; # in case $limit or $offset is undef
+ # row numbers start at 1
+ return $sql, $offset + $limit, $offset + 1;
+ },
+ );
+
+# builtin join operators with associated sprintf syntax
+my %common_join_syntax = (
+ '<=>' => '%s INNER JOIN %s ON %s',
+ '=>' => '%s LEFT OUTER JOIN %s ON %s',
+ '<=' => '%s RIGHT JOIN %s ON %s',
+ '==' => '%s NATURAL JOIN %s',
+);
+my %right_assoc_join_syntax = %common_join_syntax;
+s/JOIN %s/JOIN (%s)/ foreach values %right_assoc_join_syntax;
+
+# specification of parameters accepted by the new() method
+my %params_for_new = (
+ table_alias => {type => SCALAR|CODEREF, default => '%s AS %s'},
+ column_alias => {type => SCALAR|CODEREF, default => '%s AS %s'},
+ limit_offset => {type => SCALAR|CODEREF, default => 'LimitOffset'},
+ join_syntax => {type => HASHREF, default =>
+ \%common_join_syntax},
+ join_assoc_right => {type => BOOLEAN, default => 0},
+ max_members_IN => {type => SCALAR, optional => 1},
+ sql_dialect => {type => SCALAR, optional => 1},
+);
+
+# builtin collection of parameters, for various databases
+my %sql_dialects = (
+ MsAccess => { join_assoc_right => 1,
+ join_syntax => \%right_assoc_join_syntax},
+ BasisJDBC => { column_alias => "%s %s",
+ max_members_IN => 255 },
+ MySQL_old => { limit_offset => "LimitXY" },
+ Oracle => { limit_offset => "RowNum",
+ max_members_IN => 999,
+ table_alias => '%s %s',
+ column_alias => '%s %s', },
+);
+
+
+# operators for compound queries
+my @set_operators = qw/union union_all intersect minus except/;
+
+# specification of parameters accepted by select, insert, update, delete
+my %params_for_select = (
+ -columns => {type => SCALAR|ARRAYREF, default => '*'},
+ -from => {type => SCALAR|SCALARREF|ARRAYREF},
+ -where => {type => SCALAR|ARRAYREF|HASHREF, optional => 1},
+ (map {-$_ => {type => ARRAYREF, optional => 1}} @set_operators),
+ -group_by => {type => SCALAR|ARRAYREF, optional => 1},
+ -having => {type => SCALAR|ARRAYREF|HASHREF, optional => 1,
+ depends => '-group_by'},
+ -order_by => {type => SCALAR|ARRAYREF|HASHREF, optional => 1},
+ -page_size => {type => SCALAR, optional => 1},
+ -page_index => {type => SCALAR, optional => 1,
+ depends => '-page_size'},
+ -limit => {type => SCALAR, optional => 1},
+ -offset => {type => SCALAR, optional => 1,
+ depends => '-limit'},
+ -for => {type => SCALAR|UNDEF, optional => 1},
+ -want_details => {type => BOOLEAN, optional => 1},
+);
+my %params_for_insert = (
+ -into => {type => SCALAR},
+ -values => {type => SCALAR|ARRAYREF|HASHREF},
+ -returning => {type => SCALAR|ARRAYREF|HASHREF, optional => 1},
+);
+my %params_for_update = (
+ -table => {type => SCALAR},
+ -set => {type => HASHREF},
+ -where => {type => SCALAR|ARRAYREF|HASHREF, optional => 1},
+ -order_by => {type => SCALAR|ARRAYREF|HASHREF, optional => 1},
+ -limit => {type => SCALAR, optional => 1},
+);
+my %params_for_delete = (
+ -from => {type => SCALAR},
+ -where => {type => SCALAR|ARRAYREF|HASHREF, optional => 1},
+ -order_by => {type => SCALAR|ARRAYREF|HASHREF, optional => 1},
+ -limit => {type => SCALAR, optional => 1},
+);
+
+
+#----------------------------------------------------------------------
+# object creation
+#----------------------------------------------------------------------
+
+sub new {
+ my $class = shift;
+ my %params = does($_[0], 'HASH') ? %{$_[0]} : @_;
+
+ # extract params for this subclass
+ my %more_params;
+ foreach my $key (keys %params_for_new) {
+ $more_params{$key} = delete $params{$key} if exists $params{$key};
+ }
+
+ # import params from SQL dialect, if any
+ my $dialect = delete $more_params{sql_dialect};
+ if ($dialect) {
+ my $dialect_params = $sql_dialects{$dialect}
+ or croak "no such sql dialect: $dialect";
+ $more_params{$_} ||= $dialect_params->{$_} foreach keys %$dialect_params;
+ }
+
+ # check parameters
+ my @more_params = %more_params;
+ my $more_self = validate(@more_params, \%params_for_new);
+
+ # call parent constructor
+ my $self = $class->next::method(%params);
+
+ # inject into $self
+ $self->{$_} = $more_self->{$_} foreach keys %$more_self;
+
+ # arguments supplied as scalars are transformed into coderefs
+ ref $self->{column_alias} or $self->_make_AS_through_sprintf('column_alias');
+ ref $self->{table_alias} or $self->_make_AS_through_sprintf('table_alias');
+ ref $self->{limit_offset} or $self->_choose_LIMIT_OFFSET_dialect;
+
+ # regex for parsing join specifications
+ my @join_ops = sort {length($b) <=> length($a) || $a cmp $b}
+ keys %{$self->{join_syntax}};
+ my $joined_ops = join '|', map quotemeta, @join_ops;
+ $self->{join_regex} = qr[
+ ^ # initial anchor
+ ($joined_ops)? # $1: join operator (i.e. '<=>', '=>', etc.))
+ ([[{])? # $2: opening '[' or '{'
+ (.*?) # $3: content of brackets
+ []}]? # closing ']' or '}'
+ $ # final anchor
+ ]x;
+
+ return $self;
+}
+
+#----------------------------------------------------------------------
+# the select method
+#----------------------------------------------------------------------
+
+sub select {
+ my $self = shift;
+
+ # if got positional args, this is not our job, just delegate to the parent
+ return $self->next::method(@_) if !&_called_with_named_args;
+
+ # declare variables and parse arguments;
+ my ($join_info, %aliased_columns);
+ my %args = validate(@_, \%params_for_select);
+
+ # compute join info if the datasource is a join
+ if (ref $args{-from} eq 'ARRAY' && $args{-from}[0] eq '-join') {
+ my @join_args = @{$args{-from}};
+ shift @join_args; # drop initial '-join'
+ $join_info = $self->join(@join_args);
+ $args{-from} = \($join_info->{sql});
+ }
+
+ # reorganize columns; initial members starting with "-" are extracted
+ # into a separate list @post_select, later re-injected into the SQL
+ my @cols = ref $args{-columns} ? @{$args{-columns}} : $args{-columns};
+ my @post_select;
+ push @post_select, shift @cols while @cols && $cols[0] =~ s/^-//;
+ foreach my $col (@cols) {
+ # extract alias, if any
+ if ($col =~ /^(.*[^|\s]) # any non-empty string, not ending with ' ' or '|'
+ \| # followed by a literal '|'
+ (\w+) # followed by a word (the alias))
+ $/x) {
+ $aliased_columns{$2} = $1;
+ $col = $self->column_alias($1, $2);
+ }
+ }
+ $args{-columns} = \@cols;
+
+ # reorganize pagination
+ if ($args{-page_index} || $args{-page_size}) {
+ not exists $args{$_} or croak "-page_size conflicts with $_"
+ for qw/-limit -offset/;
+ $args{-limit} = $args{-page_size};
+ if ($args{-page_index}) {
+ $args{-offset} = ($args{-page_index} - 1) * $args{-page_size};
+ }
+ }
+
+ # generate initial ($sql, @bind), without -order_by (will be handled later)
+ my @old_API_args = @args{qw/-from -columns -where/}; #
+ my ($sql, @bind) = $self->next::method(@old_API_args);
+ unshift @bind, @{$join_info->{bind}} if $join_info;
+
+ # add @post_select clauses if needed (for ex. -distinct)
+ my $post_select = join " ", @post_select;
+ $sql =~ s[^SELECT ][SELECT $post_select ]i if $post_select;
+
+ # add set operators (UNION, INTERSECT, etc) if needed
+ foreach my $set_op (@set_operators) {
+ if ($args{-$set_op}) {
+ my %sub_args = @{$args{-$set_op}};
+ $sub_args{$_} ||= $args{$_} for qw/-columns -from/;
+ my ($sql1, @bind1) = $self->select(%sub_args);
+ (my $sql_op = uc($set_op)) =~ s/_/ /g;
+ $sql .= " $sql_op $sql1";
+ push @bind, @bind1;
+ }
+ }
+
+ # add GROUP BY/HAVING if needed
+ if ($args{-group_by}) {
+ my $sql_grp = $self->where(undef, $args{-group_by});
+ $sql_grp =~ s/\bORDER\b/GROUP/;
+ if ($args{-having}) {
+ my ($sql_having, @bind_having) = $self->where($args{-having});
+ $sql_having =~ s/\bWHERE\b/HAVING/;
+ $sql_grp .= " $sql_having";
+ push @bind, @bind_having;
+ }
+ $sql .= $sql_grp;
+ }
+
+ # add ORDER BY if needed
+ if (my $order = $args{-order_by}) {
+
+ # force scalar into an arrayref
+ $order = [$order] if not ref $order;
+
+ # restructure array data
+ if (ref $order eq 'ARRAY') {
+ my @clone = @$order; # because we will modify items
+
+ # '-' and '+' prefixes are translated into {-desc/asc => } hashrefs
+ foreach my $item (@clone) {
+ next if !$item or ref $item;
+ $item =~ s/^-// and $item = {-desc => $item} and next;
+ $item =~ s/^\+// and $item = {-asc => $item};
+ }
+ $order = \@clone;
+ }
+
+ my $sql_order = $self->where(undef, $order);
+ $sql .= $sql_order;
+ }
+
+ # add LIMIT/OFFSET if needed
+ if (defined $args{-limit}) {
+ my ($limit_sql, @limit_bind)
+ = $self->limit_offset(@args{qw/-limit -offset/});
+ $sql = $limit_sql =~ /%s/ ? sprintf $limit_sql, $sql
+ : "$sql $limit_sql";
+ push @bind, @limit_bind;
+ }
+
+ # add FOR if needed
+ $sql .= " FOR $args{-for}" if $args{-for};
+
+ if ($args{-want_details}) {
+ return {sql => $sql,
+ bind => \@bind,
+ aliased_tables => ($join_info && $join_info->{aliased_tables}),
+ aliased_columns => \%aliased_columns };
+ }
+ else {
+ return ($sql, @bind);
+ }
+}
+
+#----------------------------------------------------------------------
+# insert, update and delete methods
+#----------------------------------------------------------------------
+
+sub insert {
+ my $self = shift;
+
+ my @old_API_args;
+ my $returning_into;
+
+ if (&_called_with_named_args) {
+ # extract named args and translate to old SQLA API
+ my %args = validate(@_, \%params_for_insert);
+ @old_API_args = @args{qw/-into -values/};
+
+ # if present, "-returning" may be a scalar, arrayref or hashref; the latter
+ # is interpreted as .. RETURNING ... INTO ...
+ if (my $returning = $args{-returning}) {
+ if (does($returning, 'HASH')) {
+ my @keys = sort keys %$returning
+ or croak "-returning => {} : the hash is empty";
+ push @old_API_args, {returning => \@keys};
+ $returning_into = [@{$returning}{@keys}];
+ }
+ else {
+ push @old_API_args, {returning => $returning};
+ }
+ }
+ }
+ else {
+ @old_API_args = @_;
+ }
+
+ # get results from parent method
+ my ($sql, @bind) = $self->next::method(@old_API_args);
+
+ # inject more stuff if using Oracle's "RETURNING ... INTO ..."
+ if ($returning_into) {
+ $sql .= ' INTO ' . join(", ", ("?") x @$returning_into);
+ push @bind, @$returning_into;
+ }
+
+ return ($sql, @bind);
+}
+
+sub update {
+ my $self = shift;
+
+ my @old_API_args;
+ my %args;
+ if (&_called_with_named_args) {
+ %args = validate(@_, \%params_for_update);
+ @old_API_args = @args{qw/-table -set -where/};
+ }
+ else {
+ @old_API_args = @_;
+ }
+
+ # call clone of parent method
+ my ($sql, @bind) = $self->_overridden_update(@old_API_args);
+
+ # maybe need to handle additional args
+ $self->_handle_additional_args_for_update_delete(\%args, \$sql, \@bind);
+
+ return ($sql, @bind);
+}
+
+
+sub _handle_additional_args_for_update_delete {
+ my ($self, $args, $sql_ref, $bind_ref) = @_;
+
+ if (defined $args->{-order_by}) {
+ my ($sql_ob, @bind_ob) = $self->_order_by($args->{-order_by});
+ $$sql_ref .= $sql_ob;
+ push @$bind_ref, @bind_ob;
+ }
+ if (defined $args->{-limit}) {
+ # can't call $self->limit_offset(..) because there shouldn't be any offset
+ $$sql_ref .= $self->_sqlcase(' limit ?');
+ push @$bind_ref, $args->{-limit};
+ }
+}
+
+
+
+sub delete {
+ my $self = shift;
+
+ my @old_API_args;
+ my %args;
+ if (&_called_with_named_args) {
+ %args = validate(@_, \%params_for_delete);
+ @old_API_args = @args{qw/-from -where/};
+ }
+ else {
+ @old_API_args = @_;
+ }
+
+ # call parent method
+ my ($sql, @bind) = $self->next::method(@old_API_args);
+
+ # maybe need to handle additional args
+ $self->_handle_additional_args_for_update_delete(\%args, \$sql, \@bind);
+
+ return ($sql, @bind);
+}
+
+#----------------------------------------------------------------------
+# other public methods
+#----------------------------------------------------------------------
+
+# same pattern for 3 invocation methods
+foreach my $attr (qw/table_alias column_alias limit_offset/) {
+ no strict 'refs';
+ *{$attr} = sub {
+ my $self = shift;
+ my $method = $self->{$attr}; # grab reference to method body
+ $self->$method(@_); # invoke
+ };
+}
+
+# invocation method for 'join'
+sub join {
+ my $self = shift;
+
+ # start from the right if right-associative
+ @_ = reverse @_ if $self->{join_assoc_right};
+
+ # shift first single item (a table) before reducing pairs (op, table)
+ my $combined = shift;
+ $combined = $self->_parse_table($combined) unless ref $combined;
+
+ # reduce pairs (op, table)
+ while (@_) {
+ # shift 2 items : next join specification and next table
+ my $join_spec = shift;
+ my $table_spec = shift or croak "join(): improper number of operands";
+
+ $join_spec = $self->_parse_join_spec($join_spec) unless ref $join_spec;
+ $table_spec = $self->_parse_table($table_spec) unless ref $table_spec;
+ $combined = $self->_single_join($combined, $join_spec, $table_spec);
+ }
+
+ return $combined; # {sql=> .., bind => [..], aliased_tables => {..}}
+}
+
+
+# utility for merging several "where" clauses
+sub merge_conditions {
+ my $self = shift;
+ my %merged;
+
+ foreach my $cond (@_) {
+ if (does($cond, 'HASH')) {
+ foreach my $col (sort keys %$cond) {
+ $merged{$col} = $merged{$col} ? [-and => $merged{$col}, $cond->{$col}]
+ : $cond->{$col};
+ }
+ }
+ elsif (does($cond, 'ARRAY')) {
+ $merged{-nest} = $merged{-nest} ? {-and => [$merged{-nest}, $cond]}
+ : $cond;
+ }
+ elsif ($cond) {
+ $merged{$cond} = \"";
+ }
+ }
+ return \%merged;
+}
+
+# utility for calling either bind_param or bind_param_inout
+our $INOUT_MAX_LEN = 99; # chosen arbitrarily; see L<DBI/bind_param_inout>
+sub bind_params {
+ my ($self, $sth, @bind) = @_;
+ $sth->isa('DBI::st') or croak "sth argument is not a DBI statement handle";
+ foreach my $i (0 .. $#bind) {
+ my $val = $bind[$i];
+ my $ref = ref $val || '';
+ if ($ref eq 'SCALAR') {
+ # a scalarref is interpreted as an INOUT parameter
+ $sth->bind_param_inout($i+1, $val, $INOUT_MAX_LEN);
+ }
+ elsif ($ref eq 'ARRAY' and
+ my ($bind_meth, @args) = $self->is_bind_value_with_type($val)) {
+ # either 'bind_param' or 'bind_param_inout', with 2 or 3 args
+ $sth->$bind_meth($i+1, @args);
+ }
+ else {
+ # other cases are passed directly to DBI::bind_param
+ $sth->bind_param($i+1, $val);
+ }
+ }
+}
+
+sub is_bind_value_with_type {
+ my ($self, $val) = @_;
+
+ # compatibility with DBIx::Class syntax of shape [\%args => $val],
+ # see L<DBIx::Class::ResultSet/"DBIC BIND VALUES">
+ if ( @$val == 2
+ && does($val->[0], 'HASH')
+ && grep {$val->[0]{$_}} qw/dbd_attrs sqlt_size
+ sqlt_datatype dbic_colname/) {
+ my $args = $val->[0];
+ if (my $attrs = $args->{dbd_attrs}) {
+ return (bind_param => $val->[1], $attrs);
+ }
+ elsif (my $size = $args->{sqlt_size}) {
+ return (bind_param_inout => $val, $size);
+ }
+ # other options like 'sqlt_datatype', 'dbic_colname' are not supported
+ else {
+ croak "unsupported options for bind type : "
+ . CORE::join(", ", sort keys %$args);
+ }
+
+ # NOTE : the following DBIx::Class shortcuts are not supported
+ # [ $name => $val ] === [ { dbic_colname => $name }, $val ]
+ # [ \$dt => $val ] === [ { sqlt_datatype => $dt }, $val ]
+ # [ undef, $val ] === [ {}, $val ]
+ }
+
+ # in all other cases, this is not a bind value with type
+ return ();
+}
+
+#----------------------------------------------------------------------
+# private utility methods for 'join'
+#----------------------------------------------------------------------
+
+sub _parse_table {
+ my ($self, $table) = @_;
+
+ # extract alias, if any (recognized as "table|alias")
+ ($table, my $alias) = split /\|/, $table, 2;
+
+ # build a table spec
+ return {
+ sql => $self->table_alias($table, $alias),
+ bind => [],
+ name => ($alias || $table),
+ aliased_tables => {$alias ? ($alias => $table) : ()},
+ };
+}
+
+sub _parse_join_spec {
+ my ($self, $join_spec) = @_;
+
+ # parse the join specification
+ $join_spec
+ or croak "empty join specification";
+ my ($op, $bracket, $cond_list) = ($join_spec =~ $self->{join_regex})
+ or croak "incorrect join specification : $join_spec\n$self->{join_regex}";
+ $op ||= '<=>';
+ $bracket ||= '{';
+ $cond_list ||= '';
+
+ # extract constants (strings between quotes), replaced by placeholders
+ my $regex = qr/' # initial quote
+ ( # begin capturing group
+ [^']* # any non-quote chars
+ (?: # begin non-capturing group
+ '' # pair of quotes
+ [^']* # any non-quote chars
+ )* # this non-capturing group 0 or more times
+ ) # end of capturing group
+ ' # ending quote
+ /x;
+ my $placeholder = '_?_'; # unlikely to be counfounded with any value
+ my @constants;
+ while ($cond_list =~ s/$regex/$placeholder/) {
+ push @constants, $1;
+ };
+ s/''/'/g for @constants; # replace pairs of quotes by single quotes
+
+ # accumulate conditions as pairs ($left => \"$op $right")
+ my @conditions;
+ foreach my $cond (split /,/, $cond_list) {
+ # parse the condition (left and right operands + comparison operator)
+ my ($left, $cmp, $right) = split /([<>=!^]{1,2})/, $cond
+ or croak "can't parse join condition: $cond";
+
+ # if operands are not qualified by table/alias name, add sprintf hooks
+ $left = "%1\$s.$left" unless $left =~ /\./;
+ $right = "%2\$s.$right" unless $right =~ /\./ or $right eq $placeholder;
+
+ # add this pair into the list; right operand is either a bind value
+ # or an identifier within the right table
+ $right = $right eq $placeholder ? shift @constants : {-ident => $right};
+ push @conditions, $left, {$cmp => $right};
+ }
+
+ # list becomes an arrayref or hashref (for SQLA->where())
+ my $join_on = $bracket eq '[' ? [@conditions] : {@conditions};
+
+ # return a new join spec
+ return {operator => $op,
+ condition => $join_on};
+}
+
+sub _single_join {
+ my $self = shift;
+
+ # if right-associative, restore proper left-right order in pair
+ @_ = reverse @_ if $self->{join_assoc_right};
+ my ($left, $join_spec, $right) = @_;
+
+ # compute the "ON" clause (assuming it contains '%1$s', '%2$s' for
+ # left/right tables)
+ my ($sql, @bind) = $self->where($join_spec->{condition});
+ $sql =~ s/^\s*WHERE\s+//;
+ $sql = sprintf $sql, $left->{name}, $right->{name};
+
+ # assemble all elements
+ my $syntax = $self->{join_syntax}{$join_spec->{operator}};
+ $sql = sprintf $syntax, $left->{sql}, $right->{sql}, $sql;
+ unshift @bind, @{$left->{bind}}, @{$right->{bind}};
+
+ # build result and return
+ my %result = (sql => $sql, bind => \@bind);
+ $result{name} = ($self->{join_assoc_right} ? $left : $right)->{name};
+ $result{aliased_tables} = $left->{aliased_tables};
+ foreach my $alias (keys %{$right->{aliased_tables}}) {
+ $result{aliased_tables}{$alias} = $right->{aliased_tables}{$alias};
+ }
+
+ return \%result;
+}
+
+
+#----------------------------------------------------------------------
+# override of parent's "_where_field_IN"
+#----------------------------------------------------------------------
+
+sub _where_field_IN {
+ my ($self, $k, $op, $vals) = @_;
+
+ my $max_members_IN = $self->{max_members_IN};
+ if ($max_members_IN && does($vals, 'ARRAY')
+ && @$vals > $max_members_IN) {
+ my @vals = @$vals;
+ my @slices;
+ while (my @slice = splice(@vals, 0, $max_members_IN)) {
+ push @slices, \@slice;
+ }
+ my @clauses = map {{-$op, $_}} @slices;
+ my $connector = $op =~ /^not/i ? '-and' : '-or';
+ unshift @clauses, $connector;
+ my ($sql, @bind) = $self->where({$k => \@clauses});
+ $sql =~ s/\s*where\s*\((.*)\)/$1/i;
+ return ($sql, @bind);
+ }
+ else {
+ $vals = [@$vals] if blessed $vals; # because SQLA dies on blessed arrayrefs
+ return $self->next::method($k, $op, $vals);
+ }
+}
+
+#----------------------------------------------------------------------
+# override of parent's methods for decoding arrayrefs
+#----------------------------------------------------------------------
+
+sub _where_hashpair_ARRAYREF {
+ my ($self, $k, $v) = @_;
+
+ if ($self->is_bind_value_with_type($v)) {
+ $self->_assert_no_bindtype_columns;
+ my $sql = CORE::join ' ', $self->_convert($self->_quote($k)),
+ $self->_sqlcase($self->{cmp}),
+ $self->_convert('?');
+ my @bind = ($v);
+ return ($sql, @bind);
+ }
+ else {
+ return $self->next::method($k, $v);
+ }
+}
+
+
+sub _where_field_op_ARRAYREF {
+ my ($self, $k, $op, $vals) = @_;
+
+ if ($self->is_bind_value_with_type($vals)) {
+ $self->_assert_no_bindtype_columns;
+ my $sql = CORE::join ' ', $self->_convert($self->_quote($k)),
+ $self->_sqlcase($op),
+ $self->_convert('?');
+ my @bind = ($vals);
+ return ($sql, @bind);
+ }
+ else {
+ return $self->next::method($k, $op, $vals);
+ }
+}
+
+sub _assert_no_bindtype_columns {
+ my ($self) = @_;
+ $self->{bindtype} ne 'columns'
+ or croak 'values of shape [$val, \%type] are not compatible'
+ . 'with ...->new(bindtype => "columns")';
+}
+
+sub _insert_values {
+ # unfortunately, we can't just override the ARRAYREF part, so the whole
+ # parent method is copied here
+ my ($self, $data) = @_;
+
+ my (@values, @all_bind);
+ foreach my $column (sort keys %$data) {
+ my $v = $data->{$column};
+
+ $self->_SWITCH_refkind($v, {
+
+ ARRAYREF => sub {
+ if ($self->{array_datatypes}
+ || $self->is_bind_value_with_type($v)) {
+ # if array datatype are activated or this is a [$val, \%type] struct
+ push @values, '?';
+ push @all_bind, $self->_bindtype($column, $v);
+ }
+ else {
+ # otherwise, literal SQL with bind
+ my ($sql, @bind) = @$v;
+ $self->_assert_bindval_matches_bindtype(@bind);
+ push @values, $sql;
+ push @all_bind, @bind;
+ }
+ },
+
+ ARRAYREFREF => sub { # literal SQL with bind
+ my ($sql, @bind) = @${$v};
+ $self->_assert_bindval_matches_bindtype(@bind);
+ push @values, $sql;
+ push @all_bind, @bind;
+ },
+
+ # THINK : anything useful to do with a HASHREF ?
+ HASHREF => sub { # (nothing, but old SQLA passed it through)
+ #TODO in SQLA >= 2.0 it will die instead
+ SQL::Abstract::belch("HASH ref as bind value in insert is not supported");
+ push @values, '?';
+ push @all_bind, $self->_bindtype($column, $v);
+ },
+
+ SCALARREF => sub { # literal SQL without bind
+ push @values, $$v;
+ },
+
+ SCALAR_or_UNDEF => sub {
+ push @values, '?';
+ push @all_bind, $self->_bindtype($column, $v);
+ },
+
+ });
+
+ }
+
+ my $sql = $self->_sqlcase('values')." ( ".CORE::join(", ", @values)." )";
+ return ($sql, @all_bind);
+}
+
+sub _overridden_update {
+ # unfortunately, we can't just override the ARRAYREF part, so the whole
+ # parent method is copied here
+
+ my $self = shift;
+ my $table = $self->_table(shift);
+ my $data = shift || return;
+ my $where = shift;
+
+ # first build the 'SET' part of the sql statement
+ my (@set, @all_bind);
+ SQL::Abstract::puke("Unsupported data type specified to \$sql->update")
+ unless ref $data eq 'HASH';
+
+ for my $k (sort keys %$data) {
+ my $v = $data->{$k};
+ my $r = ref $v;
+ my $label = $self->_quote($k);
+
+ $self->_SWITCH_refkind($v, {
+ ARRAYREF => sub {
+ if ($self->{array_datatypes}
+ || $self->is_bind_value_with_type($v)) {
+ push @set, "$label = ?";
+ push @all_bind, $self->_bindtype($k, $v);
+ }
+ else { # literal SQL with bind
+ my ($sql, @bind) = @$v;
+ $self->_assert_bindval_matches_bindtype(@bind);
+ push @set, "$label = $sql";
+ push @all_bind, @bind;
+ }
+ },
+ ARRAYREFREF => sub { # literal SQL with bind
+ my ($sql, @bind) = @${$v};
+ $self->_assert_bindval_matches_bindtype(@bind);
+ push @set, "$label = $sql";
+ push @all_bind, @bind;
+ },
+ SCALARREF => sub { # literal SQL without bind
+ push @set, "$label = $$v";
+ },
+ HASHREF => sub {
+ my ($op, $arg, @rest) = %$v;
+
+ SQL::Abstract::puke(
+ 'Operator calls in update must be in the form { -op => $arg }'
+ ) if (@rest or not $op =~ /^\-(.+)/);
+
+ local $self->{_nested_func_lhs} = $k;
+ my ($sql, @bind) = $self->_where_unary_op ($1, $arg);
+
+ push @set, "$label = $sql";
+ push @all_bind, @bind;
+ },
+ SCALAR_or_UNDEF => sub {
+ push @set, "$label = ?";
+ push @all_bind, $self->_bindtype($k, $v);
+ },
+ });
+ }
+
+ # generate sql
+ my $sql = $self->_sqlcase('update') . " $table " . $self->_sqlcase('set ')
+ . CORE::join ', ', @set;
+
+ if ($where) {
+ my($where_sql, @where_bind) = $self->where($where);
+ $sql .= $where_sql;
+ push @all_bind, @where_bind;
+ }
+
+ return wantarray ? ($sql, @all_bind) : $sql;
+}
+
+#----------------------------------------------------------------------
+# method creations through closures
+#----------------------------------------------------------------------
+
+sub _make_AS_through_sprintf {
+ my ($self, $attribute) = @_;
+ my $syntax = $self->{$attribute};
+ $self->{$attribute} = sub {
+ my ($self, $name, $alias) = @_;
+ return $alias ? sprintf($syntax, $name, $alias) : $name;
+ };
+}
+
+sub _choose_LIMIT_OFFSET_dialect {
+ my $self = shift;
+ my $dialect = $self->{limit_offset};
+ my $method = $limit_offset_dialects{$dialect}
+ or croak "no such limit_offset dialect: $dialect";
+ $self->{limit_offset} = $method;
+};
+
+
+#----------------------------------------------------------------------
+# utility to decide if the method was called with named or positional args
+#----------------------------------------------------------------------
+
+sub _called_with_named_args {
+ return $_[0] && !ref $_[0] && substr($_[0], 0, 1) eq '-';
+}
+
+
+1; # End of SQL::Abstract::More
+
+__END__
+
+=head1 NAME
+
+SQL::Abstract::More - extension of SQL::Abstract with more constructs and more flexible API
+
+=head1 DESCRIPTION
+
+Generates SQL from Perl data structures. This is a subclass of
+L<SQL::Abstract>, fully compatible with the parent class, but with
+some additions :
+
+=over
+
+=item *
+
+additional SQL constructs like C<-union>, C<-group_by>, C<join>, etc.
+
+=item *
+
+methods take arguments as named parameters instead of positional parameters,
+so that various SQL fragments are more easily identified
+
+=item *
+
+values passed to C<select>, C<insert> or C<update> can directly incorporate
+information about datatypes, in the form of arrayrefs of shape
+C<< [{dbd_attrs => \%type}, $value] >>
+
+=back
+
+
+This module was designed for the specific needs of
+L<DBIx::DataModel>, but is published as a standalone distribution,
+because it may possibly be useful for other needs.
+
+=head1 SYNOPSIS
+
+ my $sqla = SQL::Abstract::More->new();
+ my ($sql, @bind);
+
+ # ex1: named parameters, select DISTINCT, ORDER BY, LIMIT/OFFSET
+ ($sql, @bind) = $sqla->select(
+ -columns => [-distinct => qw/col1 col2/],
+ -from => 'Foo',
+ -where => {bar => {">" => 123}},
+ -order_by => [qw/col1 -col2 +col3/], # BY col1, col2 DESC, col3 ASC
+ -limit => 100,
+ -offset => 300,
+ );
+
+ # ex2: column aliasing, join
+ ($sql, @bind) = $sqla->select(
+ -columns => [ qw/Foo.col_A|a Bar.col_B|b /],
+ -from => [-join => qw/Foo fk=pk Bar /],
+ );
+
+ # ex3: INTERSECT (or similar syntax for UNION)
+ ($sql, @bind) = $sqla->select(
+ -columns => [qw/col1 col2/],
+ -from => 'Foo',
+ -where => {col1 => 123},
+ -intersect => [ -columns => [qw/col3 col4/],
+ -from => 'Bar',
+ -where => {col3 => 456},
+ ],
+ );
+
+ # ex4: passing datatype specifications
+ ($sql, @bind) = $sqla->select(
+ -from => 'Foo',
+ -where => {bar => [{dbd_attrs => {ora_type => ORA_XMLTYPE}}, $xml]},
+ );
+ my $sth = $dbh->prepare($sql);
+ $sqla->bind_params($sth, @bind);
+ $sth->execute;
+
+ # merging several criteria
+ my $merged = $sqla->merge_conditions($cond_A, $cond_B, ...);
+ ($sql, @bind) = $sqla->select(..., -where => $merged, ..);
+
+ # insert / update / delete
+ ($sql, @bind) = $sqla->insert(
+ -into => $table,
+ -values => {col => $val, ...},
+ );
+ ($sql, @bind) = $sqla->update(
+ -table => $table,
+ -set => {col => $val, ...},
+ -where => \%conditions,
+ );
+ ($sql, @bind) = $sqla->delete (
+ -from => $table
+ -where => \%conditions,
+ );
+
+=head1 CLASS METHODS
+
+=head2 new
+
+ my $sqla = SQL::Abstract::More->new(%options);
+
+where C<%options> may contain any of the options for the parent
+class (see L<SQL::Abstract/new>), plus the following :
+
+=over
+
+=item table_alias
+
+A C<sprintf> format description for generating table aliasing clauses.
+The default is C<%s AS %s>.
+Can also be supplied as a method coderef (see L</"Overriding methods">).
+
+=item column_alias
+
+A C<sprintf> format description for generating column aliasing clauses.
+The default is C<%s AS %s>.
+Can also be supplied as a method coderef.
+
+=item limit_offset
+
+Name of a "limit-offset dialect", which can be one of
+C<LimitOffset>, C<LimitXY>, C<LimitYX> or C<RowNum>;
+see L<SQL::Abstract::Limit> for an explanation of those dialects.
+Here, unlike the L<SQL::Abstract::Limit> implementation,
+limit and offset values are treated as regular values,
+with placeholders '?' in the SQL; values are postponed to the
+C<@bind> list.
+
+The argument can also be a coderef (see below
+L</"Overriding methods">). That coderef takes C<$self, $limit, $offset>
+as arguments, and should return C<($sql, @bind)>. If C<$sql> contains
+C<%s>, it is treated as a C<sprintf> format string, where the original
+SQL is injected into C<%s>.
+
+
+=item join_syntax
+
+A hashref where keys are abbreviations for join
+operators to be used in the L</join> method, and
+values are associated SQL clauses with placeholders
+in C<sprintf> format. The default is described
+below under the L</join> method.
+
+=item join_assoc_right
+
+A boolean telling if multiple joins should be associative
+on the right or on the left. Default is false (i.e. left-associative).
+
+=item max_members_IN
+
+An integer specifying the maximum number of members in a "IN" clause.
+If the number of given members is greater than this maximum,
+C<SQL::Abstract::More> will automatically split it into separate
+clauses connected by 'OR' (or connected by 'AND' if used with the
+C<-not_in> operator).
+
+ my $sqla = SQL::Abstract::More->new(max_members_IN => 3);
+ ($sql, @bind) = $sqla->select(
+ -from => 'Foo',
+ -where => {foo => {-in => [1 .. 5]}},
+ bar => {-not_in => [6 .. 10]}},
+ );
+ # .. WHERE ( (foo IN (?,?,?) OR foo IN (?, ?))
+ # AND (bar NOT IN (?,?,?) AND bar NOT IN (?, ?)) )
+
+
+=item sql_dialect
+
+This is actually a "meta-argument" : it injects a collection
+of regular arguments, tuned for a specific SQL dialect.
+Dialects implemented so far are :
+
+=over
+
+=item MsAccess
+
+For Microsoft Access. Overrides the C<join> syntax to be right-associative.
+
+=item BasisJDBC
+
+For Livelink Collection Server (formerly "Basis"), accessed
+through a JDBC driver. Overrides the C<column_alias> syntax.
+Sets C<max_members_IN> to 255.
+
+=item MySQL_old
+
+For old versions of MySQL. Overrides the C<limit_offset> syntax.
+Recent versions of MySQL do not need that because they now
+implement the regular "LIMIT ? OFFSET ?" ANSI syntax.
+
+=item Oracle
+
+For Oracle. Overrides the C<limit_offset> to use the "RowNum" dialect
+(beware, this injects an additional column C<rownum__index> into your
+resultset). Also sets C<max_members_IN> to 999.
+
+=back
+
+=back
+
+=head3 Overriding methods
+
+Several arguments to C<new()> can be references to method
+implementations instead of plain scalars : this allows you to
+completely redefine a behaviour without the need to subclass. Just
+supply a regular method body as a code reference : for example, if you
+need another implementation for LIMIT-OFFSET, you could write
+
+ my $sqla = SQL::Abstract::More->new(
+ limit_offset => sub {
+ my ($self, $limit, $offset) = @_;
+ defined $limit or die "NO LIMIT!"; #:-)
+ $offset ||= 0;
+ my $last = $offset + $limit;
+ return ("ROWS ? TO ?", $offset, $last); # ($sql, @bind)
+ });
+
+
+=head1 INSTANCE METHODS
+
+=head2 select
+
+ # positional parameters, directly passed to the parent class
+ ($sql, @bind) = $sqla->select($table, $columns, $where, $order);
+
+ # named parameters, handled in this class
+ ($sql, @bind) = $sqla->select(
+ -columns => \@columns,
+ # OR: -columns => [-distinct => @columns],
+ -from => $table || \@joined_tables,
+ -where => \%where,
+ -union => [ %select_subargs ], # OR -intersect, -minus, etc
+ -order_by => \@order,
+ -group_by => \@group_by,
+ -having => \%having_criteria,
+ -limit => $limit, -offset => $offset,
+ # OR: -page_size => $size, -page_index => $index,
+ -for => $purpose,
+ );
+
+ my $details = $sqla->select(..., want_details => 1);
+ # keys in %$details: sql, bind, aliased_tables, aliased_columns
+
+If called with positional parameters, as in L<SQL::Abstract>,
+C<< select() >> just forwards the call to the parent class. Otherwise, if
+called with named parameters, as in the example above, some additional
+SQL processing is performed.
+
+The following named arguments can be specified :
+
+=over
+
+=item C<< -columns => \@columns >>
+
+C<< \@columns >> is a reference to an array
+of SQL column specifications (i.e. column names,
+C<*> or C<table.*>, functions, etc.).
+
+A '|' in a column is translated into a column aliasing clause:
+this is convenient when
+using perl C<< qw/.../ >> operator for columns, as in
+
+ -columns => [ qw/table1.longColumn|t1lc table2.longColumn|t2lc/ ]
+
+SQL column aliasing is then generated through the L</column_alias> method.
+
+Initial items in C<< @columns >> that start with a minus sign
+are shifted from the array, i.e. they are not considered as column
+names, but are re-injected later into the SQL (without the minus sign),
+just after the C<SELECT> keyword. This is especially useful for
+
+ $sqla->select(..., -columns => [-DISTINCT => @columns], ...);
+
+However, it may also be useful for other purposes, like
+vendor-specific SQL variants :
+
+ # MySQL features
+ ->select(..., -columns => [-STRAIGHT_JOIN => @columns], ...);
+ ->select(..., -columns => [-SQL_SMALL_RESULT => @columns], ...);
+
+ # Oracle hint
+ ->select(..., -columns => ["-/*+ FIRST_ROWS (100) */" => @columns], ...);
+
+The argument to C<-columns> can also be a string instead of
+an arrayref, like for example
+C<< "c1 AS foobar, MAX(c2) AS m_c2, COUNT(c3) AS n_c3" >>;
+however this is mainly for backwards compatibility. The
+recommended way is to use the arrayref notation as explained above :
+
+ -columns => [ qw/ c1|foobar MAX(c2)|m_c2 COUNT(c3)|n_c3 / ]
+
+If omitted, C<< -columns >> takes '*' as default argument.
+
+=item C<< -from => $table || \@joined_tables >>
+
+
+=item C<< -where => $criteria >>
+
+Like in L<SQL::Abstract>, C<< $criteria >> can be
+a plain SQL string like C<< "col1 IN (3, 5, 7, 11) OR col2 IS NOT NULL" >>;
+but in most cases, it will rather be a reference to a hash or array of
+conditions that will be translated into SQL clauses, like
+for example C<< {col1 => 'val1', col2 => 'val2'} >>.
+The structure of that hash or array can be nested to express complex
+boolean combinations of criteria; see
+L<SQL::Abstract/"WHERE CLAUSES"> for a detailed description.
+
+When using hashrefs or arrayrefs, leaf values can be "bind values with types";
+see the L</"BIND VALUES WITH TYPES"> section below.
+
+=item C<< -union => [ %select_subargs ] >>
+
+=item C<< -union_all => [ %select_subargs ] >>
+
+=item C<< -intersect => [ %select_subargs ] >>
+
+=item C<< -except => [ %select_subargs ] >>
+
+=item C<< -minus => [ %select_subargs ] >>
+
+generates a compound query using set operators such as C<UNION>,
+C<INTERSECT>, etc. The argument C<%select_subargs> contains a nested
+set of parameters like for the main select (i.e. C<-columns>,
+C<-from>, C<-where>, etc.); however, arguments C<-columns> and
+C<-from> can be omitted, in which case they will be copied from the
+main select(). Several levels of set operators can be nested.
+
+=item C<< -group_by => "string" >> or C<< -group_by => \@array >>
+
+adds a C<GROUP BY> clause in the SQL statement. Grouping columns are
+specified either by a plain string or by an array of strings.
+
+=item C<< -having => "string" >> or C<< -having => \%criteria >>
+
+adds a C<HAVING> clause in the SQL statement (only makes
+sense together with a C<GROUP BY> clause).
+This is like a C<-where> clause, except that the criteria
+are applied after grouping has occured.
+
+
+=item C<< -order_by => \@order >>
+
+C<< \@order >> is a reference to a list
+of columns for sorting. Columns can
+be prefixed by '+' or '-' for indicating sorting directions,
+so for example C<< -orderBy => [qw/-col1 +col2 -col3/] >>
+will generate the SQL clause
+C<< ORDER BY col1 DESC, col2 ASC, col3 DESC >>.
+
+Column names C<asc> and C<desc> are treated as exceptions to this
+rule, in order to preserve compatibility with L<SQL::Abstract>.
+So C<< -orderBy => [-desc => 'colA'] >> yields
+C<< ORDER BY colA DESC >> and not C<< ORDER BY desc DEC, colA >>.
+Any other syntax supported by L<SQL::Abstract> is also
+supported here; see L<SQL::Abstract/"ORDER BY CLAUSES"> for examples.
+
+The whole C<< -order_by >> parameter can also be a plain SQL string
+like C<< "col1 DESC, col3, col2 DESC" >>.
+
+=item C<< -page_size => $page_size >>
+
+specifies how many rows will be retrieved per "page" of data.
+Default is unlimited (or more precisely the maximum
+value of a short integer on your system).
+When specified, this parameter automatically implies C<< -limit >>.
+
+=item C<< -page_index => $page_index >>
+
+specifies the page number (starting at 1). Default is 1.
+When specified, this parameter automatically implies C<< -offset >>.
+
+=item C<< -limit => $limit >>
+
+limit to the number of rows that will be retrieved.
+Automatically implied by C<< -page_size >>.
+
+=item C<< -offset => $offset >>
+
+Automatically implied by C<< -page_index >>.
+Defaults to 0.
+
+=item C<< -for => $clause >>
+
+specifies an additional clause to be added at the end of the SQL statement,
+like C<< -for => 'READ ONLY' >> or C<< -for => 'UPDATE' >>.
+
+=item C<< -want_details => 1 >>
+
+If true, the return value will be a hashref instead of the usual
+C<< ($sql, @bind) >>. The hashref contains the following keys :
+
+=over
+
+=item sql
+
+generated SQL
+
+=item bind
+
+bind values
+
+=item aliased_tables
+
+a hashref of C<< {table_alias => table_name} >> encountered while
+parsing the C<-from> parameter.
+
+=item aliased_columns
+
+a hashref of C<< {column_alias => column_name} >> encountered while
+parsing the C<-columns> parameter.
+
+=back
+
+
+=back
+
+
+
+=head2 insert
+
+ # positional parameters, directly passed to the parent class
+ ($sql, @bind) = $sqla->insert($table, \@values || \%fieldvals, \%options);
+
+ # named parameters, handled in this class
+ ($sql, @bind) = $sqla->insert(
+ -into => $table,
+ -values => {col => $val, ...},
+ -returning => $return_structure,
+ );
+
+Like for L</select>, values assigned to columns can have associated
+SQL types; see L</"BIND VALUES WITH TYPES">.
+
+Named parameters to the C<insert()> method are just syntactic sugar
+for better readability of the client's code. Parameters
+C<-into> and C<-values> are passed verbatim to the parent method.
+Parameter C<-returning> is optional and only
+supported by some database vendors (see L<SQL::Abstract/insert>);
+if the C<$return_structure> is
+
+=over
+
+=item *
+
+a scalar or an arrayref, it is passed directly to the parent method
+
+=item *
+
+a hashref, it is interpreted as a SQL clause "RETURNING .. INTO ..",
+as required in particular by Oracle. Hash keys are field names, and
+hash values are references to variables that will receive the
+results. Then it is the client code's responsibility
+to use L<DBD::Oracle/bind_param_inout> for binding the variables
+and retrieving the results, but the L</bind_params> method in the
+present module is there for help. Example:
+
+ ($sql, @bind) = $sqla->insert(
+ -into => $table,
+ -values => {col => $val, ...},
+ -returning => {key_col => \my $generated_key},
+ );
+
+ my $sth = $dbh->prepare($sql);
+ $sqla->bind_params($sth, @bind);
+ $sth->execute;
+ print "The new key is $generated_key";
+
+=back
+
+
+=head2 update
+
+ # positional parameters, directly passed to the parent class
+ ($sql, @bind) = $sqla->update($table, \%fieldvals, \%where);
+
+ # named parameters, handled in this class
+ ($sql, @bind) = $sqla->update(
+ -table => $table,
+ -set => {col => $val, ...},
+ -where => \%conditions,
+ -order_by => \@order,
+ -limit => $limit,
+ );
+
+This works in the same spirit as the L</insert> method above.
+Positional parameters are supported for backwards compatibility
+with the old API; but named parameters should be preferred because
+they improve the readability of the client's code.
+
+Few DBMS would support parameters C<-order_by> and C<-limit>, but
+MySQL does -- see L<http://dev.mysql.com/doc/refman/5.6/en/update.html>.
+
+
+=head2 delete
+
+ # positional parameters, directly passed to the parent class
+ ($sql, @bind) = $sqla->delete($table, \%where);
+
+ # named parameters, handled in this class
+ ($sql, @bind) = $sqla->delete (
+ -from => $table
+ -where => \%conditions,
+ -order_by => \@order,
+ -limit => $limit,
+
+ );
+
+Positional parameters are supported for backwards compatibility
+with the old API; but named parameters should be preferred because
+they improve the readability of the client's code.
+
+Few DBMS would support parameters C<-order_by> and C<-limit>, but
+MySQL does -- see L<http://dev.mysql.com/doc/refman/5.6/en/update.html>.
+
+=head2 table_alias
+
+ my $sql = $sqla->table_alias($table_name, $alias);
+
+Returns the SQL fragment for aliasing a table.
+If C<$alias> is empty, just returns C<$table_name>.
+
+=head2 column_alias
+
+Like C<table_alias>, but for column aliasing.
+
+=head2 limit_offset
+
+ ($sql, @bind) = $sqla->limit_offset($limit, $offset);
+
+Generates C<($sql, @bind)> for a LIMIT-OFFSET clause.
+
+=head2 join
+
+ my $join_info = $sqla->join(
+ <table0> <join_1> <table_1> ... <join_n> <table_n>
+ );
+ my $sth = $dbh->prepare($join_info->{sql});
+ $sth->execute(@{$join_info->{bind}})
+ while (my ($alias, $aliased) = each %{$join_info->{aliased_tables}}) {
+ say "$alias is an alias for table $aliased";
+ }
+
+Generates join information for a JOIN clause, taking as input
+a collection of joined tables with their join conditions.
+The following example gives an idea of the available syntax :
+
+ ($sql, @bind) = $sqla->join(qw[
+ Table1|t1 ab=cd Table2|t2
+ <=>{ef>gh,ij<kl,mn='foobar'} Table3
+ =>{t1.op=qr} Table4
+ ]);
+
+This will generate
+
+ Table1 AS t1 INNER JOIN Table2 AS t2 ON t1.ab=t2.cd
+ INNER JOIN Table3 ON t2.ef>Table3.gh
+ AND t2.ij<Table3.kl
+ AND t2.mn=?
+ LEFT JOIN Table4 ON t1.op=Table4.qr
+
+with one bind value C<foobar>.
+
+More precisely, the arguments to C<join()> should be a list
+containing an odd number of elements, where the odd positions
+are I<table specifications> and the even positions are
+I<join specifications>.
+
+=head3 Table specifications
+
+A table specification for join is a string containing
+the table name, possibly followed by a vertical bar
+and an alias name. For example C<Table1> or C<Table1|t1>
+are valid table specifications.
+
+These are converted into internal hashrefs with keys
+C<sql>, C<bind>, C<name>, C<aliased_tables>, like this :
+
+ {
+ sql => "Table1 AS t1"
+ bind => [],
+ name => "t1"
+ aliased_tables => {"t1" => "Table1"}
+ }
+
+Such hashrefs can be passed directly as arguments,
+instead of the simple string representation.
+
+=head3 Join specifications
+
+A join specification is a string containing
+an optional I<join operator>, possibly followed
+by a pair of curly braces or square brackets
+containing the I<join conditions>.
+
+Default builtin join operators are
+C<< <=> >>, C<< => >>, C<< <= >>, C<< == >>,
+corresponding to the following
+SQL JOIN clauses :
+
+ '<=>' => '%s INNER JOIN %s ON %s',
+ '=>' => '%s LEFT OUTER JOIN %s ON %s',
+ '<=' => '%s RIGHT JOIN %s ON %s',
+ '==' => '%s NATURAL JOIN %s',
+
+This operator table can be overridden through
+the C<join_syntax> parameter of the L</new> method.
+
+The join conditions are a comma-separated list
+of binary column comparisons, like for example
+
+ {ab=cd,Table1.ef<Table2.gh}
+
+Table names may be explicitly given using dot notation,
+or may be implicit, in which case they will be filled
+automatically from the names of operands on the
+left-hand side and right-hand side of the join.
+
+Strings within quotes will be treated as bind values instead
+of column names; pairs of quotes within such values become
+single quotes. Ex.
+
+ {ab=cd,ef='foo''bar',gh<ij}
+
+becomes
+
+ ON Table1.ab=Table2.cd AND Table1.ef=? AND Table1.gh<Table2.ij
+ # bind value: "foo'bar"
+
+In accordance with L<SQL::Abstract> common conventions,
+if the list of comparisons is within curly braces, it will
+become an C<AND>; if it is within square brackets, it will
+become an C<OR>.
+
+Join specifications expressed as strings
+are converted into internal hashrefs with keys
+C<operator> and C<condition>, like this :
+
+ {
+ operator => '<=>',
+ condition => { '%1$s.ab' => {'=' => {-ident => '%2$s.cd'}},
+ '%1$s.ef' => {'=' => {-ident => 'Table2.gh'}}},
+ }
+
+The C<operator> is a key into the C<join_syntax> table; the associated
+value is a C<sprintf> format string, with placeholders for the left and
+right operands, and the join condition. The C<condition> is a
+structure suitable for being passed as argument to
+L<SQL::Abstract/where>. Places where the names of left/right tables
+(or their aliases) are expected should be expressed as C<sprintf>
+placeholders, i.e. respectively C<%1$s> and C<%2$s>. Usually the
+right-hand side of the condition refers to a column of the right
+table; in such case it should B<not> belong to the C<@bind> list, so
+this is why we need to use the C<-ident> operator from
+L<SQL::Abstract>. Only when the right-hand side is a string constant
+(string within quotes) does it become a bind value : for example
+
+ ->join(qw/Table1 {ab=cd,ef='foobar'}) Table2/)
+
+is parsed into
+
+ [ 'Table1',
+ { operator => '<=>',
+ condition => { '%1$s.ab' => {'=' => {-ident => '%2$s.cd'}},
+ '%1$s.ef' => {'=' => 'foobar'} },
+ },
+ 'Table2',
+ ]
+
+
+Hashrefs for join specifications as shown above can be passed directly
+as arguments, instead of the simple string representation.
+
+=head3 Return value
+
+The structure returned by C<join()> is a hashref with
+the following keys :
+
+=over
+
+=item sql
+
+a string containing the generated SQL
+
+=item bind
+
+an arrayref of bind values
+
+=item aliased_tables
+
+a hashref where keys are alias names and values are names of aliased tables.
+
+=back
+
+
+=head2 merge_conditions
+
+ my $conditions = $sqla->merge_conditions($cond_A, $cond_B, ...);
+
+This utility method takes a list of "C<where>" conditions and
+merges all of them in a single hashref. For example merging
+
+ ( {a => 12, b => {">" => 34}},
+ {b => {"<" => 56}, c => 78} )
+
+produces
+
+ {a => 12, b => [-and => {">" => 34}, {"<" => 56}], c => 78});
+
+
+=head2 bind_params
+
+ $sqla->bind_params($sth, @bind);
+
+For each C<$value> in C<@bind>:
+
+=over
+
+=item *
+
+if the value is a scalarref, call
+
+ $sth->bind_param_inout($index, $value, $INOUT_MAX_LEN)
+
+(see L<DBI/bind_param_inout>). C<$INOUT_MAX_LEN> defaults to
+99, which should be good enough for most uses; should you need another value,
+you can change it by setting
+
+ local $SQL::Abstract::More::INOUT_MAX_LEN = $other_value;
+
+=item *
+
+if the value is an arrayref that matches L</is_bind_value_with_type>,
+then call the method and arguments returned by L</is_bind_value_with_type>.
+
+=item *
+
+for all other cases, call
+
+ $sth->bind_param($index, $value);
+
+=back
+
+This method is useful either as a convenience for Oracle
+statements of shape C<"INSERT ... RETURNING ... INTO ...">
+(see L</insert> method above), or as a way to indicate specific
+datatypes to the database driver.
+
+=head2 is_bind_value_with_type
+
+ my ($method, @args) = $sqla->is_bind_value_with_type($value);
+
+
+If C<$value> is a ref to a pair C<< [\%args, $orig_value] >> :
+
+
+=over
+
+=item *
+
+if C<%args> is of shape C<< {dbd_attrs => \%sql_type} >>,
+then return C<< ('bind_param', $orig_value, \%sql_type) >>.
+
+=item *
+
+if C<%args> is of shape C<< {sqlt_size => $num} >>,
+then return C<< ('bind_param_inout', $orig_value, $num) >>.
+
+=back
+
+Otherwise, return C<()>.
+
+
+
+=head1 BIND VALUES WITH TYPES
+
+At places where L<SQL::Abstract> would expect a plain value,
+C<SQL::Abstract::More> also accepts a pair, i.e. an arrayref of 2
+elements, where the first element is a type specification, and the
+second element is the value. This is convenient when the DBD driver needs
+additional information about the values used in the statement.
+
+The usual type specification is a hashref C<< {dbd_attrs => \%type} >>,
+where C<\%type> is passed directly as third argument to
+L<DBI/bind_param>, and therefore is specific to the DBD driver.
+
+Another form of type specification is C<< {sqlt_size => $num} >>,
+where C<$num> will be passed as buffer size to L<DBI/bind_param_inout>.
+
+Here are some examples
+
+ ($sql, @bind) = $sqla->insert(
+ -into => 'Foo',
+ -values => {bar => [{dbd_attrs => {ora_type => ORA_XMLTYPE}}]},
+ );
+ ($sql, @bind) = $sqla->select(
+ -from => 'Foo',
+ -where => {d_begin => {">" => [{dbd_attrs => {ora_type => ORA_DATE}},
+ $some_date]}},
+ );
+
+
+When using this feature, the C<@bind> array will contain references
+that cannot be passed directly to L<DBI> methods; so you should use
+L</bind_params> from the present module to perform the appropriate
+bindings before executing the statement.
+
+
+=head1 TODO
+
+Future versions may include some of these features :
+
+=over
+
+=item *
+
+support for C<WITH> initial clauses, and C<WITH RECURSIVE>.
+
+=item *
+
+support for Oracle-specific syntax for recursive queries
+(START_WITH, PRIOR, CONNECT_BY NOCYCLE, CONNECT SIBLINGS, etc.)
+
+=item *
+
+support for INSERT variants
+
+ INSERT .. DEFAULT VALUES
+ INSERT .. VALUES(), VALUES()
+
+=item *
+
+support for MySQL C<LOCK_IN_SHARE_MODE>
+
+=item *
+
+new constructor option
+
+ ->new(..., select_implicitly_for => $string, ...)
+
+This would provide a default values for the C<-for> parameter.
+
+=back
+
+=head1 AUTHOR
+
+Laurent Dami, C<< <laurent.dami at justice.ge.ch> >>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to C<bug-sql-abstract-more at rt.cpan.org>, or through
+the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=SQL-Abstract-More>. I will be notified, and then you'll
+automatically be notified of progress on your bug as I make changes.
+
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc SQL::Abstract::More
+
+
+You can also look for information at:
+
+=over 4
+
+=item RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=SQL-Abstract-More>
+
+=item AnnoCPAN: Annotated CPAN documentation
+
+L<http://annocpan.org/dist/SQL-Abstract-More>
+
+=item CPAN Ratings
+
+L<http://cpanratings.perl.org/d/SQL-Abstract-More>
+
+=item MetaCPAN
+
+L<https://metacpan.org/module/SQL::Abstract::More>
+
+=back
+
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright 2011, 2012 Laurent Dami.
+
+This program is free software; you can redistribute it and/or modify it
+under the terms of either: the GNU General Public License as published
+by the Free Software Foundation; or the Artistic License.
+
+See http://dev.perl.org/licenses/ for more information.
+
+=cut
+
+
@@ -8,7 +8,7 @@ use Test::More;
use SQL::Abstract::Test import => [qw/is_same_sql_bind/];
use constant N_DBI_MOCK_TESTS => 2;
-use constant N_BASIC_TESTS => 51;
+use constant N_BASIC_TESTS => 57;
plan tests => (N_BASIC_TESTS + N_DBI_MOCK_TESTS);
diag( "Testing SQL::Abstract::More $SQL::Abstract::More::VERSION, Perl $], $^X" );
@@ -140,13 +140,16 @@ is_same_sql_bind(
($sql, @bind) = $sqla->select(
-columns => [qw/foo SUM(bar)|sum_bar/],
-from => 'Foo',
- -group_by => [qw/-foo/],
+ -group_by => [qw/foo/],
-having => {sum_bar => {">" => 10}},
);
is_same_sql_bind(
$sql, \@bind,
- "SELECT foo, SUM(bar) AS sum_bar FROM Foo GROUP BY foo DESC HAVING sum_bar > ?", [10],
+ "SELECT foo, SUM(bar) AS sum_bar FROM Foo GROUP BY foo HAVING sum_bar > ?", [10],
);
+# NOTE : this test used to be -group_by => [qw/-foo/], generating "GROUP BY foo DESC";
+# but this made no sense as SQL.
+
#-limit alone
($sql, @bind) = $sqla->select(
@@ -158,6 +161,19 @@ is_same_sql_bind(
"SELECT * FROM Foo LIMIT ? OFFSET ?", [100, 0],
);
+
+($sql, @bind) = $sqla->select(
+ -from => 'Foo',
+ -limit => 0,
+);
+is_same_sql_bind(
+ $sql, \@bind,
+ "SELECT * FROM Foo LIMIT ? OFFSET ?", [0, 0],
+ "limit 0",
+);
+
+
+
#-limit / -offset
($sql, @bind) = $sqla->select(
-from => 'Foo',
@@ -207,6 +223,30 @@ is_deeply($details->{aliased_tables}, {f => 'Foo', b => 'Bar'},
is_deeply($details->{aliased_columns}, {c1 => 'f.col1', c2 => 'b.col2'},
"aliased columns");
+
+# aliasing, do not conflict with "||" operator
+($sql, @bind) = $sqla->select(
+ -columns => [qw/A||B C||D|cd (E||F||G)|efg true|false|bool/],
+ -from => 'Foo',
+);
+is_same_sql_bind(
+ $sql, \@bind,
+ "SELECT A||B, C||D AS cd, (E||F||G) AS efg, true|false AS bool FROM Foo", [],
+ "aliased cols with '|'"
+);
+
+($sql, @bind) = $sqla->select(
+ -columns => [qw/NULL|a1 2|a2 x|a3/],
+ -from => 'Foo',
+);
+is_same_sql_bind(
+ $sql, \@bind,
+ "SELECT NULL AS a1, 2 AS a2, x AS a3 FROM Foo", [],
+ "aliased cols with '|', single char on left-hand side"
+);
+
+
+
# bind_params with SQL types
($sql, @bind) = $sqla->select(
-from => 'Foo',
@@ -350,6 +390,19 @@ is_same_sql_bind(
[]
);
+($sql, @bind) = $sqla->select(
+ -from => 'Foo',
+ -limit => 10,
+ -offset => 5,
+);
+
+is_same_sql_bind(
+ $sql, \@bind,
+ "SELECT * FROM (SELECT subq_A.*, ROWNUM rownum__index FROM (SELECT * FROM Foo) subq_A WHERE ROWNUM <= ?) subq_B WHERE rownum__index >= ?",
+ [15, 6],
+);
+
+
#----------------------------------------------------------------------
@@ -588,6 +641,25 @@ is_same_sql_bind(
);
+# MySQL supports -limit and -order_by in updates !
+# see http://dev.mysql.com/doc/refman/5.6/en/update.html
+($sql, @bind) = $sqla->update(
+ -table => 'Foo',
+ -set => {foo => 1, bar => 2},
+ -where => {buz => 3},
+ -order_by => 'baz',
+ -limit => 10,
+);
+is_same_sql_bind(
+ $sql, \@bind,
+ 'UPDATE Foo SET bar = ?, foo = ? WHERE buz = ? ORDER BY baz LIMIT ?',
+ [2, 1, 3, 10],
+ "update with -order_by/-limit",
+);
+
+
+
+
#----------------------------------------------------------------------
# delete
#----------------------------------------------------------------------
@@ -611,3 +683,17 @@ is_same_sql_bind(
[3],
);
+# MySQL supports -limit and -order_by in deletes !
+# see http://dev.mysql.com/doc/refman/5.6/en/delete.html
+($sql, @bind) = $sqla->delete(
+ -from => 'Foo',
+ -where => {buz => 3},
+ -order_by => 'baz',
+ -limit => 10,
+);
+is_same_sql_bind(
+ $sql, \@bind,
+ 'DELETE FROM Foo WHERE buz = ? ORDER BY baz LIMIT ?',
+ [3, 10],
+ "delete with -order_by/-limit",
+);
@@ -0,0 +1,54 @@
+use strict;
+use warnings;
+no warnings qw/qw/;
+use Test::More;
+
+use SQL::Abstract::More;
+use SQL::Abstract::Test import => ['is_same_sql_bind'];
+
+
+plan tests => 5;
+
+my $sqla = SQL::Abstract::More->new;
+my ($sql, @bind, $join);
+
+
+$join = $sqla->join(qw[Foo {fk_A=pk_A,B<'toto',C='123'} Bar]);
+is_same_sql_bind(
+ $join->{sql}, $join->{bind},
+ "Foo INNER JOIN Bar ON Foo.B < ? AND Foo.C = ? AND Foo.fk_A = Bar.pk_A",
+ ['toto', 123],
+);
+
+
+$join = $sqla->join(qw[Foo {fk_A=pk_A,B<'to''to'''} Bar]);
+is_same_sql_bind(
+ $join->{sql}, $join->{bind},
+ "Foo INNER JOIN Bar ON Foo.B < ? AND Foo.fk_A = Bar.pk_A",
+ ["to'to'"],
+);
+
+
+$join = $sqla->join(qw[Foo {fk_A=pk_A,B<'to<to'} Bar]);
+is_same_sql_bind(
+ $join->{sql}, $join->{bind},
+ "Foo INNER JOIN Bar ON Foo.B < ? AND Foo.fk_A = Bar.pk_A",
+ ['to<to'],
+);
+
+
+$join = $sqla->join(qw[Foo {fk_A=pk_A,B<'to,to'} Bar]);
+is_same_sql_bind(
+ $join->{sql}, $join->{bind},
+ "Foo INNER JOIN Bar ON Foo.B < ? AND Foo.fk_A = Bar.pk_A",
+ ['to,to'],
+);
+
+
+
+$join = $sqla->join(qw[Foo {fk_A=pk_A,B<'to{[}]to'} Bar]);
+is_same_sql_bind(
+ $join->{sql}, $join->{bind},
+ "Foo INNER JOIN Bar ON Foo.B < ? AND Foo.fk_A = Bar.pk_A",
+ ['to{[}]to'],
+);
@@ -0,0 +1,34 @@
+use strict;
+use warnings;
+
+use Test::More;
+use FindBin;
+use TAP::Harness;
+
+plan tests => 1;
+
+SKIP: {
+ $ENV{SQLA_SRC_DIR} or do {
+ my $msg = 'define $ENV{SQLA_SRC_DIR} to run these tests';
+ diag $msg;
+ skip $msg, 1;
+ };
+
+ open my $fh, ">", \my $tap_output;
+
+ my $harness = TAP::Harness->new({
+ lib => ["$ENV{SQLA_SRC_DIR}/lib", "$FindBin::Bin/lib", @INC],
+ switches => ["-MUsurpSQLA"],
+ stdout => $fh,
+ });
+
+ my @tests = glob "$ENV{SQLA_SRC_DIR}/t/*.t $ENV{SQLA_SRC_DIR}/t/*/*.t";
+
+ diag "Running the whole SQLA test suite through SQLAM..";
+ my $aggr = $harness->runtests(@tests);
+ diag $tap_output;
+ ok $aggr->all_passed, "SQLA tests against SQLAM";
+}
+
+
+
@@ -0,0 +1,7 @@
+package UsurpSQLA;
+
+use Filter::Simple sub {s/SQL::Abstract(;|->)/SQL::Abstract::More$1/g;};
+
+1;
+
+
diff --git a/var/tmp/source/DAMI/SQL-Abstract-More-1.15/SQL-Abstract-More-1.15/t/pod.t b/var/tmp/source/DAMI/SQL-Abstract-More-1.23/SQL-Abstract-More-1.23/t/pod.t
old mode 100644
new mode 100755
@@ -0,0 +1,52 @@
+use strict;
+use warnings;
+use Test::More;
+use Test::Exception;
+
+use SQL::Abstract::More;
+use SQL::Abstract::Test import => ['eq_sql'];
+use List::MoreUtils qw/any/;
+
+plan tests => 2;
+
+
+my $sqla = SQL::Abstract::More->new;
+
+my $result = $sqla->join(
+ 'table',
+ { operator => '=>',
+ condition => { '%1$s.table_id' => {-ident => '%2$s.table_id'},
+ '%2$s.date' => {'>' => {-ident => '%1$s.date'}},
+ '%2$s.event_id' => 1}},
+ 'table_log'
+);
+
+# we don't know the order of conditions generated by SQL::Abstract;
+# but unfortunately, SQL::Abstract::Test is not clever enough to apply
+# commutativity on AND, so we have to do it by hand
+
+my @conditions = (
+ 'table_log.date > table.date',
+ 'table.table_id = table_log.table_id',
+ 'table_log.event_id = ?',
+);
+
+my @possible_SQL = map {"table LEFT OUTER JOIN table_log ON "
+ . join(' AND ', @$_) } permutations(@conditions);
+
+ok (any { eq_sql($result->{sql}, $_) } @possible_SQL);
+is_deeply ($result->{bind}, [1]);
+
+
+
+sub permutations {
+ return \@_ if @_ < 2;
+
+ my @result;
+ for my $i (0 .. $#_) {
+ my @tail = @_;
+ my $head = splice(@tail, $i, 1);
+ push @result, map {[$head, @$_ ]} permutations(@tail);
+ }
+ return @result;
+}
@@ -0,0 +1,51 @@
+use strict;
+use warnings;
+use Test::More;
+use Test::Exception;
+
+use SQL::Abstract::More;
+use SQL::Abstract::Test import => ['is_same_sql_bind'];
+
+plan tests => 2;
+
+my $sqla = SQL::Abstract::More->new();
+
+my ($sql,@bind) = $sqla->select(
+ -from => 't2',
+ -where => {col => {-in => \[$sqla->select(
+ -columns => 'some_key',
+ -from => 't1',
+ -order_by => 'foo',
+ )]}},
+ -group_by => 'bar',
+);
+
+is_same_sql_bind (
+ $sql,
+ \@bind,
+ 'SELECT * FROM t2 WHERE ( col IN ( SELECT some_key FROM t1 ORDER BY foo ) ) '
+ . 'GROUP BY bar',
+ [],
+);
+
+
+($sql,@bind) = $sqla->select(
+ -from => 't2',
+ -where => {col => {-in => \[$sqla->select(
+ -columns => 'some_key',
+ -from => 't1',
+ -order_by => 'foo',
+ )]}},
+ -group_by => 'bar',
+ -order_by => 'buz',
+);
+
+
+is_same_sql_bind (
+ $sql,
+ \@bind,
+ 'SELECT * FROM t2 WHERE ( col IN ( SELECT some_key FROM t1 ORDER BY foo ) ) '
+ . 'GROUP BY bar ORDER BY buz',
+ [],
+);
+