SQL-Abstract-1.81/0000755000175000017500000000000012422705003013126 5ustar rabbitrabbitSQL-Abstract-1.81/t/0000755000175000017500000000000012422705003013371 5ustar rabbitrabbitSQL-Abstract-1.81/t/06order_by.t0000644000175000017500000001001612361730666015546 0ustar rabbitrabbituse strict; use warnings; use Test::More; use Test::Exception; use SQL::Abstract; use SQL::Abstract::Test import => ['is_same_sql_bind']; my @cases = ( { given => \'colA DESC', expects => ' ORDER BY colA DESC', expects_quoted => ' ORDER BY colA DESC', }, { given => 'colA', expects => ' ORDER BY colA', expects_quoted => ' ORDER BY `colA`', }, { # it may look odd, but this is the desired behaviour (mst) given => 'colA DESC', expects => ' ORDER BY colA DESC', expects_quoted => ' ORDER BY `colA DESC`', }, { given => [qw/colA colB/], expects => ' ORDER BY colA, colB', expects_quoted => ' ORDER BY `colA`, `colB`', }, { # it may look odd, but this is the desired behaviour (mst) given => ['colA ASC', 'colB DESC'], expects => ' ORDER BY colA ASC, colB DESC', expects_quoted => ' ORDER BY `colA ASC`, `colB DESC`', }, { given => {-asc => 'colA'}, expects => ' ORDER BY colA ASC', expects_quoted => ' ORDER BY `colA` ASC', }, { given => {-desc => 'colB'}, expects => ' ORDER BY colB DESC', expects_quoted => ' ORDER BY `colB` DESC', }, { given => [{-asc => 'colA'}, {-desc => 'colB'}], expects => ' ORDER BY colA ASC, colB DESC', expects_quoted => ' ORDER BY `colA` ASC, `colB` DESC', }, { given => ['colA', {-desc => 'colB'}], expects => ' ORDER BY colA, colB DESC', expects_quoted => ' ORDER BY `colA`, `colB` DESC', }, { given => undef, expects => '', expects_quoted => '', }, { given => [{-desc => [ qw/colA colB/ ] }], expects => ' ORDER BY colA DESC, colB DESC', expects_quoted => ' ORDER BY `colA` DESC, `colB` DESC', }, { given => [{-desc => [ qw/colA colB/ ] }, {-asc => 'colC'}], expects => ' ORDER BY colA DESC, colB DESC, colC ASC', expects_quoted => ' ORDER BY `colA` DESC, `colB` DESC, `colC` ASC', }, { given => [{-desc => [ qw/colA colB/ ] }, {-asc => [ qw/colC colD/ ] }], expects => ' ORDER BY colA DESC, colB DESC, colC ASC, colD ASC', expects_quoted => ' ORDER BY `colA` DESC, `colB` DESC, `colC` ASC, `colD` ASC', }, { given => [{-desc => [ qw/colA colB/ ] }, {-desc => 'colC' }], expects => ' ORDER BY colA DESC, colB DESC, colC DESC', expects_quoted => ' ORDER BY `colA` DESC, `colB` DESC, `colC` DESC', }, { given => [{ -asc => 'colA' }, { -desc => [qw/colB/] }, { -asc => [qw/colC colD/] }], expects => ' ORDER BY colA ASC, colB DESC, colC ASC, colD ASC', expects_quoted => ' ORDER BY `colA` ASC, `colB` DESC, `colC` ASC, `colD` ASC', }, { given => { -desc => \['colA LIKE ?', 'test'] }, expects => ' ORDER BY colA LIKE ? DESC', expects_quoted => ' ORDER BY colA LIKE ? DESC', bind => ['test'], }, { given => \['colA LIKE ? DESC', 'test'], expects => ' ORDER BY colA LIKE ? DESC', expects_quoted => ' ORDER BY colA LIKE ? DESC', bind => ['test'], }, { given => [ { -asc => \['colA'] }, { -desc => \['colB LIKE ?', 'test'] }, { -asc => \['colC LIKE ?', 'tost'] }], expects => ' ORDER BY colA ASC, colB LIKE ? DESC, colC LIKE ? ASC', expects_quoted => ' ORDER BY colA ASC, colB LIKE ? DESC, colC LIKE ? ASC', bind => [qw/test tost/], }, ); my $sql = SQL::Abstract->new; my $sqlq = SQL::Abstract->new({quote_char => '`'}); for my $case( @cases) { my ($stat, @bind); ($stat, @bind) = $sql->_order_by($case->{given}); is_same_sql_bind ( $stat, \@bind, $case->{expects}, $case->{bind} || [], ); ($stat, @bind) = $sqlq->_order_by($case->{given}); is_same_sql_bind ( $stat, \@bind, $case->{expects_quoted}, $case->{bind} || [], ); } throws_ok ( sub { $sql->_order_by({-desc => 'colA', -asc => 'colB' }) }, qr/hash passed .+ must have exactly one key/, 'Undeterministic order exception', ); throws_ok ( sub { $sql->_order_by({-desc => [ qw/colA colB/ ], -asc => [ qw/colC colD/ ] }) }, qr/hash passed .+ must have exactly one key/, 'Undeterministic order exception', ); done_testing; SQL-Abstract-1.81/t/11parser.t0000644000175000017500000006115212361730666015240 0ustar rabbitrabbituse strict; use warnings; use Test::More; use Test::Warn; use SQL::Abstract::Tree; my $sqlat = SQL::Abstract::Tree->new; is_deeply($sqlat->parse("SELECT a, b.*, * FROM foo WHERE foo.a =1 and foo.b LIKE 'station'"), [ [ "SELECT", [ [ "-LIST", [ [ "-LITERAL", [ "a" ] ], [ "-LITERAL", [ "b.*" ] ], [ "-LITERAL", [ "*" ] ] ] ] ] ], [ "FROM", [ [ "-LITERAL", [ "foo" ] ] ] ], [ "WHERE", [ [ "AND", [ [ "=", [ [ "-LITERAL", [ "foo.a" ] ], [ "-LITERAL", [ 1 ] ] ] ], [ "LIKE", [ [ "-LITERAL", [ "foo.b" ] ], [ "-LITERAL", [ "'station'" ] ] ] ] ] ] ] ] ], 'simple statement parsed correctly'); is_deeply($sqlat->parse( "SELECT * FROM (SELECT * FROM foobar) foo WHERE foo.a =1 and foo.b LIKE 'station'"), [ [ "SELECT", [ [ "-LITERAL", [ "*" ] ] ] ], [ "FROM", [ [ "-MISC", [ [ "-PAREN", [ [ "SELECT", [ [ "-LITERAL", [ "*" ] ] ] ], [ "FROM", [ [ "-LITERAL", [ "foobar" ] ] ] ] ] ], [ "-LITERAL", [ "foo" ] ] ] ] ] ], [ "WHERE", [ [ "AND", [ [ "=", [ [ "-LITERAL", [ "foo.a" ] ], [ "-LITERAL", [ 1 ] ] ] ], [ "LIKE", [ [ "-LITERAL", [ "foo.b" ] ], [ "-LITERAL", [ "'station'" ] ] ] ] ] ] ] ] ], 'subquery statement parsed correctly'); is_deeply($sqlat->parse( "SELECT [screen].[id], [screen].[name], [screen].[section_id], [screen].[xtype] FROM [users_roles] [me] JOIN [roles] [role] ON [role].[id] = [me].[role_id] JOIN [roles_permissions] [role_permissions] ON [role_permissions].[role_id] = [role].[id] JOIN [permissions] [permission] ON [permission].[id] = [role_permissions].[permission_id] JOIN [permissionscreens] [permission_screens] ON [permission_screens].[permission_id] = [permission].[id] JOIN [screens] [screen] ON [screen].[id] = [permission_screens].[screen_id] WHERE ( [me].[user_id] = ? ) GROUP BY [screen].[id], [screen].[name], [screen].[section_id], [screen].[xtype]"), [ [ "SELECT", [ [ "-LIST", [ [ "-LITERAL", [ "[screen].[id]" ] ], [ "-LITERAL", [ "[screen].[name]" ] ], [ "-LITERAL", [ "[screen].[section_id]" ] ], [ "-LITERAL", [ "[screen].[xtype]" ] ] ] ] ] ], [ "FROM", [ [ "-MISC", [ [ "-LITERAL", [ "[users_roles]" ] ], [ "-LITERAL", [ "[me]" ] ] ] ] ] ], [ "JOIN", [ [ "-MISC", [ [ "-LITERAL", [ "[roles]" ] ], [ "-LITERAL", [ "[role]" ] ] ] ] ] ], [ "ON", [ [ "=", [ [ "-LITERAL", [ "[role].[id]" ] ], [ "-LITERAL", [ "[me].[role_id]" ] ] ] ] ] ], [ "JOIN", [ [ "-MISC", [ [ "-LITERAL", [ "[roles_permissions]" ] ], [ "-LITERAL", [ "[role_permissions]" ] ] ] ] ] ], [ "ON", [ [ "=", [ [ "-LITERAL", [ "[role_permissions].[role_id]" ] ], [ "-LITERAL", [ "[role].[id]" ] ] ] ] ] ], [ "JOIN", [ [ "-MISC", [ [ "-LITERAL", [ "[permissions]" ] ], [ "-LITERAL", [ "[permission]" ] ] ] ] ] ], [ "ON", [ [ "=", [ [ "-LITERAL", [ "[permission].[id]" ] ], [ "-LITERAL", [ "[role_permissions].[permission_id]" ] ] ] ] ] ], [ "JOIN", [ [ "-MISC", [ [ "-LITERAL", [ "[permissionscreens]" ] ], [ "-LITERAL", [ "[permission_screens]" ] ] ] ] ] ], [ "ON", [ [ "=", [ [ "-LITERAL", [ "[permission_screens].[permission_id]" ] ], [ "-LITERAL", [ "[permission].[id]" ] ] ] ] ] ], [ "JOIN", [ [ "-MISC", [ [ "-LITERAL", [ "[screens]" ] ], [ "-LITERAL", [ "[screen]" ] ] ] ] ] ], [ "ON", [ [ "=", [ [ "-LITERAL", [ "[screen].[id]" ] ], [ "-LITERAL", [ "[permission_screens].[screen_id]" ] ] ] ] ] ], [ "WHERE", [ [ "-PAREN", [ [ "=", [ [ "-LITERAL", [ "[me].[user_id]" ] ], [ "-PLACEHOLDER", [ "?" ] ] ] ] ] ] ] ], [ "GROUP BY", [ [ "-LIST", [ [ "-LITERAL", [ "[screen].[id]" ] ], [ "-LITERAL", [ "[screen].[name]" ] ], [ "-LITERAL", [ "[screen].[section_id]" ] ], [ "-LITERAL", [ "[screen].[xtype]" ] ] ] ] ] ] ], 'real life statement 1 parsed correctly'); is_deeply($sqlat->parse("CASE WHEN FOO() > BAR()"), [ [ "-MISC", [ [ "-LITERAL", [ "CASE" ] ], [ "-LITERAL", [ "WHEN" ] ] ] ], [ ">", [ [ "FOO", [ [ "-PAREN", [] ] ] ], [ "BAR", [ [ "-PAREN", [] ] ] ] ] ] ]); is_deeply($sqlat->parse("SELECT [me].[id], ROW_NUMBER ( ) OVER (ORDER BY (SELECT 1)) AS [rno__row__index] FROM bar"), [ [ "SELECT", [ [ "-LIST", [ [ "-LITERAL", [ "[me].[id]" ] ], [ "AS", [ [ "ROW_NUMBER() OVER", [ [ "-PAREN", [ [ "ORDER BY", [ [ "-PAREN", [ [ "SELECT", [ [ "-LITERAL", [ 1 ] ] ] ] ] ] ] ] ] ] ] ], [ "-LITERAL", [ "[rno__row__index]" ] ] ] ] ] ] ] ], [ "FROM", [ [ "-LITERAL", [ "bar" ] ] ] ] ]); is_deeply($sqlat->parse("SELECT x, y FROM foo WHERE x IN (?, ?, ?, ?)"), [ [ "SELECT", [ [ "-LIST", [ [ "-LITERAL", [ "x" ] ], [ "-LITERAL", [ "y" ] ] ] ] ] ], [ "FROM", [ [ "-LITERAL", [ "foo" ] ] ] ], [ "WHERE", [ [ "IN", [ [ "-LITERAL", [ "x" ] ], [ "-PAREN", [ [ "-LIST", [ [ "-PLACEHOLDER", [ "?" ] ], [ "-PLACEHOLDER", [ "?" ] ], [ "-PLACEHOLDER", [ "?" ] ], [ "-PLACEHOLDER", [ "?" ] ] ] ] ] ] ] ] ] ] ], 'Lists parsed correctly'); is_deeply($sqlat->parse('SELECT foo FROM bar ORDER BY x + ? DESC, oomph, y - ? DESC, unf, baz.g / ? ASC, buzz * 0 DESC, foo LIKE ? DESC, ickk ASC'), [ [ "SELECT", [ [ "-LITERAL", [ "foo" ] ] ] ], [ "FROM", [ [ "-LITERAL", [ "bar" ] ] ] ], [ "ORDER BY", [ [ "-LIST", [ [ "-DESC", [ [ "-MISC", [ [ "-LITERAL", [ "x" ] ], [ "-LITERAL", [ "+" ] ], [ "-PLACEHOLDER", [ "?" ] ] ] ], ] ], [ "-LITERAL", [ "oomph" ] ], [ "-DESC", [ [ "-MISC", [ [ "-LITERAL", [ "y" ] ], [ "-LITERAL", [ "-" ] ], [ "-PLACEHOLDER", [ "?" ] ], ] ], ] ], [ "-LITERAL", [ "unf" ] ], [ "-ASC", [ [ "-MISC", [ [ "-LITERAL", [ "baz.g" ] ], [ "-LITERAL", [ "/" ] ], [ "-PLACEHOLDER", [ "?" ] ], ] ], ] ], [ "-DESC", [ [ "-MISC", [ [ "-LITERAL", [ "buzz" ] ], [ "-LITERAL", [ "*" ] ], [ "-LITERAL", [ 0 ] ] ] ] ] ], [ "-DESC", [ [ "LIKE", [ [ "-LITERAL", [ "foo" ] ], [ "-PLACEHOLDER", [ "?" ] ], ], ], ] ], [ "-ASC", [ [ "-LITERAL", [ "ickk" ] ] ] ] ] ] ] ] ], 'Crazy ORDER BY parsed correctly'); is_deeply( $sqlat->parse("META SELECT * * FROM (SELECT *, FROM foobar baz buzz) foo bar WHERE NOT NOT NOT EXISTS (SELECT 'cr,ap') AND foo.a = ? STUFF moar(stuff) and not (foo.b LIKE 'station') and x = y and z in ((1, 2)) and a = b and GROUP BY , ORDER BY x x1 x2 y asc, max(y) desc x z desc"), [ [ "-LITERAL", [ "META" ] ], [ "SELECT", [ [ "-MISC", [ [ "-LITERAL", [ "*" ] ], [ "-LITERAL", [ "*" ] ] ] ] ] ], [ "FROM", [ [ "-MISC", [ [ "-PAREN", [ [ "SELECT", [ [ "-LIST", [ [ "-LITERAL", [ "*" ] ], [] ] ] ] ], [ "FROM", [ [ "-MISC", [ [ "-LITERAL", [ "foobar" ] ], [ "-LITERAL", [ "baz" ] ], [ "-LITERAL", [ "buzz" ] ] ] ] ] ] ] ], [ "-LITERAL", [ "foo" ] ], [ "-LITERAL", [ "bar" ] ] ] ] ] ], [ "WHERE", [ [ "AND", [ [ "NOT", [] ], [ "NOT", [] ], [ "NOT EXISTS", [ [ "-PAREN", [ [ "SELECT", [ [ "-LIST", [ [ "-LITERAL", [ "'cr" ] ], [ "-LITERAL", [ "ap'" ] ] ] ] ] ] ] ] ] ], [ "-MISC", [ [ "=", [ [ "-LITERAL", [ "foo.a" ] ], [ "-PLACEHOLDER", [ "?" ] ], ], ], [ "-LITERAL", [ "STUFF" ] ], ], ], [ 'moar', [ [ '-PAREN', [ [ '-LITERAL', [ 'stuff' ] ] ] ] ] ], [ "NOT", [ [ "-PAREN", [ [ "LIKE", [ [ "-LITERAL", [ "foo.b" ] ], [ "-LITERAL", [ "'station'" ] ] ] ] ] ] ] ], [ "=", [ [ "-LITERAL", [ "x" ] ], [ "-LITERAL", [ "y" ] ] ] ], [ 'IN', [ [ '-LITERAL', [ 'z', ], ], [ '-PAREN', [ [ '-PAREN', [ [ '-LIST', [ [ '-LITERAL', [ '1' ] ], [ '-LITERAL', [ '2' ] ], ], ], ], ], ], ], ], ], [ "=", [ [ "-LITERAL", [ "a" ] ], [ "-LITERAL", [ "b" ] ] ] ] ] ] ] ], [ "GROUP BY", [ [ "-LIST", [ [], [] ] ] ] ], [ "ORDER BY", [ [ "-LIST", [ [ "-ASC", [ [ "-MISC", [ [ "-LITERAL", [ "x" ] ], [ "-LITERAL", [ "x1" ] ], [ "-LITERAL", [ "x2" ] ], [ "-LITERAL", [ "y" ] ] ] ], ], ], [ "-DESC", [ [ "-MISC", [ [ "-DESC", [ [ "max", [ [ "-PAREN", [ [ "-LITERAL", [ "y" ] ] ] ] ], ] ] ], [ "-LITERAL", [ "x" ] ], [ "-LITERAL", [ "z" ] ] ] ] ] ] ] ] ] ] ], 'Deliberately malformed SQL parsed "correctly"'); # test for recursion warnings on huge selectors my @lst = ('AA' .. 'zz'); #@lst = ('AAA' .. 'zzz'); # if you really want to wait a while warnings_are { my $sql = sprintf 'SELECT %s FROM foo', join (', ', (map { qq|( "$_" )| } @lst), (map { qq|"$_"| } @lst), (map { qq|"$_", ( "$_" )| } @lst) ); my $tree = $sqlat->parse($sql); is_deeply( $tree, [ [ "SELECT", [ [ "-LIST", [ (map { [ -PAREN => [ [ -LITERAL => [ qq|"$_"| ] ] ] ] } @lst), (map { [ -LITERAL => [ qq|"$_"| ] ] } @lst), (map { [ -LITERAL => [ qq|"$_"| ] ], [ -PAREN => [ [ -LITERAL => [ qq|"$_"| ] ] ] ] } @lst), ] ] ] ], [ "FROM", [ [ "-LITERAL", [ "foo" ] ] ] ] ], 'long list parsed correctly'); is( $sqlat->unparse($tree), $sql, 'roundtrip ok'); } [], 'no recursion warnings on insane SQL'; done_testing; SQL-Abstract-1.81/t/10test.t0000644000175000017500000010216712406777003014720 0ustar rabbitrabbituse strict; use warnings; use Test::More; use SQL::Abstract::Test import => [qw( eq_sql_bind eq_sql eq_bind is_same_sql_bind dumper $sql_differ )]; my @sql_tests = ( # WHERE condition - equal { equal => 1, statements => [ q/SELECT foo FROM bar WHERE a = 1/, q/SELECT foo FROM bar WHERE a=1/, q/SELECT foo FROM bar WHERE (a = 1)/, q/SELECT foo FROM bar WHERE (a=1)/, q/SELECT foo FROM bar WHERE ( a = 1 )/, q/ SELECT foo FROM bar WHERE a = 1 /, q/ SELECT foo FROM bar WHERE (a = 1) /, q/ SELECT foo FROM bar WHERE ( a = 1 ) /, q/SELECT foo FROM bar WHERE ((a = 1))/, q/SELECT foo FROM bar WHERE ( (a = 1) )/, q/SELECT foo FROM bar WHERE ( ( a = 1 ) )/, ] }, { equal => 1, statements => [ q/SELECT foo FROM bar WHERE a = 1 AND b = 1/, q/SELECT foo FROM bar WHERE (a = 1) AND (b = 1)/, q/SELECT foo FROM bar WHERE ((a = 1) AND (b = 1))/, q/SELECT foo FROM bar WHERE (a = 1 AND b = 1)/, q/SELECT foo FROM bar WHERE ((a = 1 AND b = 1))/, q/SELECT foo FROM bar WHERE (((a = 1) AND (b = 1)))/, q/ SELECT foo FROM bar WHERE a = 1 AND b = 1 /, q/ SELECT foo FROM bar WHERE (a = 1 AND b = 1) /, q/ SELECT foo FROM bar WHERE (a = 1) AND (b = 1) /, q/ SELECT foo FROM bar WHERE ((a = 1) AND (b = 1)) /, ] }, { equal => 1, statements => [ q/SELECT foo FROM bar WHERE a = 1 AND b = 1 AND c = 1/, q/SELECT foo FROM bar WHERE (a = 1 AND b = 1 AND c = 1)/, q/SELECT foo FROM bar WHERE (a = 1 AND b = 1) AND c = 1/, q/SELECT foo FROM bar WHERE a = 1 AND (b = 1 AND c = 1)/, q/SELECT foo FROM bar WHERE ((((a = 1))) AND (b = 1 AND c = 1))/, ] }, { equal => 1, statements => [ q/SELECT foo FROM bar WHERE a = 1 OR b = 1 OR c = 1/, q/SELECT foo FROM bar WHERE (a = 1 OR b = 1) OR c = 1/, q/SELECT foo FROM bar WHERE a = 1 OR (b = 1 OR c = 1)/, q/SELECT foo FROM bar WHERE a = 1 OR ((b = 1 OR (c = 1)))/, ] }, { equal => 1, statements => [ q/SELECT foo FROM bar WHERE (a = 1) AND (b = 1 OR c = 1 OR d = 1) AND (e = 1 AND f = 1)/, q/SELECT foo FROM bar WHERE a = 1 AND (b = 1 OR c = 1 OR d = 1) AND e = 1 AND (f = 1)/, q/SELECT foo FROM bar WHERE ( ((a = 1) AND ( b = 1 OR (c = 1 OR d = 1) )) AND ((e = 1)) AND f = 1) /, ] }, { equal => 1, statements => [ q/SELECT foo FROM bar WHERE (a) AND (b = 2)/, q/SELECT foo FROM bar WHERE (a AND b = 2)/, q/SELECT foo FROM bar WHERE (a AND (b = 2))/, q/SELECT foo FROM bar WHERE a AND (b = 2)/, ] }, { equal => 1, statements => [ q/SELECT foo FROM bar WHERE ((NOT a) AND b = 2)/, q/SELECT foo FROM bar WHERE (NOT a) AND (b = 2)/, q/SELECT foo FROM bar WHERE (NOT (a)) AND b = 2/, ], }, { equal => 0, statements => [ q/SELECT foo FROM bar WHERE NOT a AND (b = 2)/, q/SELECT foo FROM bar WHERE (NOT a) AND (b = 2)/, ] }, { equal => 0, opts => { parenthesis_significant => 1 }, statements => [ q/SELECT foo FROM bar WHERE a = 1 AND b = 1 AND c = 1/, q/SELECT foo FROM bar WHERE (a = 1 AND b = 1 AND c = 1)/, q/SELECT foo FROM bar WHERE (a = 1 AND b = 1) AND c = 1/, q/SELECT foo FROM bar WHERE a = 1 AND (b = 1 AND c = 1)/, q/SELECT foo FROM bar WHERE ((((a = 1))) AND (b = 1 AND c = 1))/, ] }, { equal => 0, opts => { parenthesis_significant => 1 }, statements => [ q/SELECT foo FROM bar WHERE a = 1 OR b = 1 OR c = 1/, q/SELECT foo FROM bar WHERE (a = 1 OR b = 1) OR c = 1/, q/SELECT foo FROM bar WHERE a = 1 OR (b = 1 OR c = 1)/, q/SELECT foo FROM bar WHERE a = 1 OR ((b = 1 OR (c = 1)))/, ] }, { equal => 0, opts => { parenthesis_significant => 1 }, statements => [ q/SELECT foo FROM bar WHERE (a = 1) AND (b = 1 OR c = 1 OR d = 1) AND (e = 1 AND f = 1)/, q/SELECT foo FROM bar WHERE a = 1 AND (b = 1 OR c = 1 OR d = 1) AND e = 1 AND (f = 1)/, q/SELECT foo FROM bar WHERE ( ((a = 1) AND ( b = 1 OR (c = 1 OR d = 1) )) AND ((e = 1)) AND f = 1) /, ] }, # WHERE condition - different { equal => 0, statements => [ q/SELECT foo FROM bar WHERE a = 1/, q/SELECT quux FROM bar WHERE a = 1/, q/SELECT foo FROM quux WHERE a = 1/, q/FOOBAR foo FROM bar WHERE a = 1/, q/SELECT foo FROM bar WHERE a = 2/, q/SELECT foo FROM bar WHERE a < 1/, q/SELECT foo FROM bar WHERE b = 1/, q/SELECT foo FROM bar WHERE (c = 1)/, q/SELECT foo FROM bar WHERE (d = 1)/, q/SELECT foo FROM bar WHERE a = 1 AND quux/, q/SELECT foo FROM bar WHERE a = 1 GROUP BY foo/, q/SELECT foo FROM bar WHERE a = 1 ORDER BY foo/, q/SELECT foo FROM bar WHERE a = 1 LIMIT 1/, q/SELECT foo FROM bar WHERE a = 1 OFFSET 1/, q/SELECT foo FROM bar JOIN quux WHERE a = 1/, q/SELECT foo FROM bar JOIN quux ON a = 1 WHERE a = 1/, ] }, { equal => 0, statements => [ q/SELECT foo FROM bar WHERE a = 1 AND b = 1/, q/SELECT quux FROM bar WHERE a = 1 AND b = 1/, q/SELECT foo FROM quux WHERE a = 1 AND b = 1/, q/FOOBAR foo FROM bar WHERE a = 1 AND b = 1/, q/SELECT foo FROM bar WHERE a = 2 AND b = 1/, q/SELECT foo FROM bar WHERE a = 3 AND (b = 1)/, q/SELECT foo FROM bar WHERE (a = 4) AND b = 1/, q/SELECT foo FROM bar WHERE (a = 5) AND (b = 1)/, q/SELECT foo FROM bar WHERE ((a = 6) AND (b = 1))/, q/SELECT foo FROM bar WHERE ((a = 7) AND (b = 1))/, q/SELECT foo FROM bar WHERE a = 1 AND b = 2/, q/SELECT foo FROM bar WHERE a = 1 AND (b = 3)/, q/SELECT foo FROM bar WHERE (a = 1) AND b = 4/, q/SELECT foo FROM bar WHERE (a = 1) AND (b = 5)/, q/SELECT foo FROM bar WHERE ((a = 1) AND (b = 6))/, q/SELECT foo FROM bar WHERE ((a = 1) AND (b = 7))/, q/SELECT foo FROM bar WHERE a < 1 AND b = 1/, q/SELECT foo FROM bar WHERE b = 1 AND b = 1/, q/SELECT foo FROM bar WHERE (c = 1) AND b = 1/, q/SELECT foo FROM bar WHERE (d = 1) AND b = 1/, q/SELECT foo FROM bar WHERE a = 1 AND b = 1 AND quux/, q/SELECT foo FROM bar WHERE a = 1 AND b = 1 GROUP BY foo/, q/SELECT foo FROM bar WHERE a = 1 AND b = 1 ORDER BY foo/, q/SELECT foo FROM bar WHERE a = 1 AND b = 1 LIMIT 1/, q/SELECT foo FROM bar WHERE a = 1 AND b = 1 OFFSET 1/, q/SELECT foo FROM bar JOIN quux WHERE a = 1 AND b = 1/, q/SELECT foo FROM bar JOIN quux ON a = 1 WHERE a = 1 AND b = 1/, ] }, { equal => 0, statements => [ q/SELECT foo FROM bar WHERE a = 1 AND b = 1 OR c = 1/, q/SELECT foo FROM bar WHERE (a = 1 AND b = 1) OR c = 1/, q/SELECT foo FROM bar WHERE a = 1 AND (b = 1 OR c = 1)/, ] }, { equal => 0, statements => [ q/SELECT foo FROM bar WHERE a = 1 OR b = 1 AND c = 1/, q/SELECT foo FROM bar WHERE (a = 1 OR b = 1) AND c = 1/, q/SELECT foo FROM bar WHERE a = 1 OR (b = 1 AND c = 1)/, ] }, { equal => 0, statements => [ q/SELECT foo FROM bar WHERE a IN (1,3,2)/, q/SELECT foo FROM bar WHERE a IN 1,2,3/, q/SELECT foo FROM bar WHERE a IN (1,2,3)/, q/SELECT foo FROM bar WHERE a IN ((1,2,3))/, ] }, { equal => 0, statements => [ # BETWEEN with/without parenthesis around itself/RHS is a sticky business # if I made a mistake here, simply rewrite the special BETWEEN handling in # _recurse_parse() # # by RIBASUSHI q/SELECT foo FROM bar WHERE ( completion_date BETWEEN ? AND ? AND status = ? )/, q/SELECT foo FROM bar WHERE completion_date BETWEEN (? AND ?) AND status = ?/, q/SELECT foo FROM bar WHERE ( (completion_date BETWEEN (? AND ?) ) AND status = ? )/, q/SELECT foo FROM bar WHERE ( (completion_date BETWEEN (? AND ? AND status = ?) ) )/, ] }, # IS NULL (special LHS-only op) { equal => 1, statements => [ q/WHERE a IS NOT NULL AND b IS NULL/, q/WHERE (a IS NOT NULL) AND b IS NULL/, q/WHERE a IS NOT NULL AND (b IS NULL)/, q/WHERE (a IS NOT NULL) AND ((b IS NULL))/, ], }, # JOIN condition - equal { equal => 1, statements => [ q/SELECT foo FROM bar JOIN baz ON a = 1 WHERE x = 1/, q/SELECT foo FROM bar JOIN baz ON a=1 WHERE x = 1/, q/SELECT foo FROM bar JOIN baz ON (a = 1) WHERE x = 1/, q/SELECT foo FROM bar JOIN baz ON (a=1) WHERE x = 1/, q/SELECT foo FROM bar JOIN baz ON ( a = 1 ) WHERE x = 1/, q/ SELECT foo FROM bar JOIN baz ON a = 1 WHERE x = 1 /, q/ SELECT foo FROM bar JOIN baz ON (a = 1) WHERE x = 1 /, q/ SELECT foo FROM bar JOIN baz ON ( a = 1 ) WHERE x = 1 /, q/SELECT foo FROM bar JOIN baz ON ((a = 1)) WHERE x = 1/, q/SELECT foo FROM bar JOIN baz ON ( (a = 1) ) WHERE x = 1/, q/SELECT foo FROM bar JOIN baz ON ( ( a = 1 ) ) WHERE x = 1/, ] }, { equal => 1, statements => [ q/SELECT foo FROM bar JOIN baz ON a = 1 AND b = 1 WHERE x = 1/, q/SELECT foo FROM bar JOIN baz ON (a = 1) AND (b = 1) WHERE x = 1/, q/SELECT foo FROM bar JOIN baz ON ((a = 1) AND (b = 1)) WHERE x = 1/, q/SELECT foo FROM bar JOIN baz ON (a = 1 AND b = 1) WHERE x = 1/, q/SELECT foo FROM bar JOIN baz ON ((a = 1 AND b = 1)) WHERE x = 1/, q/SELECT foo FROM bar JOIN baz ON (((a = 1) AND (b = 1))) WHERE x = 1/, q/ SELECT foo FROM bar JOIN baz ON a = 1 AND b = 1 WHERE x = 1 /, q/ SELECT foo FROM bar JOIN baz ON (a = 1 AND b = 1) WHERE x = 1 /, q/ SELECT foo FROM bar JOIN baz ON (a = 1) AND (b = 1) WHERE x = 1 /, q/ SELECT foo FROM bar JOIN baz ON ((a = 1) AND (b = 1)) WHERE x = 1 /, ] }, # JOIN condition - different { equal => 0, statements => [ q/SELECT foo FROM bar JOIN quux ON a = 1 WHERE quuux/, q/SELECT quux FROM bar JOIN quux ON a = 1 WHERE quuux/, q/SELECT foo FROM quux JOIN quux ON a = 1 WHERE quuux/, q/FOOBAR foo FROM bar JOIN quux ON a = 1 WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON a = 2 WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON a < 1 WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON b = 1 WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON (c = 1) WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON (d = 1) WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON a = 1 AND quuux/, q/SELECT foo FROM bar JOIN quux ON a = 1 GROUP BY foo/, q/SELECT foo FROM bar JOIN quux ON a = 1 ORDER BY foo/, q/SELECT foo FROM bar JOIN quux ON a = 1 LIMIT 1/, q/SELECT foo FROM bar JOIN quux ON a = 1 OFFSET 1/, q/SELECT foo FROM bar JOIN quux ON a = 1 JOIN quuux/, q/SELECT foo FROM bar JOIN quux ON a = 1 JOIN quuux ON a = 1/, ] }, { equal => 0, statements => [ q/SELECT foo FROM bar JOIN quux ON a = 1 AND b = 1 WHERE quuux/, q/SELECT quux FROM bar JOIN quux ON a = 1 AND b = 1 WHERE quuux/, q/SELECT foo FROM quux JOIN quux ON a = 1 AND b = 1 WHERE quuux/, q/FOOBAR foo FROM bar JOIN quux ON a = 1 AND b = 1 WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON a = 2 AND b = 1 WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON a = 3 AND (b = 1) WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON (a = 4) AND b = 1 WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON (a = 5) AND (b = 1) WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON ((a = 6) AND (b = 1)) WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON ((a = 7) AND (b = 1)) WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON a = 1 AND b = 2 WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON a = 1 AND (b = 3) WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON (a = 1) AND b = 4 WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON (a = 1) AND (b = 5) WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON ((a = 1) AND (b = 6)) WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON ((a = 1) AND (b = 7)) WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON a < 1 AND b = 1 WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON b = 1 AND b = 1 WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON (c = 1) AND b = 1 WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON (d = 1) AND b = 1 WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON a = 1 AND b = 1 AND quuux/, q/SELECT foo FROM bar JOIN quux ON a = 1 AND b = 1 GROUP BY foo/, q/SELECT foo FROM bar JOIN quux ON a = 1 AND b = 1 ORDER BY foo/, q/SELECT foo FROM bar JOIN quux ON a = 1 AND b = 1 LIMIT 1/, q/SELECT foo FROM bar JOIN quux ON a = 1 AND b = 1 OFFSET 1/, q/SELECT foo FROM bar JOIN quux JOIN quuux ON a = 1 AND b = 1/, q/SELECT foo FROM bar JOIN quux ON a = 1 JOIN quuux ON a = 1 AND b = 1/, ] }, # DISTINCT ON (...) not confused with JOIN ON (...) { equal => 1, statements => [ q/SELECT DISTINCT ON (foo, quux) foo, quux FROM bar WHERE a = 1/, q/SELECT DISTINCT ON (foo, quux) foo, quux FROM bar WHERE a=1/, q/SELECT DISTINCT ON (foo, quux) foo, quux FROM bar WHERE (a = 1)/, q/SELECT DISTINCT ON (foo, quux) foo, quux FROM bar WHERE (a=1)/, q/SELECT DISTINCT ON (foo, quux) foo, quux FROM bar WHERE ( a = 1 )/, q/ SELECT DISTINCT ON (foo, quux) foo, quux FROM bar WHERE a = 1 /, q/ SELECT DISTINCT ON (foo, quux) foo, quux FROM bar WHERE (a = 1) /, q/ SELECT DISTINCT ON (foo, quux) foo, quux FROM bar WHERE ( a = 1 ) /, q/SELECT DISTINCT ON (foo, quux) foo, quux FROM bar WHERE ((a = 1))/, q/SELECT DISTINCT ON (foo, quux) foo, quux FROM bar WHERE ( (a = 1) )/, q/SELECT DISTINCT ON (foo, quux) foo, quux FROM bar WHERE ( ( a = 1 ) )/, ] }, # subselects - equal { equal => 1, statements => [ q/SELECT * FROM (SELECT * FROM bar WHERE b = 1) AS foo WHERE a = 1/, q/SELECT * FROM (SELECT * FROM bar WHERE b = 1) AS foo WHERE (a = 1)/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1)) AS foo WHERE a = 1/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1)) AS foo WHERE (a = 1)/, ] }, { equal => 1, statements => [ q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND c = 1) AS foo WHERE a = 1/, q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND (c = 1)) AS foo WHERE a = 1/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND c = 1) AS foo WHERE a = 1/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND (c = 1)) AS foo WHERE a = 1/, q/SELECT * FROM (SELECT * FROM bar WHERE ((b = 1) AND (c = 1))) AS foo WHERE a = 1/, q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND c = 1) AS foo WHERE (a = 1)/, q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND (c = 1)) AS foo WHERE (a = 1)/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND c = 1) AS foo WHERE (a = 1)/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND (c = 1)) AS foo WHERE (a = 1)/, q/SELECT * FROM (SELECT * FROM bar WHERE ((b = 1) AND (c = 1))) AS foo WHERE (a = 1)/, ] }, # subselects - different { equal => 0, statements => [ q/DELETE FROM cd WHERE ( cdid IN ( SELECT me.cdid FROM (SELECT * FROM cd me WHERE ( year != ? ) GROUP BY me.cdid) me WHERE ( year != ? ) ) )/, q/DELETE FROM cd WHERE ( cdid IN ( SELECT me.cdid FROM cd me WHERE ( year != ? ) GROUP BY me.cdid ) )/, ], }, { equal => 0, statements => [ q/SELECT * FROM (SELECT * FROM bar WHERE b = 1) AS foo WHERE a = 1/, q/SELECT * FROM (SELECT * FROM bar WHERE b = 1) AS foo WHERE a = 2/, q/SELECT * FROM (SELECT * FROM bar WHERE b = 1) AS foo WHERE (a = 3)/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1)) AS foo WHERE a = 4/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1)) AS foo WHERE (a = 5)/, q/SELECT * FROM (SELECT * FROM bar WHERE b = 2) AS foo WHERE a = 1/, q/SELECT * FROM (SELECT * FROM bar WHERE b = 3) AS foo WHERE (a = 1)/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 4)) AS foo WHERE a = 1/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 5)) AS foo WHERE (a = 1)/, ] }, { equal => 0, statements => [ q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND c = 1) AS foo WHERE a = 1/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND c = 2) AS foo WHERE a = 1/, q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND (c = 3)) AS foo WHERE a = 1/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND (c = 4)) AS foo WHERE a = 1/, q/SELECT * FROM (SELECT * FROM bar WHERE ((b = 1) AND (c = 5))) AS foo WHERE a = 1/, q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND c = 6) AS foo WHERE (a = 1)/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND c = 7) AS foo WHERE (a = 1)/, q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND (c = 8)) AS foo WHERE (a = 1)/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND (c = 9)) AS foo WHERE (a = 1)/, q/SELECT * FROM (SELECT * FROM bar WHERE ((b = 1) AND (c = 10))) AS foo WHERE (a = 1)/, q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND c = 1) AS foo WHERE a = 2/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND c = 2) AS foo WHERE a = 2/, q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND (c = 3)) AS foo WHERE a = 2/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND (c = 4)) AS foo WHERE a = 2/, q/SELECT * FROM (SELECT * FROM bar WHERE ((b = 1) AND (c = 5))) AS foo WHERE a = 2/, q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND c = 6) AS foo WHERE (a = 2)/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND c = 7) AS foo WHERE (a = 2)/, q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND (c = 8)) AS foo WHERE (a = 2)/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND (c = 9)) AS foo WHERE (a = 2)/, q/SELECT * FROM (SELECT * FROM bar WHERE ((b = 1) AND (c = 10))) AS foo WHERE (a = 2)/, ] }, # order by { equal => 1, statements => [ q/SELECT * FROM foo ORDER BY bar/, q/SELECT * FROM foo ORDER BY bar ASC/, q/SELECT * FROM foo ORDER BY bar asc/, ], }, { equal => 1, statements => [ q/SELECT * FROM foo ORDER BY bar, baz ASC/, q/SELECT * FROM foo ORDER BY bar ASC, baz/, q/SELECT * FROM foo ORDER BY bar asc, baz ASC/, q/SELECT * FROM foo ORDER BY bar, baz/, ], }, { equal => 1, statements => [ q/ORDER BY colA, colB LIKE ? DESC, colC LIKE ?/, q/ORDER BY colA ASC, colB LIKE ? DESC, colC LIKE ? ASC/, ], }, { equal => 1, statements => [ q/ORDER BY name + ?, [me].[id]/, q/ORDER BY name + ? ASC, [me].[id]/, ], }, { equal => 0, opts => { order_by_asc_significant => 1 }, statements => [ q/SELECT * FROM foo ORDER BY bar/, q/SELECT * FROM foo ORDER BY bar ASC/, q/SELECT * FROM foo ORDER BY bar desc/, ], }, # list permutations { equal => 0, statements => [ 'SELECT a,b,c FROM foo', 'SELECT a,c,b FROM foo', 'SELECT b,a,c FROM foo', 'SELECT b,c,a FROM foo', 'SELECT c,a,b FROM foo', 'SELECT c,b,a FROM foo', ], }, { equal => 0, statements => [ 'SELECT * FROM foo WHERE a IN (1,2,3)', 'SELECT * FROM foo WHERE a IN (1,3,2)', 'SELECT * FROM foo WHERE a IN (2,1,3)', 'SELECT * FROM foo WHERE a IN (2,3,1)', 'SELECT * FROM foo WHERE a IN (3,1,2)', 'SELECT * FROM foo WHERE a IN (3,2,1)', ] }, # list consistency { equal => 0, statements => [ 'SELECT a,b FROM foo', 'SELECT a,,b FROM foo', 'SELECT a,b, FROM foo', 'SELECT ,a,b, FROM foo', 'SELECT ,a,,b, FROM foo', ], }, # misc func { equal => 0, statements => [ 'SELECT count(*) FROM foo', 'SELECT count(*) AS bar FROM foo', 'SELECT count(*) AS "bar" FROM foo', 'SELECT count(a) FROM foo', 'SELECT count(1) FROM foo', ] }, { equal => 1, statements => [ 'SELECT foo() bar FROM baz', 'SELECT foo ( )bar FROM baz', 'SELECT foo (())bar FROM baz', 'SELECT foo(( ) ) bar FROM baz', ] }, { equal => 0, statements => [ 'SELECT foo() FROM bar', 'SELECT foo FROM bar', 'SELECT foo FROM bar ()', ] }, { equal => 0, statements => [ 'SELECT COUNT * FROM foo', 'SELECT COUNT( * ) FROM foo', ] }, # single ? of unknown funcs do not unroll unless # explicitly allowed (e.g. Like) { equal => 0, statements => [ 'SELECT foo FROM bar WHERE bar > foo ?', 'SELECT foo FROM bar WHERE bar > foo( ? )', ] }, { equal => 1, statements => [ 'SELECT foo FROM bar WHERE bar LIKE ?', 'SELECT foo FROM bar WHERE bar LiKe (?)', 'SELECT foo FROM bar WHERE bar lIkE( (?))', ] }, # test multival { equal => 0, statements => [ 'SELECT foo FROM bar WHERE foo IN (?, ?)', 'SELECT foo FROM bar WHERE foo IN ?, ?', ] }, # math { equal => 0, statements => [ 'SELECT * FROM foo WHERE 1 = ( a > b)', 'SELECT * FROM foo WHERE 1 = a > b', 'SELECT * FROM foo WHERE (1 = a) > b', ] }, { equal => 1, statements => [ 'SELECT * FROM foo WHERE bar = baz(buzz)', 'SELECT * FROM foo WHERE bar = (baz( buzz ))', ] }, # oddballs { equal => 1, statements => [ 'WHERE ( foo GLOB ? )', 'WHERE foo GLOB ?', ], }, { equal => 1, statements => [ 'SELECT FIRST ? SKIP ? [me].[id], [me].[owner] FROM [books] [me] WHERE ( ( (EXISTS ( SELECT FIRST ? SKIP ? [owner].[id] FROM [owners] [owner] WHERE ( [books].[owner] = [owner].[id] ) )) AND [source] = ? ) )', 'SELECT FIRST ? SKIP ? [me].[id], [me].[owner] FROM [books] [me] WHERE ( ( EXISTS ( SELECT FIRST ? SKIP ? [owner].[id] FROM [owners] [owner] WHERE ( [books].[owner] = [owner].[id] ) ) AND [source] = ? ) )', ], }, { equal => 1, statements => [ 'WHERE foo = ? FETCH FIRST 1 ROWS ONLY', 'WHERE ( foo = ? ) FETCH FIRST 1 ROWS ONLY', 'WHERE (( foo = ? )) FETCH FIRST 1 ROWS ONLY', ], }, ); my @bind_tests = ( # scalar - equal { equal => 1, bindvals => [ undef, undef, ] }, { equal => 1, bindvals => [ 'foo', 'foo', ] }, { equal => 1, bindvals => [ 42, 42, '42', ] }, # scalarref - equal { equal => 1, bindvals => [ \'foo', \'foo', ] }, { equal => 1, bindvals => [ \42, \42, \'42', ] }, # arrayref - equal { equal => 1, bindvals => [ [], [] ] }, { equal => 1, bindvals => [ [42], [42], ['42'], ] }, { equal => 1, bindvals => [ [1, 42], [1, 42], ['1', 42], [1, '42'], ['1', '42'], ] }, # hashref - equal { equal => 1, bindvals => [ { foo => 42 }, { foo => 42 }, { foo => '42' }, ] }, { equal => 1, bindvals => [ { foo => 42, bar => 1 }, { foo => 42, bar => 1 }, { foo => '42', bar => 1 }, ] }, # blessed object - equal { equal => 1, bindvals => [ bless(\(local $_ = 42), 'Life::Universe::Everything'), bless(\(local $_ = 42), 'Life::Universe::Everything'), ] }, { equal => 1, bindvals => [ bless([42], 'Life::Universe::Everything'), bless([42], 'Life::Universe::Everything'), ] }, { equal => 1, bindvals => [ bless({ answer => 42 }, 'Life::Universe::Everything'), bless({ answer => 42 }, 'Life::Universe::Everything'), ] }, # complex data structure - equal { equal => 1, bindvals => [ [42, { foo => 'bar', quux => [1, 2, \3, { quux => [4, 5] } ] }, 8 ], [42, { foo => 'bar', quux => [1, 2, \3, { quux => [4, 5] } ] }, 8 ], ] }, # scalar - different { equal => 0, bindvals => [ undef, 'foo', 42, ] }, # scalarref - different { equal => 0, bindvals => [ \undef, \'foo', \42, ] }, # arrayref - different { equal => 0, bindvals => [ [undef], ['foo'], [42], ] }, # hashref - different { equal => 0, bindvals => [ { foo => undef }, { foo => 'bar' }, { foo => 42 }, ] }, # different types { equal => 0, bindvals => [ 'foo', \'foo', ['foo'], { foo => 'bar' }, ] }, # complex data structure - different { equal => 0, bindvals => [ [42, { foo => 'bar', quux => [1, 2, \3, { quux => [4, 5] } ] }, 8 ], [43, { foo => 'bar', quux => [1, 2, \3, { quux => [4, 5] } ] }, 8 ], [42, { foo => 'baz', quux => [1, 2, \3, { quux => [4, 5] } ] }, 8 ], [42, { bar => 'bar', quux => [1, 2, \3, { quux => [4, 5] } ] }, 8 ], [42, { foo => 'bar', quuux => [1, 2, \3, { quux => [4, 5] } ] }, 8 ], [42, { foo => 'bar', quux => [0, 1, 2, \3, { quux => [4, 5] } ] }, 8 ], [42, { foo => 'bar', quux => [1, 2, 3, { quux => [4, 5] } ] }, 8 ], [42, { foo => 'bar', quux => [1, 2, \4, { quux => [4, 5] } ] }, 8 ], [42, { foo => 'bar', quux => [1, 2, \3, { quuux => [4, 5] } ] }, 8 ], [42, { foo => 'bar', quux => [1, 2, \3, { quux => [4, 5, 6] } ] }, 8 ], [42, { foo => 'bar', quux => [1, 2, \3, { quux => 4 } ] }, 8 ], [42, { foo => 'bar', quux => [1, 2, \3, { quux => [4, 5], quuux => 1 } ] }, 8 ], [42, { foo => 'bar', quux => [1, 2, \3, { quux => [4, 5] } ] }, 8, 9 ], ] }, ); for my $test ( @sql_tests ) { # this does not work on 5.8.8 and earlier :( #local @{*SQL::Abstract::Test::}{keys %{$test->{opts}}} = map { \$_ } values %{$test->{opts}} # if $test->{opts}; my %restore_globals; for (keys %{$test->{opts} || {} }) { $restore_globals{$_} = ${${*SQL::Abstract::Test::}{$_}}; ${*SQL::Abstract::Test::}{$_} = \ do { my $cp = $test->{opts}{$_} }; } my $statements = $test->{statements}; while (@$statements) { my $sql1 = shift @$statements; foreach my $sql2 (@$statements) { my $equal = eq_sql($sql1, $sql2); TODO: { local $TODO = $test->{todo} if $test->{todo}; if ($test->{equal}) { ok($equal, "equal SQL expressions should have been considered equal"); } else { ok(!$equal, "different SQL expressions should have been considered not equal"); } if ($equal ^ $test->{equal}) { my ($ast1, $ast2) = map { SQL::Abstract::Test::parse ($_) } ($sql1, $sql2); $_ = dumper($_) for ($ast1, $ast2); diag "sql1: $sql1"; diag "sql2: $sql2"; note $sql_differ || 'No differences found'; note "ast1: $ast1"; note "ast2: $ast2"; } } } } ${*SQL::Abstract::Test::}{$_} = \$restore_globals{$_} for keys %restore_globals; } for my $test (@bind_tests) { my $bindvals = $test->{bindvals}; while (@$bindvals) { my $bind1 = shift @$bindvals; foreach my $bind2 (@$bindvals) { my $equal = eq_bind($bind1, $bind2); if ($test->{equal}) { ok($equal, "equal bind values considered equal"); } else { ok(!$equal, "different bind values considered not equal"); } if ($equal ^ $test->{equal}) { diag("bind1: " . dumper($bind1)); diag("bind2: " . dumper($bind2)); } } } } ok(eq_sql_bind( "SELECT * FROM foo WHERE id = ?", [42], "SELECT * FROM foo WHERE (id = ?)", [42], ), "eq_sql_bind considers equal SQL expressions and bind values equal" ); ok(!eq_sql_bind( "SELECT * FROM foo WHERE id = ?", [42], "SELECT * FROM foo WHERE (id = ?)", [0], ), "eq_sql_bind considers equal SQL expressions and different bind values different" ); ok(!eq_sql_bind( "SELECT * FROM foo WHERE id = ?", [42], "SELECT * FROM bar WHERE (id = ?)", [42], ), "eq_sql_bind considers different SQL expressions and equal bind values different" ); # test diag string ok (! eq_sql ( 'SELECT owner_name FROM books me WHERE ( source = ? )', 'SELECT owner_name FROM books me WHERE ( sUOrce = ? )', )); like( $sql_differ, qr/\Q[ source ] != [ sUOrce ]/, 'expected debug of literal diff', ); ok (! eq_sql ( 'SELECT owner_name FROM books me ORDER BY owner_name', 'SELECT owner_name FROM books me GROUP BY owner_name', )); like( $sql_differ, qr/\QOP [ORDER BY] != [GROUP BY]/, 'expected debug of op diff', ); ok (! eq_sql ( 'SELECT owner_name FROM books WHERE ( source = ? )', 'SELECT owner_name FROM books' )); like( $sql_differ, qr|\Q[WHERE source = ?] != [N/A]|, 'expected debug of missing branch', ); ok (eq_sql_bind ( \[ 'SELECT foo FROM bar WHERE baz = ? or buzz = ?', [ {} => 1 ], 2 ], 'SELECT foo FROM bar WHERE (baz = ?) OR buzz = ?', [ [ {} => 1 ], 2 ], ), 'arrayrefref unpacks correctly' ); is_same_sql_bind( \[ 'SELECT foo FROM bar WHERE baz = ? or buzz = ?', [ {} => 1 ], 2 ], \[ 'SELECT foo FROM bar WHERE (( baz = ? OR (buzz = ?) ))', [ {} => 1 ], 2 ], 'double arrayrefref unpacks correctly' ); done_testing; SQL-Abstract-1.81/t/05in_between.t0000644000175000017500000002421712422677324016066 0ustar rabbitrabbituse strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; use SQL::Abstract::Test import => [qw(is_same_sql_bind diag_where dumper)]; use SQL::Abstract; my @in_between_tests = ( { where => { x => { -between => [1, 2] } }, stmt => 'WHERE (x BETWEEN ? AND ?)', bind => [qw/1 2/], test => '-between with two placeholders', }, { where => { x => { -between => [\"1", 2] } }, stmt => 'WHERE (x BETWEEN 1 AND ?)', bind => [qw/2/], test => '-between with one literal sql arg and one placeholder', }, { where => { x => { -between => [1, \"2"] } }, stmt => 'WHERE (x BETWEEN ? AND 2)', bind => [qw/1/], test => '-between with one placeholder and one literal sql arg', }, { where => { x => { -between => [\'current_date - 1', \'current_date - 0'] } }, stmt => 'WHERE (x BETWEEN current_date - 1 AND current_date - 0)', bind => [], test => '-between with two literal sql arguments', }, { where => { x => { -between => [ \['current_date - ?', 1], \['current_date - ?', 0] ] } }, stmt => 'WHERE (x BETWEEN current_date - ? AND current_date - ?)', bind => [1, 0], test => '-between with two literal sql arguments with bind', }, { where => { x => { -between => \['? AND ?', 1, 2] } }, stmt => 'WHERE (x BETWEEN ? AND ?)', bind => [1,2], test => '-between with literal sql with placeholders (\["? AND ?", scalar, scalar])', }, { where => { x => { -between => \["'something' AND ?", 2] } }, stmt => "WHERE (x BETWEEN 'something' AND ?)", bind => [2], test => '-between with literal sql with one literal arg and one placeholder (\["\'something\' AND ?", scalar])', }, { where => { x => { -between => \["? AND 'something'", 1] } }, stmt => "WHERE (x BETWEEN ? AND 'something')", bind => [1], test => '-between with literal sql with one placeholder and one literal arg (\["? AND \'something\'", scalar])', }, { where => { x => { -between => \"'this' AND 'that'" } }, stmt => "WHERE (x BETWEEN 'this' AND 'that')", bind => [], test => '-between with literal sql with a literal (\"\'this\' AND \'that\'")', }, # generate a set of invalid -between tests ( map { { where => { x => { -between => $_ } }, test => 'invalid -between args', throws => qr|Operator 'BETWEEN' requires either an arrayref with two defined values or expressions, or a single literal scalarref/arrayref-ref|, } } ( [ 1, 2, 3 ], [ 1, undef, 3 ], [ undef, 2, 3 ], [ 1, 2, undef ], [ 1, undef ], [ undef, 2 ], [ undef, undef ], [ 1 ], [ undef ], [], 1, undef, )), { where => { start0 => { -between => [ 1, { -upper => 2 } ] }, start1 => { -between => \["? AND ?", 1, 2] }, start2 => { -between => \"lower(x) AND upper(y)" }, start3 => { -between => [ \"lower(x)", \["upper(?)", 'stuff' ], ] }, }, stmt => "WHERE ( ( start0 BETWEEN ? AND UPPER ? ) AND ( start1 BETWEEN ? AND ? ) AND ( start2 BETWEEN lower(x) AND upper(y) ) AND ( start3 BETWEEN lower(x) AND upper(?) ) )", bind => [1, 2, 1, 2, 'stuff'], test => '-between POD test', }, { args => { bindtype => 'columns' }, where => { start0 => { -between => [ 1, { -upper => 2 } ] }, start1 => { -between => \["? AND ?", [ start1 => 1], [start1 => 2] ] }, start2 => { -between => \"lower(x) AND upper(y)" }, start3 => { -between => [ \"lower(x)", \["upper(?)", [ start3 => 'stuff'] ], ] }, }, stmt => "WHERE ( ( start0 BETWEEN ? AND UPPER ? ) AND ( start1 BETWEEN ? AND ? ) AND ( start2 BETWEEN lower(x) AND upper(y) ) AND ( start3 BETWEEN lower(x) AND upper(?) ) )", bind => [ [ start0 => 1 ], [ start0 => 2 ], [ start1 => 1 ], [ start1 => 2 ], [ start3 => 'stuff' ], ], test => '-between POD test', }, { where => { 'test1.a' => { 'In', ['boom', 'bang'] } }, stmt => ' WHERE ( test1.a IN ( ?, ? ) )', bind => ['boom', 'bang'], test => 'In (no dash, initial cap) with qualified column', }, { where => { a => { 'between', ['boom', 'bang'] } }, stmt => ' WHERE ( a BETWEEN ? AND ? )', bind => ['boom', 'bang'], test => 'between (no dash) with two placeholders', }, { where => { x => { -in => [ 1 .. 3] } }, stmt => "WHERE x IN (?, ?, ?)", bind => [ 1 .. 3 ], test => '-in with an array of scalars', }, { where => { x => { -in => [] } }, stmt => "WHERE 0=1", bind => [], test => '-in with an empty array', }, { where => { x => { -in => \'( 1,2,lower(y) )' } }, stmt => "WHERE x IN ( 1,2,lower(y) )", bind => [], test => '-in with a literal scalarref', }, # note that outer parens are opened even though literal was requested below { where => { x => { -in => \['( ( ?,?,lower(y) ) )', 1, 2] } }, stmt => "WHERE x IN ( ?,?,lower(y) )", bind => [1, 2], test => '-in with a literal arrayrefref', }, { where => { status => { -in => \"(SELECT status_codes\nFROM states)" }, }, stmt => " WHERE status IN ( SELECT status_codes FROM states )", bind => [], test => '-in multi-line subquery test', }, # check that the outer paren opener is not too agressive # note: this syntax *is not legal* on SQLite (maybe others) # see end of https://rt.cpan.org/Ticket/Display.html?id=99503 { where => { foo => { -in => \ '(SELECT 1) UNION (SELECT 2)' } }, stmt => 'WHERE foo IN ( (SELECT 1) UNION (SELECT 2) )', bind => [], test => '-in paren-opening works on balanced pairs only', }, { where => { customer => { -in => \[ 'SELECT cust_id FROM cust WHERE balance > ?', 2000, ]}, status => { -in => \'SELECT status_codes FROM states' }, }, stmt => " WHERE customer IN ( SELECT cust_id FROM cust WHERE balance > ? ) AND status IN ( SELECT status_codes FROM states ) ", bind => [2000], test => '-in POD test', }, { where => { x => { -in => [ \['LOWER(?)', 'A' ], \'LOWER(b)', { -lower => 'c' } ] } }, stmt => " WHERE ( x IN ( LOWER(?), LOWER(b), LOWER ? ) )", bind => [qw/A c/], test => '-in with an array of function array refs with args', }, { throws => qr/ \QSQL::Abstract before v1.75 used to generate incorrect SQL \E \Qwhen the -IN operator was given an undef-containing list: \E \Q!!!AUDIT YOUR CODE AND DATA!!! (the upcoming Data::Query-based \E \Qversion of SQL::Abstract will emit the logically correct SQL \E \Qinstead of raising this exception)\E /x, where => { x => { -in => [ 1, undef ] } }, stmt => " WHERE ( x IN ( ? ) OR x IS NULL )", bind => [ 1 ], test => '-in with undef as an element', }, { throws => qr/ \QSQL::Abstract before v1.75 used to generate incorrect SQL \E \Qwhen the -IN operator was given an undef-containing list: \E \Q!!!AUDIT YOUR CODE AND DATA!!! (the upcoming Data::Query-based \E \Qversion of SQL::Abstract will emit the logically correct SQL \E \Qinstead of raising this exception)\E /x, where => { x => { -in => [ 1, undef, 2, 3, undef ] } }, stmt => " WHERE ( x IN ( ?, ?, ? ) OR x IS NULL )", bind => [ 1, 2, 3 ], test => '-in with multiple undef elements', }, { where => { a => { -in => 42 }, b => { -not_in => 42 } }, stmt => ' WHERE a IN ( ? ) AND b NOT IN ( ? )', bind => [ 42, 42 ], test => '-in, -not_in with scalar', }, { where => { a => { -in => [] }, b => { -not_in => [] } }, stmt => ' WHERE ( 0=1 AND 1=1 )', bind => [], test => '-in, -not_in with empty arrays', }, { throws => qr/ \QSQL::Abstract before v1.75 used to generate incorrect SQL \E \Qwhen the -IN operator was given an undef-containing list: \E \Q!!!AUDIT YOUR CODE AND DATA!!! (the upcoming Data::Query-based \E \Qversion of SQL::Abstract will emit the logically correct SQL \E \Qinstead of raising this exception)\E /x, where => { a => { -in => [42, undef] }, b => { -not_in => [42, undef] } }, stmt => ' WHERE ( ( a IN ( ? ) OR a IS NULL ) AND b NOT IN ( ? ) AND b IS NOT NULL )', bind => [ 42, 42 ], test => '-in, -not_in with undef among elements', }, { throws => qr/ \QSQL::Abstract before v1.75 used to generate incorrect SQL \E \Qwhen the -IN operator was given an undef-containing list: \E \Q!!!AUDIT YOUR CODE AND DATA!!! (the upcoming Data::Query-based \E \Qversion of SQL::Abstract will emit the logically correct SQL \E \Qinstead of raising this exception)\E /x, where => { a => { -in => [undef] }, b => { -not_in => [undef] } }, stmt => ' WHERE ( a IS NULL AND b IS NOT NULL )', bind => [], test => '-in, -not_in with just undef element', }, { where => { a => { -in => undef } }, throws => qr/Argument passed to the 'IN' operator can not be undefined/, test => '-in with undef argument', }, { where => { -in => [42] }, throws => qr/Illegal use of top-level '-in'/, test => 'Top level -in', }, { where => { -between => [42, 69] }, throws => qr/Illegal use of top-level '-between'/, test => 'Top level -between', }, ); for my $case (@in_between_tests) { TODO: { local $TODO = $case->{todo} if $case->{todo}; local $SQL::Abstract::Test::parenthesis_significant = $case->{parenthesis_significant}; my $label = $case->{test} || 'in-between test'; my $sql = SQL::Abstract->new ($case->{args} || {}); if (my $e = $case->{throws}) { my $stmt; throws_ok { ($stmt) = $sql->where($case->{where}) } $e, "$label throws correctly" or diag dumper ({ where => $case->{where}, result => $stmt }); } else { my ($stmt, @bind); warnings_are { ($stmt, @bind) = $sql->where($case->{where}); } [], "$label gives no warnings"; is_same_sql_bind( $stmt, \@bind, $case->{stmt}, $case->{bind}, "$label generates correct SQL and bind", ) || diag_where ( $case->{where} ); } } } done_testing; SQL-Abstract-1.81/t/02where.t0000644000175000017500000002476412410760067015057 0ustar rabbitrabbituse strict; use warnings; use Test::More; use Test::Warn; use SQL::Abstract::Test import => [qw(is_same_sql_bind diag_where) ]; use SQL::Abstract; my $not_stringifiable = bless {}, 'SQLA::NotStringifiable'; my @handle_tests = ( { where => { requestor => 'inna', worker => ['nwiger', 'rcwe', 'sfz'], status => { '!=', 'completed' } }, order => [], stmt => " WHERE ( requestor = ? AND status != ? AND ( ( worker = ? ) OR" . " ( worker = ? ) OR ( worker = ? ) ) )", bind => [qw/inna completed nwiger rcwe sfz/], }, { where => [ status => 'completed', user => 'nwiger', ], stmt => " WHERE ( status = ? OR user = ? )", bind => [qw/completed nwiger/], }, { where => { user => 'nwiger', status => 'completed' }, order => [qw/ticket/], stmt => " WHERE ( status = ? AND user = ? ) ORDER BY ticket", bind => [qw/completed nwiger/], }, { where => { user => 'nwiger', status => { '!=', 'completed' } }, order => [qw/ticket/], stmt => " WHERE ( status != ? AND user = ? ) ORDER BY ticket", bind => [qw/completed nwiger/], }, { where => { status => 'completed', reportid => { 'in', [567, 2335, 2] } }, order => [], stmt => " WHERE ( reportid IN ( ?, ?, ? ) AND status = ? )", bind => [qw/567 2335 2 completed/], }, { where => { status => 'completed', reportid => { 'not in', [567, 2335, 2] } }, order => [], stmt => " WHERE ( reportid NOT IN ( ?, ?, ? ) AND status = ? )", bind => [qw/567 2335 2 completed/], }, { where => { status => 'completed', completion_date => { 'between', ['2002-10-01', '2003-02-06'] }, }, order => \'ticket, requestor', stmt => "WHERE ( ( completion_date BETWEEN ? AND ? ) AND status = ? ) ORDER BY ticket, requestor", bind => [qw/2002-10-01 2003-02-06 completed/], }, { where => [ { user => 'nwiger', status => { 'in', ['pending', 'dispatched'] }, }, { user => 'robot', status => 'unassigned', }, ], order => [], stmt => " WHERE ( ( status IN ( ?, ? ) AND user = ? ) OR ( status = ? AND user = ? ) )", bind => [qw/pending dispatched nwiger unassigned robot/], }, { where => { priority => [ {'>', 3}, {'<', 1} ], requestor => \'is not null', }, order => 'priority', stmt => " WHERE ( ( ( priority > ? ) OR ( priority < ? ) ) AND requestor is not null ) ORDER BY priority", bind => [qw/3 1/], }, { where => { requestor => { '!=', ['-and', undef, ''] }, }, stmt => " WHERE ( requestor IS NOT NULL AND requestor != ? )", bind => [''], }, { where => { priority => [ {'>', 3}, {'<', 1} ], requestor => { '!=', undef }, }, order => [qw/a b c d e f g/], stmt => " WHERE ( ( ( priority > ? ) OR ( priority < ? ) ) AND requestor IS NOT NULL )" . " ORDER BY a, b, c, d, e, f, g", bind => [qw/3 1/], }, { where => { priority => { 'between', [1, 3] }, requestor => { 'like', undef }, }, order => \'requestor, ticket', stmt => " WHERE ( ( priority BETWEEN ? AND ? ) AND requestor IS NULL ) ORDER BY requestor, ticket", bind => [qw/1 3/], warns => qr/Supplying an undefined argument to 'LIKE' is deprecated/, }, { where => { id => 1, num => { '<=' => 20, '>' => 10, }, }, stmt => " WHERE ( id = ? AND ( num <= ? AND num > ? ) )", bind => [qw/1 20 10/], }, { where => { foo => {-not_like => [7,8,9]}, fum => {'like' => [qw/a b/]}, nix => {'between' => [100,200] }, nox => {'not between' => [150,160] }, wix => {'in' => [qw/zz yy/]}, wux => {'not_in' => [qw/30 40/]} }, stmt => " WHERE ( ( ( foo NOT LIKE ? ) OR ( foo NOT LIKE ? ) OR ( foo NOT LIKE ? ) ) AND ( ( fum LIKE ? ) OR ( fum LIKE ? ) ) AND ( nix BETWEEN ? AND ? ) AND ( nox NOT BETWEEN ? AND ? ) AND wix IN ( ?, ? ) AND wux NOT IN ( ?, ? ) )", bind => [7,8,9,'a','b',100,200,150,160,'zz','yy','30','40'], warns => qr/\QA multi-element arrayref as an argument to the inequality op 'NOT LIKE' is technically equivalent to an always-true 1=1/, }, { where => { bar => {'!=' => []}, }, stmt => " WHERE ( 1=1 )", bind => [], }, { where => { id => [], }, stmt => " WHERE ( 0=1 )", bind => [], }, { where => { foo => \["IN (?, ?)", 22, 33], bar => [-and => \["> ?", 44], \["< ?", 55] ], }, stmt => " WHERE ( (bar > ? AND bar < ?) AND foo IN (?, ?) )", bind => [44, 55, 22, 33], }, { where => { -and => [ user => 'nwiger', [ -and => [ workhrs => {'>', 20}, geo => 'ASIA' ], -or => { workhrs => {'<', 50}, geo => 'EURO' }, ], ], }, stmt => "WHERE ( user = ? AND ( ( workhrs > ? AND geo = ? ) OR ( geo = ? OR workhrs < ? ) ) )", bind => [qw/nwiger 20 ASIA EURO 50/], }, { where => { -and => [{}, { 'me.id' => '1'}] }, stmt => " WHERE ( ( me.id = ? ) )", bind => [ 1 ], }, { where => { foo => $not_stringifiable, }, stmt => " WHERE ( foo = ? )", bind => [ $not_stringifiable ], }, { where => \[ 'foo = ?','bar' ], stmt => " WHERE (foo = ?)", bind => [ "bar" ], }, { where => [ \[ 'foo = ?','bar' ] ], stmt => " WHERE (foo = ?)", bind => [ "bar" ], }, { where => { -bool => \'function(x)' }, stmt => " WHERE function(x)", bind => [], }, { where => { -bool => 'foo' }, stmt => " WHERE foo", bind => [], }, { where => { -and => [-bool => 'foo', -bool => 'bar'] }, stmt => " WHERE foo AND bar", bind => [], }, { where => { -or => [-bool => 'foo', -bool => 'bar'] }, stmt => " WHERE foo OR bar", bind => [], }, { where => { -not_bool => \'function(x)' }, stmt => " WHERE NOT function(x)", bind => [], }, { where => { -not_bool => 'foo' }, stmt => " WHERE NOT foo", bind => [], }, { where => { -and => [-not_bool => 'foo', -not_bool => 'bar'] }, stmt => " WHERE (NOT foo) AND (NOT bar)", bind => [], }, { where => { -or => [-not_bool => 'foo', -not_bool => 'bar'] }, stmt => " WHERE (NOT foo) OR (NOT bar)", bind => [], }, { where => { -bool => \['function(?)', 20] }, stmt => " WHERE function(?)", bind => [20], }, { where => { -not_bool => \['function(?)', 20] }, stmt => " WHERE NOT function(?)", bind => [20], }, { where => { -bool => { a => 1, b => 2} }, stmt => " WHERE a = ? AND b = ?", bind => [1, 2], }, { where => { -bool => [ a => 1, b => 2] }, stmt => " WHERE a = ? OR b = ?", bind => [1, 2], }, { where => { -not_bool => { a => 1, b => 2} }, stmt => " WHERE NOT (a = ? AND b = ?)", bind => [1, 2], }, { where => { -not_bool => [ a => 1, b => 2] }, stmt => " WHERE NOT ( a = ? OR b = ? )", bind => [1, 2], }, # Op against internal function { where => { bool1 => { '=' => { -not_bool => 'bool2' } } }, stmt => " WHERE ( bool1 = (NOT bool2) )", bind => [], }, { where => { -not_bool => { -not_bool => { -not_bool => 'bool2' } } }, stmt => " WHERE ( NOT ( NOT ( NOT bool2 ) ) )", bind => [], }, # Op against random functions (these two are oracle-specific) { where => { timestamp => { '!=' => { -trunc => { -year => \'sysdate' } } } }, stmt => " WHERE ( timestamp != TRUNC (YEAR sysdate) )", bind => [], }, { where => { timestamp => { '>=' => { -to_date => '2009-12-21 00:00:00' } } }, stmt => " WHERE ( timestamp >= TO_DATE ? )", bind => ['2009-12-21 00:00:00'], }, # Legacy function specs { where => { ip => {'<<=' => '127.0.0.1/32' } }, stmt => "WHERE ( ip <<= ? )", bind => ['127.0.0.1/32'], }, { where => { foo => { 'GLOB' => '*str*' } }, stmt => " WHERE foo GLOB ? ", bind => [ '*str*' ], }, { where => { foo => { 'REGEXP' => 'bar|baz' } }, stmt => " WHERE foo REGEXP ? ", bind => [ 'bar|baz' ], }, # Tests for -not # Basic tests only { where => { -not => { a => 1 } }, stmt => " WHERE ( (NOT a = ?) ) ", bind => [ 1 ], }, { where => { a => 1, -not => { b => 2 } }, stmt => " WHERE ( ( (NOT b = ?) AND a = ? ) ) ", bind => [ 2, 1 ], }, { where => { -not => { a => 1, b => 2, c => 3 } }, stmt => " WHERE ( (NOT ( a = ? AND b = ? AND c = ? )) ) ", bind => [ 1, 2, 3 ], }, { where => { -not => [ a => 1, b => 2, c => 3 ] }, stmt => " WHERE ( (NOT ( a = ? OR b = ? OR c = ? )) ) ", bind => [ 1, 2, 3 ], }, { where => { -not => { c => 3, -not => { b => 2, -not => { a => 1 } } } }, stmt => " WHERE ( (NOT ( (NOT ( (NOT a = ?) AND b = ? )) AND c = ? )) ) ", bind => [ 1, 2, 3 ], }, { where => { -not => { -bool => 'c', -not => { -not_bool => 'b', -not => { a => 1 } } } }, stmt => " WHERE ( (NOT ( c AND (NOT ( (NOT a = ?) AND (NOT b) )) )) ) ", bind => [ 1 ], }, ); for my $case (@handle_tests) { my $sql = SQL::Abstract->new; my ($stmt, @bind); warnings_exist { ($stmt, @bind) = $sql->where($case->{where}, $case->{order}); } $case->{warns} || []; is_same_sql_bind($stmt, \@bind, $case->{stmt}, $case->{bind}) || diag_where ( $case->{where} ); } done_testing; SQL-Abstract-1.81/t/03values.t0000644000175000017500000000577212361730666015252 0ustar rabbitrabbituse strict; use warnings; use Test::More; use SQL::Abstract::Test import => [qw/is_same_sql_bind is_same_bind/]; use SQL::Abstract; my @data = ( { user => 'nwiger', name => 'Nathan Wiger', phone => '123-456-7890', addr => 'Yeah, right', city => 'Milwalkee', state => 'Minnesota', }, { user => 'jimbo', name => 'Jimbo Bobson', phone => '321-456-0987', addr => 'Yo Momma', city => 'Yo City', state => 'Minnesota', }, { user => 'mr.hat', name => 'Mr. Garrison', phone => '123-456-7890', addr => undef, city => 'South Park', state => 'CO', }, { user => 'kennyg', name => undef, phone => '1-800-Sucky-Sucky', addr => 'Mr. Garrison', city => undef, state => 'CO', }, { user => 'barbara_streisand', name => 'MechaStreisand!', phone => 0, addr => -9230992340, city => 42, state => 'CO', }, ); # test insert() and values() for reentrancy my($insert_hash, $insert_array, $numfields); my $a_sql = SQL::Abstract->new; my $h_sql = SQL::Abstract->new; for my $record (@data) { my $values = [ map { $record->{$_} } sort keys %$record ]; my ($h_stmt, @h_bind) = $h_sql->insert('h_table', $record); my ($a_stmt, @a_bind) = $a_sql->insert('a_table', $values ); # init from first run, should not change afterwards $insert_hash ||= $h_stmt; $insert_array ||= $a_stmt; $numfields ||= @$values; is ( $a_stmt, $insert_array, 'Array-based insert statement unchanged' ); is ( $h_stmt, $insert_hash, 'Hash-based insert statement unchanged' ); is_deeply ( \@a_bind, \@h_bind, 'Bind values match after both insert() calls' ); is_deeply ( [$h_sql->values ($record)] , \@h_bind, 'values() output matches bind values after insert()' ); is ( scalar @h_bind, $numfields, 'Number of fields unchanged' ); } # test values() with literal sql # # NOTE: # The example is deliberately complicated by the addition of a literal ? in xfunc # This is an intentional test making sure literal ? remains untouched. # It is rather impractical in the field, as the user will have to insert # a bindvalue for the literal position(s) in the correct offset of \@bind { my $sql = SQL::Abstract->new; my $data = { event => 'rapture', stuff => 'fluff', time => \ 'now()', xfunc => \ 'xfunc(?)', yfunc => ['yfunc(?)', 'ystuff' ], zfunc => \['zfunc(?)', 'zstuff' ], zzlast => 'zzstuff', }; my ($stmt, @bind) = $sql->insert ('table', $data); is_same_sql_bind ( $stmt, \@bind, 'INSERT INTO table ( event, stuff, time, xfunc, yfunc, zfunc, zzlast) VALUES ( ?, ?, now(), xfunc (?), yfunc(?), zfunc(?), ? )', [qw/rapture fluff ystuff zstuff zzstuff/], # event < stuff ); is_same_bind ( [$sql->values ($data)], [@bind], 'values() output matches that of initial bind' ) || diag "Corresponding SQL statement: $stmt"; } done_testing; SQL-Abstract-1.81/t/08special_ops.t0000644000175000017500000000273412361730666016254 0ustar rabbitrabbituse strict; use warnings; use Test::More; use SQL::Abstract::Test import => ['is_same_sql_bind']; use SQL::Abstract; my $sqlmaker = SQL::Abstract->new(special_ops => [ # special op for MySql MATCH (field) AGAINST(word1, word2, ...) {regex => qr/^match$/i, handler => sub { my ($self, $field, $op, $arg) = @_; $arg = [$arg] if not ref $arg; my $label = $self->_quote($field); my ($placeholder) = $self->_convert('?'); my $placeholders = join ", ", (($placeholder) x @$arg); my $sql = $self->_sqlcase('match') . " ($label) " . $self->_sqlcase('against') . " ($placeholders) "; my @bind = $self->_bindtype($field, @$arg); return ($sql, @bind); } }, # special op for Basis+ NATIVE {regex => qr/^native$/i, handler => sub { my ($self, $field, $op, $arg) = @_; $arg =~ s/'/''/g; my $sql = "NATIVE (' $field $arg ')"; return ($sql); } }, ]); my @tests = ( #1 { where => {foo => {-match => 'foo'}, bar => {-match => [qw/foo bar/]}}, stmt => " WHERE ( MATCH (bar) AGAINST (?, ?) AND MATCH (foo) AGAINST (?) )", bind => [qw/foo bar foo/], }, #2 { where => {foo => {-native => "PH IS 'bar'"}}, stmt => " WHERE ( NATIVE (' foo PH IS ''bar'' ') )", bind => [], }, ); for (@tests) { my($stmt, @bind) = $sqlmaker->where($_->{where}, $_->{order}); is_same_sql_bind($stmt, \@bind, $_->{stmt}, $_->{bind}); } done_testing; SQL-Abstract-1.81/t/22op_value.t0000644000175000017500000000353312361733001015541 0ustar rabbitrabbituse strict; use warnings; use Test::More; use SQL::Abstract; use SQL::Abstract::Test import => [qw/is_same_sql_bind/]; for my $q ('', '"') { for my $col_btype (0,1) { my $sql_maker = SQL::Abstract->new( quote_char => $q, name_sep => $q ? '.' : '', $col_btype ? (bindtype => 'columns') : (), ); my ($sql, @bind) = $sql_maker->select ('artist', '*', { arr1 => { -value => [1,2] }, arr2 => { '>', { -value => [3,4] } }, field => [5,6] } ); is_same_sql_bind ( $sql, \@bind, "SELECT * FROM ${q}artist${q} WHERE ${q}arr1${q} = ? AND ${q}arr2${q} > ? AND ( ${q}field${q} = ? OR ${q}field${q} = ? ) ", [ $col_btype ? ( [ arr1 => [ 1, 2 ] ], [ arr2 => [ 3, 4 ] ], [ field => 5 ], [ field => 6 ], ) : ( [ 1, 2 ], [ 3, 4 ], 5, 6, ) ], ); { local $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /Supplying an undefined argument to '(?:NOT )?LIKE'/ }; ($sql, @bind) = $sql_maker->where ({ c1 => undef, c2 => { -value => undef }, c3 => { '=' => { -value => undef } }, c4 => { '!=' => { -value => undef } }, c5 => { '<>' => { -value => undef } }, c6 => { '-like' => { -value => undef } }, c7 => { '-not_like' => { -value => undef } }, c8 => { 'is' => { -value => undef } }, c9 => { 'is not' => { -value => undef } }, }); is_same_sql_bind ( $sql, \@bind, "WHERE ${q}c1${q} IS NULL AND ${q}c2${q} IS NULL AND ${q}c3${q} IS NULL AND ${q}c4${q} IS NOT NULL AND ${q}c5${q} IS NOT NULL AND ${q}c6${q} IS NULL AND ${q}c7${q} IS NOT NULL AND ${q}c8${q} IS NULL AND ${q}c9${q} IS NOT NULL ", [], ); } }} done_testing; SQL-Abstract-1.81/t/dbic/0000755000175000017500000000000012422705003014272 5ustar rabbitrabbitSQL-Abstract-1.81/t/dbic/show-progress.t0000644000175000017500000000165512414330762017317 0ustar rabbitrabbituse strict; use warnings; use Test::More; BEGIN { # ask for a recent DBIC version to skip the 5.6 tests as well plan skip_all => 'Test temporarily requires DBIx::Class' unless eval { require DBIx::Class::Storage::Statistics; DBIx::Class->VERSION('0.08124') }; plan skip_all => 'Test does not properly work with the pre-0.082800 DBIC trials' if DBIx::Class->VERSION =~ /^0.082700\d\d/; } use DBIx::Class::Storage::Debug::PrettyPrint; my $cap; open my $fh, '>', \$cap; my $pp = DBIx::Class::Storage::Debug::PrettyPrint->new({ show_progress => 1, clear_line => 'CLEAR', executing => 'GOGOGO', }); $pp->debugfh($fh); $pp->query_start('SELECT * FROM frew WHERE id = 1'); is( $cap, qq(SELECT * FROM frew WHERE id = 1 : \nGOGOGO), 'SQL Logged' ); $pp->query_end('SELECT * FROM frew WHERE id = 1'); is( $cap, qq(SELECT * FROM frew WHERE id = 1 : \nGOGOGOCLEAR), 'SQL Logged' ); done_testing; SQL-Abstract-1.81/t/dbic/no-repeats.t0000644000175000017500000000312512414330752016543 0ustar rabbitrabbituse strict; use warnings; use Test::More; BEGIN { # ask for a recent DBIC version to skip the 5.6 tests as well plan skip_all => 'Test temporarily requires DBIx::Class' unless eval { require DBIx::Class::Storage::Statistics; DBIx::Class->VERSION('0.08124') }; plan skip_all => 'Test does not properly work with the pre-0.082800 DBIC trials' if DBIx::Class->VERSION =~ /^0.082700\d\d/; } use DBIx::Class::Storage::Debug::PrettyPrint; my $cap; open my $fh, '>', \$cap; my $pp = DBIx::Class::Storage::Debug::PrettyPrint->new({ profile => 'none', squash_repeats => 1, fill_in_placeholders => 1, placeholder_surround => ['', ''], show_progress => 0, }); $pp->debugfh($fh); $pp->query_start('SELECT * FROM frew WHERE id = ?', q('1')); is( $cap, qq(SELECT * FROM frew WHERE id = '1'\n), 'SQL Logged' ); open $fh, '>', \$cap; $pp->query_start('SELECT * FROM frew WHERE id = ?', q('2')); is( $cap, qq(... : '2'\n), 'Repeated SQL ellided' ); open $fh, '>', \$cap; $pp->query_start('SELECT * FROM frew WHERE id = ?', q('3')); is( $cap, qq(... : '3'\n), 'Repeated SQL ellided' ); open $fh, '>', \$cap; $pp->query_start('SELECT * FROM frew WHERE id = ?', q('4')); is( $cap, qq(... : '4'\n), 'Repeated SQL ellided' ); open $fh, '>', \$cap; $pp->query_start('SELECT * FROM bar WHERE id = ?', q('4')); is( $cap, qq(SELECT * FROM bar WHERE id = '4'\n), 'New SQL Logged' ); open $fh, '>', \$cap; $pp->query_start('SELECT * FROM frew WHERE id = ?', q('1')); is( $cap, qq(SELECT * FROM frew WHERE id = '1'\n), 'New SQL Logged' ); done_testing; SQL-Abstract-1.81/t/dbic/bulk-insert.t0000644000175000017500000000165012414330741016724 0ustar rabbitrabbituse strict; use warnings; use Test::More; BEGIN { # ask for a recent DBIC version to skip the 5.6 testing as well plan skip_all => 'Test temporarily requires DBIx::Class' unless eval { require DBIx::Class::Storage::Statistics; DBIx::Class->VERSION('0.08124') }; plan skip_all => 'Test does not properly work with the pre-0.082800 DBIC trials' if DBIx::Class->VERSION =~ /^0.082700\d\d/; } use DBIx::Class::Storage::Debug::PrettyPrint; my $cap; open my $fh, '>', \$cap; my $pp = DBIx::Class::Storage::Debug::PrettyPrint->new({ profile => 'none', fill_in_placeholders => 1, placeholder_surround => [qw(' ')], show_progress => 0, }); $pp->debugfh($fh); $pp->query_start('INSERT INTO self_ref_alias (alias, self_ref) VALUES ( ?, ? )', qw('__BULK_INSERT__' '1')); is( $cap, qq{INSERT INTO self_ref_alias( alias, self_ref ) VALUES( ?, ? ) : '__BULK_INSERT__', '1'\n}, 'SQL Logged' ); done_testing; SQL-Abstract-1.81/t/15placeholders.t0000644000175000017500000000170312361730666016411 0ustar rabbitrabbituse strict; use warnings; use Test::More; use SQL::Abstract::Tree; { my $sqlat = SQL::Abstract::Tree->new({ fill_in_placeholders => 1, placeholder_surround => [qw(; -)], }); is($sqlat->fill_in_placeholder(['lolz']), q(;lolz-), 'placeholders are populated correctly' ); } { my $sqlat = SQL::Abstract::Tree->new({ fill_in_placeholders => 1, placeholder_surround => [qw(< >)], }); is($sqlat->fill_in_placeholder(['station']), q(), 'placeholders are populated correctly and in order' ); } { my $sqlat = SQL::Abstract::Tree->new({ fill_in_placeholders => 1, placeholder_surround => [qw(' ')], }); is $sqlat->format('SELECT ? AS x, ? AS y FROM Foo WHERE t > ? and z IN (?, ?, ?) ', [qw/frew ribasushi 2008-12-12 1 2 3/]), q[SELECT 'frew' AS x, 'ribasushi' AS y FROM Foo WHERE t > '2008-12-12' AND z IN ( '1', '2', '3' )], 'Complex placeholders work'; } done_testing; SQL-Abstract-1.81/t/21op_ident.t0000644000175000017500000000213612407404211015524 0ustar rabbitrabbituse strict; use warnings; use Test::More; use Test::Exception; use SQL::Abstract; use SQL::Abstract::Test import => [qw/is_same_sql_bind/]; for my $q ('', '"') { my $sql_maker = SQL::Abstract->new( quote_char => $q, name_sep => $q ? '.' : '', ); throws_ok { $sql_maker->where({ foo => { -ident => undef } }) } qr/-ident requires a single plain scalar argument/; my ($sql, @bind) = $sql_maker->select ('artist', '*', { 'artist.name' => { -ident => 'artist.pseudonym' } } ); is_same_sql_bind ( $sql, \@bind, "SELECT * FROM ${q}artist${q} WHERE ${q}artist${q}.${q}name${q} = ${q}artist${q}.${q}pseudonym${q} ", [], ); ($sql, @bind) = $sql_maker->update ('artist', { 'artist.name' => { -ident => 'artist.pseudonym' } }, { 'artist.name' => { '!=' => { -ident => 'artist.pseudonym' } } }, ); is_same_sql_bind ( $sql, \@bind, "UPDATE ${q}artist${q} SET ${q}artist${q}.${q}name${q} = ${q}artist${q}.${q}pseudonym${q} WHERE ${q}artist${q}.${q}name${q} != ${q}artist${q}.${q}pseudonym${q} ", [], ); } done_testing; SQL-Abstract-1.81/t/16no_sideeffects.t0000644000175000017500000000070512254322025016711 0ustar rabbitrabbituse strict; use warnings; use Test::More; use SQL::Abstract::Tree; ok my $placeholders = [100,'xxx']; ok my $sqlat = SQL::Abstract::Tree->new({profile=>'html'}); ok my $out = $sqlat->format('SELECT * FROM bar WHERE x = ?', $placeholders); is scalar(@$placeholders), 2, 'correct number of placeholders'; is $placeholders->[0], 100, 'did not mess up a placeholder'; is $placeholders->[1], 'xxx', 'did not mess up a placeholder'; done_testing; SQL-Abstract-1.81/t/20injection_guard.t0000644000175000017500000000210612361730666017102 0ustar rabbitrabbituse strict; use warnings; use Test::More; use Test::Exception; use SQL::Abstract::Test import => ['is_same_sql_bind']; use SQL::Abstract; my $sqla = SQL::Abstract->new; my $sqla_q = SQL::Abstract->new(quote_char => '"'); throws_ok( sub { $sqla->select( 'foo', [ 'bar' ], { 'bobby; tables' => 'bar' }, ); }, qr/Possible SQL injection attempt/, 'Injection thwarted on unquoted column' ); my ($sql, @bind) = $sqla_q->select( 'foo', [ 'bar' ], { 'bobby; tables' => 'bar' }, ); is_same_sql_bind ( $sql, \@bind, 'SELECT "bar" FROM "foo" WHERE ( "bobby; tables" = ? )', [ 'bar' ], 'Correct sql with quotes on' ); for ($sqla, $sqla_q) { throws_ok( sub { $_->select( 'foo', [ 'bar' ], { x => { 'bobby; tables' => 'y' } }, ); }, qr/Possible SQL injection attempt/, 'Injection thwarted on top level op'); throws_ok( sub { $_->select( 'foo', [ 'bar' ], { x => { '<' => { "-go\ndo some harm" => 'y' } } }, ); }, qr/Possible SQL injection attempt/, 'Injection thwarted on chained functions'); } done_testing; SQL-Abstract-1.81/t/12confmerge.t0000644000175000017500000000111512254322025015666 0ustar rabbitrabbituse strict; use warnings; use Test::More; use SQL::Abstract::Tree; my $tree = SQL::Abstract::Tree->new({ profile => 'console', colormap => { select => undef, 'group by' => ['yo', 'seph'] , }, }); is $tree->newline, "\n", 'console profile appears to have been used'; ok !defined $tree->colormap->{select}, 'select correctly got undefined from colormap'; ok eq_array($tree->colormap->{'group by'}, [qw(yo seph)]), 'group by correctly got overridden'; ok ref $tree->colormap->{'order by'}, 'but the rest of the colormap does not get blown away'; done_testing; SQL-Abstract-1.81/t/01generate.t0000644000175000017500000011175112410777714015536 0ustar rabbitrabbituse strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; use SQL::Abstract::Test import => [qw( is_same_sql_bind diag_where dumper )]; use SQL::Abstract; #### WARNING #### # # -nest has been undocumented on purpose, but is still supported for the # foreseable future. Do not rip out the -nest tests before speaking to # someone on the DBIC mailing list or in irc.perl.org#dbix-class # ################# my @tests = ( { func => 'select', args => ['test', '*'], stmt => 'SELECT * FROM test', stmt_q => 'SELECT * FROM `test`', bind => [] }, { func => 'select', args => ['test', [qw(one two three)]], stmt => 'SELECT one, two, three FROM test', stmt_q => 'SELECT `one`, `two`, `three` FROM `test`', bind => [] }, { func => 'select', args => ['test', '*', { a => 0 }, [qw/boom bada bing/]], stmt => 'SELECT * FROM test WHERE ( a = ? ) ORDER BY boom, bada, bing', stmt_q => 'SELECT * FROM `test` WHERE ( `a` = ? ) ORDER BY `boom`, `bada`, `bing`', bind => [0] }, { func => 'select', args => ['test', '*', [ { a => 5 }, { b => 6 } ]], stmt => 'SELECT * FROM test WHERE ( ( a = ? ) OR ( b = ? ) )', stmt_q => 'SELECT * FROM `test` WHERE ( ( `a` = ? ) OR ( `b` = ? ) )', bind => [5,6] }, { func => 'select', args => ['test', '*', undef, ['id']], stmt => 'SELECT * FROM test ORDER BY id', stmt_q => 'SELECT * FROM `test` ORDER BY `id`', bind => [] }, { func => 'select', args => ['test', '*', { a => 'boom' } , ['id']], stmt => 'SELECT * FROM test WHERE ( a = ? ) ORDER BY id', stmt_q => 'SELECT * FROM `test` WHERE ( `a` = ? ) ORDER BY `id`', bind => ['boom'] }, { func => 'select', args => ['test', '*', { a => ['boom', 'bang'] }], stmt => 'SELECT * FROM test WHERE ( ( ( a = ? ) OR ( a = ? ) ) )', stmt_q => 'SELECT * FROM `test` WHERE ( ( ( `a` = ? ) OR ( `a` = ? ) ) )', bind => ['boom', 'bang'] }, { func => 'select', args => ['test', '*', { a => { '!=', 'boom' } }], stmt => 'SELECT * FROM test WHERE ( a != ? )', stmt_q => 'SELECT * FROM `test` WHERE ( `a` != ? )', bind => ['boom'] }, { func => 'update', args => ['test', {a => 'boom'}, {a => undef}], stmt => 'UPDATE test SET a = ? WHERE ( a IS NULL )', stmt_q => 'UPDATE `test` SET `a` = ? WHERE ( `a` IS NULL )', bind => ['boom'] }, { func => 'update', args => ['test', {a => 'boom'}, { a => {'!=', "bang" }} ], stmt => 'UPDATE test SET a = ? WHERE ( a != ? )', stmt_q => 'UPDATE `test` SET `a` = ? WHERE ( `a` != ? )', bind => ['boom', 'bang'] }, { func => 'update', args => ['test', {'a-funny-flavored-candy' => 'yummy', b => 'oops'}, { a42 => "bang" }], stmt => 'UPDATE test SET a-funny-flavored-candy = ?, b = ? WHERE ( a42 = ? )', stmt_q => 'UPDATE `test` SET `a-funny-flavored-candy` = ?, `b` = ? WHERE ( `a42` = ? )', bind => ['yummy', 'oops', 'bang'] }, { func => 'delete', args => ['test', {requestor => undef}], stmt => 'DELETE FROM test WHERE ( requestor IS NULL )', stmt_q => 'DELETE FROM `test` WHERE ( `requestor` IS NULL )', bind => [] }, { func => 'delete', args => [[qw/test1 test2 test3/], { 'test1.field' => \'!= test2.field', user => {'!=','nwiger'} }, ], stmt => 'DELETE FROM test1, test2, test3 WHERE ( test1.field != test2.field AND user != ? )', stmt_q => 'DELETE FROM `test1`, `test2`, `test3` WHERE ( `test1`.`field` != test2.field AND `user` != ? )', # test2.field is a literal value, cannnot be quoted. bind => ['nwiger'] }, { func => 'select', args => [[\'test1', 'test2'], '*', { 'test1.a' => 'boom' } ], stmt => 'SELECT * FROM test1, test2 WHERE ( test1.a = ? )', stmt_q => 'SELECT * FROM test1, `test2` WHERE ( `test1`.`a` = ? )', bind => ['boom'] }, { func => 'insert', args => ['test', {a => 1, b => 2, c => 3, d => 4, e => 5}], stmt => 'INSERT INTO test (a, b, c, d, e) VALUES (?, ?, ?, ?, ?)', stmt_q => 'INSERT INTO `test` (`a`, `b`, `c`, `d`, `e`) VALUES (?, ?, ?, ?, ?)', bind => [qw/1 2 3 4 5/], }, { func => 'insert', args => ['test', [qw/1 2 3 4 5/]], stmt => 'INSERT INTO test VALUES (?, ?, ?, ?, ?)', stmt_q => 'INSERT INTO `test` VALUES (?, ?, ?, ?, ?)', bind => [qw/1 2 3 4 5/], }, { func => 'insert', args => ['test', [qw/1 2 3 4 5/, undef]], stmt => 'INSERT INTO test VALUES (?, ?, ?, ?, ?, ?)', stmt_q => 'INSERT INTO `test` VALUES (?, ?, ?, ?, ?, ?)', bind => [qw/1 2 3 4 5/, undef], }, { func => 'update', args => ['test', {a => 1, b => 2, c => 3, d => 4, e => 5}], stmt => 'UPDATE test SET a = ?, b = ?, c = ?, d = ?, e = ?', stmt_q => 'UPDATE `test` SET `a` = ?, `b` = ?, `c` = ?, `d` = ?, `e` = ?', bind => [qw/1 2 3 4 5/], }, { func => 'update', args => ['test', {a => 1, b => 2, c => 3, d => 4, e => 5}, {a => {'in', [1..5]}}], stmt => 'UPDATE test SET a = ?, b = ?, c = ?, d = ?, e = ? WHERE ( a IN ( ?, ?, ?, ?, ? ) )', stmt_q => 'UPDATE `test` SET `a` = ?, `b` = ?, `c` = ?, `d` = ?, `e` = ? WHERE ( `a` IN ( ?, ?, ?, ?, ? ) )', bind => [qw/1 2 3 4 5 1 2 3 4 5/], }, { func => 'update', args => ['test', {a => 1, b => \["to_date(?, 'MM/DD/YY')", '02/02/02']}, {a => {'between', [1,2]}}], stmt => 'UPDATE test SET a = ?, b = to_date(?, \'MM/DD/YY\') WHERE ( a BETWEEN ? AND ? )', stmt_q => 'UPDATE `test` SET `a` = ?, `b` = to_date(?, \'MM/DD/YY\') WHERE ( `a` BETWEEN ? AND ? )', bind => [qw(1 02/02/02 1 2)], }, { func => 'insert', args => ['test.table', {high_limit => \'max(all_limits)', low_limit => 4} ], stmt => 'INSERT INTO test.table (high_limit, low_limit) VALUES (max(all_limits), ?)', stmt_q => 'INSERT INTO `test`.`table` (`high_limit`, `low_limit`) VALUES (max(all_limits), ?)', bind => ['4'], }, { func => 'insert', args => ['test.table', [ \'max(all_limits)', 4 ] ], stmt => 'INSERT INTO test.table VALUES (max(all_limits), ?)', stmt_q => 'INSERT INTO `test`.`table` VALUES (max(all_limits), ?)', bind => ['4'], }, { func => 'insert', new => {bindtype => 'columns'}, args => ['test.table', {one => 2, three => 4, five => 6} ], stmt => 'INSERT INTO test.table (five, one, three) VALUES (?, ?, ?)', stmt_q => 'INSERT INTO `test`.`table` (`five`, `one`, `three`) VALUES (?, ?, ?)', bind => [['five', 6], ['one', 2], ['three', 4]], # alpha order, man... }, { func => 'select', new => {bindtype => 'columns', case => 'lower'}, args => ['test.table', [qw/one two three/], {one => 2, three => 4, five => 6} ], stmt => 'select one, two, three from test.table where ( five = ? and one = ? and three = ? )', stmt_q => 'select `one`, `two`, `three` from `test`.`table` where ( `five` = ? and `one` = ? and `three` = ? )', bind => [['five', 6], ['one', 2], ['three', 4]], # alpha order, man... }, { func => 'update', new => {bindtype => 'columns', cmp => 'like'}, args => ['testin.table2', {One => 22, Three => 44, FIVE => 66}, {Beer => 'is', Yummy => '%YES%', IT => ['IS','REALLY','GOOD']}], stmt => 'UPDATE testin.table2 SET FIVE = ?, One = ?, Three = ? WHERE ' . '( Beer LIKE ? AND ( ( IT LIKE ? ) OR ( IT LIKE ? ) OR ( IT LIKE ? ) ) AND Yummy LIKE ? )', stmt_q => 'UPDATE `testin`.`table2` SET `FIVE` = ?, `One` = ?, `Three` = ? WHERE ' . '( `Beer` LIKE ? AND ( ( `IT` LIKE ? ) OR ( `IT` LIKE ? ) OR ( `IT` LIKE ? ) ) AND `Yummy` LIKE ? )', bind => [['FIVE', 66], ['One', 22], ['Three', 44], ['Beer','is'], ['IT','IS'], ['IT','REALLY'], ['IT','GOOD'], ['Yummy','%YES%']], }, { func => 'select', args => ['test', '*', {priority => [ -and => {'!=', 2}, { -not_like => '3%'} ]}], stmt => 'SELECT * FROM test WHERE ( ( ( priority != ? ) AND ( priority NOT LIKE ? ) ) )', stmt_q => 'SELECT * FROM `test` WHERE ( ( ( `priority` != ? ) AND ( `priority` NOT LIKE ? ) ) )', bind => [qw(2 3%)], }, { func => 'select', args => ['Yo Momma', '*', { user => 'nwiger', -nest => [ workhrs => {'>', 20}, geo => 'ASIA' ] }], stmt => 'SELECT * FROM Yo Momma WHERE ( ( ( workhrs > ? ) OR ( geo = ? ) ) AND user = ? )', stmt_q => 'SELECT * FROM `Yo Momma` WHERE ( ( ( `workhrs` > ? ) OR ( `geo` = ? ) ) AND `user` = ? )', bind => [qw(20 ASIA nwiger)], }, { func => 'update', args => ['taco_punches', { one => 2, three => 4 }, { bland => [ -and => {'!=', 'yes'}, {'!=', 'YES'} ], tasty => { '!=', [qw(yes YES)] }, -nest => [ face => [ -or => {'=', 'mr.happy'}, {'=', undef} ] ] }, ], warns => qr/\QA multi-element arrayref as an argument to the inequality op '!=' is technically equivalent to an always-true 1=1/, stmt => 'UPDATE taco_punches SET one = ?, three = ? WHERE ( ( ( ( ( face = ? ) OR ( face IS NULL ) ) ) )' . ' AND ( ( bland != ? ) AND ( bland != ? ) ) AND ( ( tasty != ? ) OR ( tasty != ? ) ) )', stmt_q => 'UPDATE `taco_punches` SET `one` = ?, `three` = ? WHERE ( ( ( ( ( `face` = ? ) OR ( `face` IS NULL ) ) ) )' . ' AND ( ( `bland` != ? ) AND ( `bland` != ? ) ) AND ( ( `tasty` != ? ) OR ( `tasty` != ? ) ) )', bind => [qw(2 4 mr.happy yes YES yes YES)], }, { func => 'select', args => ['jeff', '*', { name => {'ilike', '%smith%', -not_in => ['Nate','Jim','Bob','Sally']}, -nest => [ -or => [ -and => [age => { -between => [20,30] }, age => {'!=', 25} ], yob => {'<', 1976} ] ] } ], stmt => 'SELECT * FROM jeff WHERE ( ( ( ( ( ( ( age BETWEEN ? AND ? ) AND ( age != ? ) ) ) OR ( yob < ? ) ) ) )' . ' AND name NOT IN ( ?, ?, ?, ? ) AND name ILIKE ? )', stmt_q => 'SELECT * FROM `jeff` WHERE ( ( ( ( ( ( ( `age` BETWEEN ? AND ? ) AND ( `age` != ? ) ) ) OR ( `yob` < ? ) ) ) )' . ' AND `name` NOT IN ( ?, ?, ?, ? ) AND `name` ILIKE ? )', bind => [qw(20 30 25 1976 Nate Jim Bob Sally %smith%)] }, { func => 'update', args => ['fhole', {fpoles => 4}, [ { race => [qw/-or black white asian /] }, { -nest => { firsttime => [-or => {'=','yes'}, undef] } }, { -and => [ { firstname => {-not_like => 'candace'} }, { lastname => {-in => [qw(jugs canyon towers)] } } ] }, ] ], stmt => 'UPDATE fhole SET fpoles = ? WHERE ( ( ( ( ( ( ( race = ? ) OR ( race = ? ) OR ( race = ? ) ) ) ) ) )' . ' OR ( ( ( ( firsttime = ? ) OR ( firsttime IS NULL ) ) ) ) OR ( ( ( firstname NOT LIKE ? ) ) AND ( lastname IN (?, ?, ?) ) ) )', stmt_q => 'UPDATE `fhole` SET `fpoles` = ? WHERE ( ( ( ( ( ( ( `race` = ? ) OR ( `race` = ? ) OR ( `race` = ? ) ) ) ) ) )' . ' OR ( ( ( ( `firsttime` = ? ) OR ( `firsttime` IS NULL ) ) ) ) OR ( ( ( `firstname` NOT LIKE ? ) ) AND ( `lastname` IN( ?, ?, ? )) ) )', bind => [qw(4 black white asian yes candace jugs canyon towers)] }, { func => 'insert', args => ['test', {a => 1, b => \["to_date(?, 'MM/DD/YY')", '02/02/02']}], stmt => 'INSERT INTO test (a, b) VALUES (?, to_date(?, \'MM/DD/YY\'))', stmt_q => 'INSERT INTO `test` (`a`, `b`) VALUES (?, to_date(?, \'MM/DD/YY\'))', bind => [qw(1 02/02/02)], }, { func => 'select', args => ['test', '*', { a => \["= to_date(?, 'MM/DD/YY')", '02/02/02']}], stmt => q{SELECT * FROM test WHERE ( a = to_date(?, 'MM/DD/YY') )}, stmt_q => q{SELECT * FROM `test` WHERE ( `a` = to_date(?, 'MM/DD/YY') )}, bind => ['02/02/02'], }, { func => 'insert', new => {array_datatypes => 1}, args => ['test', {a => 1, b => [1, 1, 2, 3, 5, 8]}], stmt => 'INSERT INTO test (a, b) VALUES (?, ?)', stmt_q => 'INSERT INTO `test` (`a`, `b`) VALUES (?, ?)', bind => [1, [1, 1, 2, 3, 5, 8]], }, { func => 'insert', new => {bindtype => 'columns', array_datatypes => 1}, args => ['test', {a => 1, b => [1, 1, 2, 3, 5, 8]}], stmt => 'INSERT INTO test (a, b) VALUES (?, ?)', stmt_q => 'INSERT INTO `test` (`a`, `b`) VALUES (?, ?)', bind => [[a => 1], [b => [1, 1, 2, 3, 5, 8]]], }, { func => 'update', new => {array_datatypes => 1}, args => ['test', {a => 1, b => [1, 1, 2, 3, 5, 8]}], stmt => 'UPDATE test SET a = ?, b = ?', stmt_q => 'UPDATE `test` SET `a` = ?, `b` = ?', bind => [1, [1, 1, 2, 3, 5, 8]], }, { func => 'update', new => {bindtype => 'columns', array_datatypes => 1}, args => ['test', {a => 1, b => [1, 1, 2, 3, 5, 8]}], stmt => 'UPDATE test SET a = ?, b = ?', stmt_q => 'UPDATE `test` SET `a` = ?, `b` = ?', bind => [[a => 1], [b => [1, 1, 2, 3, 5, 8]]], }, { func => 'select', args => ['test', '*', { a => {'>', \'1 + 1'}, b => 8 }], stmt => 'SELECT * FROM test WHERE ( a > 1 + 1 AND b = ? )', stmt_q => 'SELECT * FROM `test` WHERE ( `a` > 1 + 1 AND `b` = ? )', bind => [8], }, { func => 'select', args => ['test', '*', { a => {'<' => \["to_date(?, 'MM/DD/YY')", '02/02/02']}, b => 8 }], stmt => 'SELECT * FROM test WHERE ( a < to_date(?, \'MM/DD/YY\') AND b = ? )', stmt_q => 'SELECT * FROM `test` WHERE ( `a` < to_date(?, \'MM/DD/YY\') AND `b` = ? )', bind => ['02/02/02', 8], }, { #TODO in SQLA >= 2.0 it will die instead (we kept this just because old SQLA passed it through) func => 'insert', args => ['test', {a => 1, b => 2, c => 3, d => 4, e => { answer => 42 }}], stmt => 'INSERT INTO test (a, b, c, d, e) VALUES (?, ?, ?, ?, ?)', stmt_q => 'INSERT INTO `test` (`a`, `b`, `c`, `d`, `e`) VALUES (?, ?, ?, ?, ?)', bind => [qw/1 2 3 4/, { answer => 42}], warns => qr/HASH ref as bind value in insert is not supported/i, }, { func => 'update', args => ['test', {a => 1, b => \["42"]}, {a => {'between', [1,2]}}], stmt => 'UPDATE test SET a = ?, b = 42 WHERE ( a BETWEEN ? AND ? )', stmt_q => 'UPDATE `test` SET `a` = ?, `b` = 42 WHERE ( `a` BETWEEN ? AND ? )', bind => [qw(1 1 2)], }, { func => 'insert', args => ['test', {a => 1, b => \["42"]}], stmt => 'INSERT INTO test (a, b) VALUES (?, 42)', stmt_q => 'INSERT INTO `test` (`a`, `b`) VALUES (?, 42)', bind => [qw(1)], }, { func => 'select', args => ['test', '*', { a => \["= 42"], b => 1}], stmt => q{SELECT * FROM test WHERE ( a = 42 ) AND (b = ? )}, stmt_q => q{SELECT * FROM `test` WHERE ( `a` = 42 ) AND ( `b` = ? )}, bind => [qw(1)], }, { func => 'select', args => ['test', '*', { a => {'<' => \["42"]}, b => 8 }], stmt => 'SELECT * FROM test WHERE ( a < 42 AND b = ? )', stmt_q => 'SELECT * FROM `test` WHERE ( `a` < 42 AND `b` = ? )', bind => [qw(8)], }, { func => 'insert', new => {bindtype => 'columns'}, args => ['test', {a => 1, b => \["to_date(?, 'MM/DD/YY')", [dummy => '02/02/02']]}], stmt => 'INSERT INTO test (a, b) VALUES (?, to_date(?, \'MM/DD/YY\'))', stmt_q => 'INSERT INTO `test` (`a`, `b`) VALUES (?, to_date(?, \'MM/DD/YY\'))', bind => [[a => '1'], [dummy => '02/02/02']], }, { func => 'update', new => {bindtype => 'columns'}, args => ['test', {a => 1, b => \["to_date(?, 'MM/DD/YY')", [dummy => '02/02/02']]}, {a => {'between', [1,2]}}], stmt => 'UPDATE test SET a = ?, b = to_date(?, \'MM/DD/YY\') WHERE ( a BETWEEN ? AND ? )', stmt_q => 'UPDATE `test` SET `a` = ?, `b` = to_date(?, \'MM/DD/YY\') WHERE ( `a` BETWEEN ? AND ? )', bind => [[a => '1'], [dummy => '02/02/02'], [a => '1'], [a => '2']], }, { func => 'select', new => {bindtype => 'columns'}, args => ['test', '*', { a => \["= to_date(?, 'MM/DD/YY')", [dummy => '02/02/02']]}], stmt => q{SELECT * FROM test WHERE ( a = to_date(?, 'MM/DD/YY') )}, stmt_q => q{SELECT * FROM `test` WHERE ( `a` = to_date(?, 'MM/DD/YY') )}, bind => [[dummy => '02/02/02']], }, { func => 'select', new => {bindtype => 'columns'}, args => ['test', '*', { a => {'<' => \["to_date(?, 'MM/DD/YY')", [dummy => '02/02/02']]}, b => 8 }], stmt => 'SELECT * FROM test WHERE ( a < to_date(?, \'MM/DD/YY\') AND b = ? )', stmt_q => 'SELECT * FROM `test` WHERE ( `a` < to_date(?, \'MM/DD/YY\') AND `b` = ? )', bind => [[dummy => '02/02/02'], [b => 8]], }, { func => 'insert', new => {bindtype => 'columns'}, args => ['test', {a => 1, b => \["to_date(?, 'MM/DD/YY')", '02/02/02']}], throws => qr/bindtype 'columns' selected, you need to pass: \[column_name => bind_value\]/, }, { func => 'update', new => {bindtype => 'columns'}, args => ['test', {a => 1, b => \["to_date(?, 'MM/DD/YY')", '02/02/02']}, {a => {'between', [1,2]}}], throws => qr/bindtype 'columns' selected, you need to pass: \[column_name => bind_value\]/, }, { func => 'select', new => {bindtype => 'columns'}, args => ['test', '*', { a => \["= to_date(?, 'MM/DD/YY')", '02/02/02']}], throws => qr/bindtype 'columns' selected, you need to pass: \[column_name => bind_value\]/, }, { func => 'select', new => {bindtype => 'columns'}, args => ['test', '*', { a => {'<' => \["to_date(?, 'MM/DD/YY')", '02/02/02']}, b => 8 }], throws => qr/bindtype 'columns' selected, you need to pass: \[column_name => bind_value\]/, }, { func => 'select', args => ['test', '*', { foo => { '>=' => [] }} ], throws => qr/\Qoperator '>=' applied on an empty array (field 'foo')/, }, { func => 'select', new => {bindtype => 'columns'}, args => ['test', '*', { a => {-in => \["(SELECT d FROM to_date(?, 'MM/DD/YY') AS d)", [dummy => '02/02/02']]}, b => 8 }], stmt => 'SELECT * FROM test WHERE ( a IN (SELECT d FROM to_date(?, \'MM/DD/YY\') AS d) AND b = ? )', stmt_q => 'SELECT * FROM `test` WHERE ( `a` IN (SELECT d FROM to_date(?, \'MM/DD/YY\') AS d) AND `b` = ? )', bind => [[dummy => '02/02/02'], [b => 8]], }, { func => 'select', new => {bindtype => 'columns'}, args => ['test', '*', { a => {-in => \["(SELECT d FROM to_date(?, 'MM/DD/YY') AS d)", '02/02/02']}, b => 8 }], throws => qr/bindtype 'columns' selected, you need to pass: \[column_name => bind_value\]/, }, { func => 'insert', new => {bindtype => 'columns'}, args => ['test', {a => 1, b => \["to_date(?, 'MM/DD/YY')", [{dummy => 1} => '02/02/02']]}], stmt => 'INSERT INTO test (a, b) VALUES (?, to_date(?, \'MM/DD/YY\'))', stmt_q => 'INSERT INTO `test` (`a`, `b`) VALUES (?, to_date(?, \'MM/DD/YY\'))', bind => [[a => '1'], [{dummy => 1} => '02/02/02']], }, { func => 'update', new => {bindtype => 'columns'}, args => ['test', {a => 1, b => \["to_date(?, 'MM/DD/YY')", [{dummy => 1} => '02/02/02']], c => { -lower => 'foo' }}, {a => {'between', [1,2]}}], stmt => "UPDATE test SET a = ?, b = to_date(?, 'MM/DD/YY'), c = LOWER ? WHERE ( a BETWEEN ? AND ? )", stmt_q => "UPDATE `test` SET `a` = ?, `b` = to_date(?, 'MM/DD/YY'), `c` = LOWER ? WHERE ( `a` BETWEEN ? AND ? )", bind => [[a => '1'], [{dummy => 1} => '02/02/02'], [c => 'foo'], [a => '1'], [a => '2']], }, { func => 'select', new => {bindtype => 'columns'}, args => ['test', '*', { a => \["= to_date(?, 'MM/DD/YY')", [{dummy => 1} => '02/02/02']]}], stmt => q{SELECT * FROM test WHERE ( a = to_date(?, 'MM/DD/YY') )}, stmt_q => q{SELECT * FROM `test` WHERE ( `a` = to_date(?, 'MM/DD/YY') )}, bind => [[{dummy => 1} => '02/02/02']], }, { func => 'select', new => {bindtype => 'columns'}, args => ['test', '*', { a => {'<' => \["to_date(?, 'MM/DD/YY')", [{dummy => 1} => '02/02/02']]}, b => 8 }], stmt => 'SELECT * FROM test WHERE ( a < to_date(?, \'MM/DD/YY\') AND b = ? )', stmt_q => 'SELECT * FROM `test` WHERE ( `a` < to_date(?, \'MM/DD/YY\') AND `b` = ? )', bind => [[{dummy => 1} => '02/02/02'], [b => 8]], }, { func => 'select', new => {bindtype => 'columns'}, args => ['test', '*', { -or => [ -and => [ a => 'a', b => 'b' ], -and => [ c => 'c', d => 'd' ] ] }], stmt => 'SELECT * FROM test WHERE ( a = ? AND b = ? ) OR ( c = ? AND d = ? )', stmt_q => 'SELECT * FROM `test` WHERE ( `a` = ? AND `b` = ? ) OR ( `c` = ? AND `d` = ? )', bind => [[a => 'a'], [b => 'b'], [ c => 'c'],[ d => 'd']], }, { func => 'select', new => {bindtype => 'columns'}, args => ['test', '*', [ { a => 1, b => 1}, [ a => 2, b => 2] ] ], stmt => 'SELECT * FROM test WHERE ( a = ? AND b = ? ) OR ( a = ? OR b = ? )', stmt_q => 'SELECT * FROM `test` WHERE ( `a` = ? AND `b` = ? ) OR ( `a` = ? OR `b` = ? )', bind => [[a => 1], [b => 1], [ a => 2], [ b => 2]], }, { func => 'select', new => {bindtype => 'columns'}, args => ['test', '*', [ [ a => 1, b => 1], { a => 2, b => 2 } ] ], stmt => 'SELECT * FROM test WHERE ( a = ? OR b = ? ) OR ( a = ? AND b = ? )', stmt_q => 'SELECT * FROM `test` WHERE ( `a` = ? OR `b` = ? ) OR ( `a` = ? AND `b` = ? )', bind => [[a => 1], [b => 1], [ a => 2], [ b => 2]], }, { func => 'insert', args => ['test', [qw/1 2 3 4 5/], { returning => 'id' }], stmt => 'INSERT INTO test VALUES (?, ?, ?, ?, ?) RETURNING id', stmt_q => 'INSERT INTO `test` VALUES (?, ?, ?, ?, ?) RETURNING `id`', bind => [qw/1 2 3 4 5/], }, { func => 'insert', args => ['test', [qw/1 2 3 4 5/], { returning => 'id, foo, bar' }], stmt => 'INSERT INTO test VALUES (?, ?, ?, ?, ?) RETURNING id, foo, bar', stmt_q => 'INSERT INTO `test` VALUES (?, ?, ?, ?, ?) RETURNING `id, foo, bar`', bind => [qw/1 2 3 4 5/], }, { func => 'insert', args => ['test', [qw/1 2 3 4 5/], { returning => [qw(id foo bar) ] }], stmt => 'INSERT INTO test VALUES (?, ?, ?, ?, ?) RETURNING id, foo, bar', stmt_q => 'INSERT INTO `test` VALUES (?, ?, ?, ?, ?) RETURNING `id`, `foo`, `bar`', bind => [qw/1 2 3 4 5/], }, { func => 'insert', args => ['test', [qw/1 2 3 4 5/], { returning => \'id, foo, bar' }], stmt => 'INSERT INTO test VALUES (?, ?, ?, ?, ?) RETURNING id, foo, bar', stmt_q => 'INSERT INTO `test` VALUES (?, ?, ?, ?, ?) RETURNING id, foo, bar', bind => [qw/1 2 3 4 5/], }, { func => 'insert', args => ['test', [qw/1 2 3 4 5/], { returning => \'id' }], stmt => 'INSERT INTO test VALUES (?, ?, ?, ?, ?) RETURNING id', stmt_q => 'INSERT INTO `test` VALUES (?, ?, ?, ?, ?) RETURNING id', bind => [qw/1 2 3 4 5/], }, { func => 'select', new => {bindtype => 'columns'}, args => ['test', '*', [ Y => { '=' => { -max => { -LENGTH => { -min => 'x' } } } } ] ], stmt => 'SELECT * FROM test WHERE ( Y = ( MAX( LENGTH( MIN ? ) ) ) )', stmt_q => 'SELECT * FROM `test` WHERE ( `Y` = ( MAX( LENGTH( MIN ? ) ) ) )', bind => [[Y => 'x']], }, { func => 'select', args => ['test', '*', { a => { '=' => undef }, b => { -is => undef }, c => { -like => undef } }], stmt => 'SELECT * FROM test WHERE ( a IS NULL AND b IS NULL AND c IS NULL )', stmt_q => 'SELECT * FROM `test` WHERE ( `a` IS NULL AND `b` IS NULL AND `c` IS NULL )', bind => [], warns => qr/\QSupplying an undefined argument to 'LIKE' is deprecated/, }, { func => 'select', args => ['test', '*', { a => { '!=' => undef }, b => { -is_not => undef }, c => { -not_like => undef } }], stmt => 'SELECT * FROM test WHERE ( a IS NOT NULL AND b IS NOT NULL AND c IS NOT NULL )', stmt_q => 'SELECT * FROM `test` WHERE ( `a` IS NOT NULL AND `b` IS NOT NULL AND `c` IS NOT NULL )', bind => [], warns => qr/\QSupplying an undefined argument to 'NOT LIKE' is deprecated/, }, { func => 'select', args => ['test', '*', { a => { IS => undef }, b => { LIKE => undef } }], stmt => 'SELECT * FROM test WHERE ( a IS NULL AND b IS NULL )', stmt_q => 'SELECT * FROM `test` WHERE ( `a` IS NULL AND `b` IS NULL )', bind => [], warns => qr/\QSupplying an undefined argument to 'LIKE' is deprecated/, }, { func => 'select', args => ['test', '*', { a => { 'IS NOT' => undef }, b => { 'NOT LIKE' => undef } }], stmt => 'SELECT * FROM test WHERE ( a IS NOT NULL AND b IS NOT NULL )', stmt_q => 'SELECT * FROM `test` WHERE ( `a` IS NOT NULL AND `b` IS NOT NULL )', bind => [], warns => qr/\QSupplying an undefined argument to 'NOT LIKE' is deprecated/, }, { func => 'select', args => ['`test``table`', ['`test``column`']], stmt => 'SELECT `test``column` FROM `test``table`', stmt_q => 'SELECT ```test````column``` FROM ```test````table```', bind => [], }, { func => 'select', args => ['`test\\`table`', ['`test`\\column`']], stmt => 'SELECT `test`\column` FROM `test\`table`', stmt_q => 'SELECT `\`test\`\\\\column\`` FROM `\`test\\\\\`table\``', esc => '\\', bind => [], }, ); # check is( not) => undef for my $op ( qw(not is is_not), 'is not' ) { (my $sop = uc $op) =~ s/_/ /gi; $sop = 'IS NOT' if $sop eq 'NOT'; for my $uc (0, 1) { for my $prefix ('', '-') { push @tests, { func => 'where', args => [{ a => { ($prefix . ($uc ? uc $op : lc $op) ) => undef } }], stmt => "WHERE a $sop NULL", stmt_q => "WHERE `a` $sop NULL", bind => [], }; } } } # check single-element inequality ops for no warnings for my $op ( qw(!= <>) ) { for my $val (undef, 42) { push @tests, { func => 'where', args => [ { x => { "$_$op" => [ $val ] } } ], stmt => "WHERE x " . ($val ? "$op ?" : 'IS NOT NULL'), stmt_q => "WHERE `x` " . ($val ? "$op ?" : 'IS NOT NULL'), bind => [ $val || () ], } for ('', '-'); # with and without - } } # check single-element not-like ops for no warnings, and NULL exception # (the last two "is not X" are a weird syntax, but mebbe a dialect...) for my $op (qw(not_like not_rlike), 'not like', 'not rlike', 'is not like','is not rlike') { (my $sop = uc $op) =~ s/_/ /gi; for my $val (undef, 42) { push @tests, { func => 'where', args => [ { x => { "$_$op" => [ $val ] } } ], $val ? ( stmt => "WHERE x $sop ?", stmt_q => "WHERE `x` $sop ?", bind => [ $val ], ) : ( stmt => "WHERE x IS NOT NULL", stmt_q => "WHERE `x` IS NOT NULL", bind => [], warns => qr/\QSupplying an undefined argument to '$sop' is deprecated/, ), } for ('', '-'); # with and without - } } # check all multi-element inequality/not-like ops for warnings for my $op ( qw(!= <> not_like not_rlike), 'not like', 'not rlike', 'is not like','is not rlike') { (my $sop = uc $op) =~ s/_/ /gi; push @tests, { func => 'where', args => [ { x => { "$_$op" => [ 42, 69 ] } } ], stmt => "WHERE x $sop ? OR x $sop ?", stmt_q => "WHERE `x` $sop ? OR `x` $sop ?", bind => [ 42, 69 ], warns => qr/\QA multi-element arrayref as an argument to the inequality op '$sop' is technically equivalent to an always-true 1=1/, } for ('', '-'); # with and without - } # check all like/not-like ops for empty-arrayref warnings for my $op ( qw(like rlike not_like not_rlike), 'not like', 'not rlike', 'is like', 'is not like', 'is rlike', 'is not rlike') { (my $sop = uc $op) =~ s/_/ /gi; push @tests, { func => 'where', args => [ { x => { "$_$op" => [] } } ], stmt => ( $sop =~ /NOT/ ? "WHERE 1=1" : "WHERE 0=1" ), stmt_q => ( $sop =~ /NOT/ ? "WHERE 1=1" : "WHERE 0=1" ), bind => [], warns => qr/\QSupplying an empty arrayref to '$sop' is deprecated/, } for ('', '-'); # with and without - } # check emtpty-lhs in a hashpair and arraypair for my $lhs (undef, '') { no warnings 'uninitialized'; ## ## hard exceptions - never worked for my $where_arg ( ( map { $_, { @$_ } } [ $lhs => "foo" ], [ $lhs => { "=" => "bozz" } ], [ $lhs => { "=" => \"bozz" } ], [ $lhs => { -max => \"bizz" } ], ), [ -and => { $lhs => "baz" }, bizz => "buzz" ], [ foo => "bar", { $lhs => "baz" }, bizz => "buzz" ], { foo => "bar", -or => { $lhs => "baz" } }, # the hashref forms of these work sadly - check for warnings below { foo => "bar", -and => [ $lhs => \"baz" ], bizz => "buzz" }, { foo => "bar", -or => [ $lhs => \"baz" ], bizz => "buzz" }, [ foo => "bar", [ $lhs => \"baz" ], bizz => "buzz" ], [ foo => "bar", $lhs => \"baz", bizz => "buzz" ], [ foo => "bar", $lhs => \["baz"], bizz => "buzz" ], [ $lhs => \"baz" ], [ $lhs => \["baz"] ], # except for this one, that is automagically arrayified { foo => "bar", -or => { $lhs => \"baz" }, bizz => "buzz" }, ) { push @tests, { func => 'where', args => [ $where_arg ], throws => qr/\QSupplying an empty left hand side argument is not supported/, }; } ## ## deprecations - sorta worked, likely abused by folks for my $where_arg ( # the arrayref forms of this never worked and throw above { foo => "bar", -and => { $lhs => \"baz" }, bizz => "buzz" }, { foo => "bar", $lhs => \"baz", bizz => "buzz" }, { foo => "bar", $lhs => \["baz"], bizz => "buzz" }, ) { push @tests, { func => 'where', args => [ $where_arg ], stmt => 'WHERE baz AND bizz = ? AND foo = ?', stmt_q => 'WHERE baz AND `bizz` = ? AND `foo` = ?', bind => [qw( buzz bar )], warns => qr/\QHash-pairs consisting of an empty string with a literal are deprecated/, }; } for my $where_arg ( { $lhs => \"baz" }, { $lhs => \["baz"] }, ) { push @tests, { func => 'where', args => [ $where_arg ], stmt => 'WHERE baz', stmt_q => 'WHERE baz', bind => [], warns => qr/\QHash-pairs consisting of an empty string with a literal are deprecated/, } } } # check false lhs, silly but possible { for my $where_arg ( [ { 0 => "baz" }, bizz => "buzz", foo => "bar" ], [ -or => { foo => "bar", -or => { 0 => "baz" }, bizz => "buzz" } ], ) { push @tests, { func => 'where', args => [ $where_arg ], stmt => 'WHERE 0 = ? OR bizz = ? OR foo = ?', stmt_q => 'WHERE `0` = ? OR `bizz` = ? OR `foo` = ?', bind => [qw( baz buzz bar )], }; } for my $where_arg ( { foo => "bar", -and => [ 0 => \"= baz" ], bizz => "buzz" }, { foo => "bar", -or => [ 0 => \"= baz" ], bizz => "buzz" }, { foo => "bar", -and => { 0 => \"= baz" }, bizz => "buzz" }, { foo => "bar", -or => { 0 => \"= baz" }, bizz => "buzz" }, { foo => "bar", 0 => \"= baz", bizz => "buzz" }, { foo => "bar", 0 => \["= baz"], bizz => "buzz" }, ) { push @tests, { func => 'where', args => [ $where_arg ], stmt => 'WHERE 0 = baz AND bizz = ? AND foo = ?', stmt_q => 'WHERE `0` = baz AND `bizz` = ? AND `foo` = ?', bind => [qw( buzz bar )], }; } for my $where_arg ( [ -and => [ 0 => \"= baz" ], bizz => "buzz", foo => "bar" ], [ -or => [ 0 => \"= baz" ], bizz => "buzz", foo => "bar" ], [ 0 => \"= baz", bizz => "buzz", foo => "bar" ], [ 0 => \["= baz"], bizz => "buzz", foo => "bar" ], ) { push @tests, { func => 'where', args => [ $where_arg ], stmt => 'WHERE 0 = baz OR bizz = ? OR foo = ?', stmt_q => 'WHERE `0` = baz OR `bizz` = ? OR `foo` = ?', bind => [qw( buzz bar )], }; } } for my $t (@tests) { my $new = $t->{new} || {}; for my $quoted (0, 1) { my $maker = SQL::Abstract->new( %$new, ($quoted ? ( quote_char => '`', name_sep => '.', ( $t->{esc} ? ( escape_char => $t->{esc}, ) : ()) ) : ()) ); my($stmt, @bind); my $cref = sub { my $op = $t->{func}; ($stmt, @bind) = $maker->$op (@ { $t->{args} } ); }; if (my $e = $t->{throws}) { throws_ok( sub { $cref->() }, $e, ) || diag dumper ({ args => $t->{args}, result => $stmt }); } else { warnings_like( sub { $cref->() }, $t->{warns} || [], ) || diag dumper ({ args => $t->{args}, result => $stmt }); is_same_sql_bind( $stmt, \@bind, $quoted ? $t->{stmt_q}: $t->{stmt}, $t->{bind} ); } } } done_testing; SQL-Abstract-1.81/t/23_is_X_value.t0000644000175000017500000001352212411144122016160 0ustar rabbitrabbituse warnings; use strict; use Test::More; use Test::Exception; use Scalar::Util 'refaddr'; use Storable 'nfreeze'; BEGIN { $ENV{SQLA_ISVALUE_IGNORE_AUTOGENERATED_STRINGIFICATION} = 0 } use SQL::Abstract qw(is_plain_value is_literal_value); # fallback setting is inheriting starting p5 50853fa9 (run up to 5.17.0) use constant OVERLOAD_FALLBACK_INHERITS => ( ($] < 5.017) ? 0 : 1 ); use constant STRINGIFIER_CAN_RETURN_IVS => ( ($] < 5.008) ? 0 : 1 ); { package # hideee SQLATest::SillyBool; use overload # *DELIBERATELY* unspecified #fallback => 1, bool => sub { ${$_[0]} }, ; package # hideee SQLATest::SillyBool::Subclass; our @ISA = 'SQLATest::SillyBool'; } { package # hideee SQLATest::SillyInt; use overload # *DELIBERATELY* unspecified #fallback => 1, '0+' => sub { ${$_[0]} }, ; package # hideee SQLATest::SillyInt::Subclass; our @ISA = 'SQLATest::SillyInt'; } { package # hideee SQLATest::SillierInt; use overload fallback => 0, ; package # hideee SQLATest::SillierInt::Subclass; use overload '0+' => sub { ${$_[0]} }, '+' => sub { ${$_[0]} + $_[1] }, ; our @ISA = 'SQLATest::SillierInt'; } { package # hideee SQLATest::AnalInt; use overload fallback => 0, '0+' => sub { ${$_[0]} }, ; package # hideee SQLATest::AnalInt::Subclass; use overload '0+' => sub { ${$_[0]} }, ; our @ISA = 'SQLATest::AnalInt'; } { package # hidee SQLATest::ReasonableInt; # make it match JSON::PP::Boolean use overload '0+' => sub { ${$_[0]} }, '++' => sub { $_[0] = ${$_[0]} + 1 }, '--' => sub { $_[0] = ${$_[0]} - 1 }, fallback => 1, ; package # hideee SQLATest::ReasonableInt::Subclass; our @ISA = 'SQLATest::ReasonableInt'; } { package # hidee SQLATest::ReasonableString; # somewhat like DateTime use overload 'fallback' => 1, '""' => sub { "${$_[0]}" }, '-' => sub { ${$_[0]} - $_[1] }, '+' => sub { ${$_[0]} + $_[1] }, ; package # hideee SQLATest::ReasonableString::Subclass; our @ISA = 'SQLATest::ReasonableString'; } for my $case ( { class => 'SQLATest::SillyBool', can_math => 0, should_str => 1 }, { class => 'SQLATest::SillyBool::Subclass', can_math => 0, should_str => 1 }, { class => 'SQLATest::SillyInt', can_math => 0, should_str => 1 }, { class => 'SQLATest::SillyInt::Subclass', can_math => 0, should_str => 1 }, { class => 'SQLATest::SillierInt', can_math => 0, should_str => 0 }, { class => 'SQLATest::SillierInt::Subclass',can_math => 1, should_str => (OVERLOAD_FALLBACK_INHERITS ? 0 : 1) }, { class => 'SQLATest::AnalInt', can_math => 0, should_str => 0 }, { class => 'SQLATest::AnalInt::Subclass', can_math => 0, should_str => (OVERLOAD_FALLBACK_INHERITS ? 0 : 1) }, { class => 'SQLATest::ReasonableInt', can_math => 1, should_str => 1 }, { class => 'SQLATest::ReasonableInt::Subclass', can_math => 1, should_str => 1 }, { class => 'SQLATest::ReasonableString', can_math => 1, should_str => 1 }, { class => 'SQLATest::ReasonableString::Subclass',can_math => 1, should_str => 1 }, ) { my $num = bless( \do { my $foo = 42 }, $case->{class} ); my $can_str = eval { "$num" eq 42 } || 0; ok ( !($can_str xor $case->{should_str}), "should_str setting for $case->{class} matches perl behavior", ) || diag explain { %$case, can_str => $can_str }; my $can_math = eval { ($num + 1) == 43 } ? 1 : 0; ok ( !($can_math xor $case->{can_math}), "can_math setting for $case->{class} matches perl behavior", ) || diag explain { %$case, actual_can_math => $can_math }; my $can_cmp = eval { my $dum = ($num eq "nope"); 1 } || 0; for (1,2) { if ($can_str) { ok $num, 'bool ctx works'; if (STRINGIFIER_CAN_RETURN_IVS and $can_cmp) { is_deeply( is_plain_value $num, \$num, "stringification detected on $case->{class}", ) || diag explain $case; } else { # is_deeply does not do nummify/stringify cmps properly # but we can always compare the ice ok( ( nfreeze( is_plain_value $num ) eq nfreeze( \$num ) ), "stringification without cmp capability detected on $case->{class}" ) || diag explain $case; } is ( refaddr( ${is_plain_value($num)} ), refaddr $num, "Same reference (blessed object) returned", ); } else { is( is_plain_value($num), undef, "non-stringifiable $case->{class} object detected" ) || diag explain $case; } if ($case->{can_math}) { is ($num+1, 43); } } } lives_ok { my $num = bless( \do { my $foo = 23 }, 'SQLATest::ReasonableInt' ); cmp_ok(++$num, '==', 24, 'test overloaded object compares correctly'); cmp_ok(--$num, 'eq', 23, 'test overloaded object compares correctly'); is_deeply( is_plain_value $num, \23, 'fallback stringification detected' ); cmp_ok(--$num, 'eq', 22, 'test overloaded object compares correctly'); cmp_ok(++$num, '==', 23, 'test overloaded object compares correctly'); } 'overload testing lives'; is_deeply is_plain_value { -value => [] }, \[], '-value recognized' ; for ([], {}, \'') { is is_plain_value $_, undef, 'nonvalues correctly recognized' ; } for (undef, { -value => undef }) { is_deeply is_plain_value $_, \undef, 'NULL -value recognized' ; } is_deeply is_literal_value \'sql', [ 'sql' ], 'literal correctly recognized and unpacked' ; is_deeply is_literal_value \[ 'sql', 'bind1', [ {} => 'bind2' ] ], [ 'sql', 'bind1', [ {} => 'bind2' ] ], 'literal with binds correctly recognized and unpacked' ; for ([], {}, \'', undef) { is is_literal_value { -ident => $_ }, undef, 'illegal -ident does not trip up detection' ; } done_testing; SQL-Abstract-1.81/t/12format_keyword.t0000644000175000017500000000101512361730666016771 0ustar rabbitrabbituse strict; use warnings; use Test::More; use SQL::Abstract::Tree; my $sqlat = SQL::Abstract::Tree->new({ colormap => { select => ['s(', ')s'], where => ['w(', ')w'], from => ['f(', ')f'], join => ['j(', ')f'], on => ['o(', ')o'], 'group by' => ['gb(',')gb'], 'order by' => ['ob(',')ob'], }, }); for ( keys %{$sqlat->colormap}) { my ($l, $r) = @{$sqlat->colormap->{$_}}; is($sqlat->format_keyword($_), "$l$_$r", "$_ 'colored' correctly"); } done_testing; SQL-Abstract-1.81/t/07subqueries.t0000644000175000017500000000511312361730666016133 0ustar rabbitrabbituse strict; use warnings; use Test::More; use SQL::Abstract::Test import => ['is_same_sql_bind']; use SQL::Abstract; #### WARNING #### # # -nest has been undocumented on purpose, but is still supported for the # foreseable future. Do not rip out the -nest tests before speaking to # someone on the DBIC mailing list or in irc.perl.org#dbix-class # ################# my $sql = SQL::Abstract->new; my (@tests, $sub_stmt, @sub_bind, $where); #1 ($sub_stmt, @sub_bind) = ("SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?", 100, "foo%"); $where = { foo => 1234, bar => \["IN ($sub_stmt)" => @sub_bind], }; push @tests, { where => $where, stmt => " WHERE ( bar IN (SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?) AND foo = ? )", bind => [100, "foo%", 1234], }; #2 ($sub_stmt, @sub_bind) = $sql->select("t1", "c1", {c2 => {"<" => 100}, c3 => {-like => "foo%"}}); $where = { foo => 1234, bar => \["> ALL ($sub_stmt)" => @sub_bind], }; push @tests, { where => $where, stmt => " WHERE ( bar > ALL (SELECT c1 FROM t1 WHERE (( c2 < ? AND c3 LIKE ? )) ) AND foo = ? )", bind => [100, "foo%", 1234], }; #3 ($sub_stmt, @sub_bind) = $sql->select("t1", "*", {c1 => 1, c2 => \"> t0.c0"}); $where = { foo => 1234, -nest => \["EXISTS ($sub_stmt)" => @sub_bind], }; push @tests, { where => $where, stmt => " WHERE ( EXISTS (SELECT * FROM t1 WHERE ( c1 = ? AND c2 > t0.c0 )) AND foo = ? )", bind => [1, 1234], }; #4 $where = { -nest => \["MATCH (col1, col2) AGAINST (?)" => "apples"], }; push @tests, { where => $where, stmt => " WHERE ( MATCH (col1, col2) AGAINST (?) )", bind => ["apples"], }; #5 ($sub_stmt, @sub_bind) = $sql->where({age => [{"<" => 10}, {">" => 20}]}); $sub_stmt =~ s/^ where //i; # don't want "WHERE" in the subclause $where = { lname => {-like => '%son%'}, -nest => \["NOT ( $sub_stmt )" => @sub_bind], }; push @tests, { where => $where, stmt => " WHERE ( NOT ( ( ( ( age < ? ) OR ( age > ? ) ) ) ) AND lname LIKE ? )", bind => [10, 20, '%son%'], }; #6 ($sub_stmt, @sub_bind) = ("SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?", 100, "foo%"); $where = { foo => 1234, bar => { -in => \[$sub_stmt => @sub_bind] }, }; push @tests, { where => $where, stmt => " WHERE ( bar IN (SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?) AND foo = ? )", bind => [100, "foo%", 1234], }; for (@tests) { my($stmt, @bind) = $sql->where($_->{where}, $_->{order}); is_same_sql_bind($stmt, \@bind, $_->{stmt}, $_->{bind}); } done_testing; SQL-Abstract-1.81/t/00new.t0000644000175000017500000000712212361730666014530 0ustar rabbitrabbituse strict; use warnings; use Test::More; use Test::Warn; use SQL::Abstract::Test import => ['is_same_sql']; use SQL::Abstract; my @handle_tests = ( #1 { args => {logic => 'OR'}, stmt => 'SELECT * FROM test WHERE ( a = ? AND b = ? )' }, #2 { args => {}, stmt => 'SELECT * FROM test WHERE ( a = ? AND b = ? )' }, #3 { args => {case => "upper"}, stmt => 'SELECT * FROM test WHERE ( a = ? AND b = ? )' }, #4 { args => {case => "upper", cmp => "="}, stmt => 'SELECT * FROM test WHERE ( a = ? AND b = ? )' }, #5 { args => {cmp => "=", logic => 'or'}, stmt => 'SELECT * FROM test WHERE ( a = ? AND b = ? )' }, #6 { args => {cmp => "like"}, stmt => 'SELECT * FROM test WHERE ( a LIKE ? AND b LIKE ? )' }, #7 { args => {logic => "or", cmp => "like"}, stmt => 'SELECT * FROM test WHERE ( a LIKE ? AND b LIKE ? )' }, #8 { args => {case => "lower"}, stmt => 'select * from test where ( a = ? and b = ? )' }, #9 { args => {case => "lower", cmp => "="}, stmt => 'select * from test where ( a = ? and b = ? )' }, #10 { args => {case => "lower", cmp => "like"}, stmt => 'select * from test where ( a like ? and b like ? )' }, #11 { args => {case => "lower", convert => "lower", cmp => "like"}, stmt => 'select * from test where ( lower(a) like lower(?) and lower(b) like lower(?) )' }, #12 { args => {convert => "Round"}, stmt => 'SELECT * FROM test WHERE ( ROUND(a) = ROUND(?) AND ROUND(b) = ROUND(?) )', }, #13 { args => {convert => "lower"}, stmt => 'SELECT * FROM test WHERE ( ( LOWER(ticket) = LOWER(?) ) OR ( LOWER(hostname) = LOWER(?) ) OR ( LOWER(taco) = LOWER(?) ) OR ( LOWER(salami) = LOWER(?) ) )', where => [ { ticket => 11 }, { hostname => 11 }, { taco => 'salad' }, { salami => 'punch' } ], }, #14 { args => {convert => "upper"}, stmt => 'SELECT * FROM test WHERE ( ( UPPER(hostname) IN ( UPPER(?), UPPER(?), UPPER(?), UPPER(?) ) AND ( ( UPPER(ticket) = UPPER(?) ) OR ( UPPER(ticket) = UPPER(?) ) OR ( UPPER(ticket) = UPPER(?) ) ) ) OR ( UPPER(tack) BETWEEN UPPER(?) AND UPPER(?) ) OR ( ( ( UPPER(a) = UPPER(?) ) OR ( UPPER(a) = UPPER(?) ) OR ( UPPER(a) = UPPER(?) ) ) AND ( ( UPPER(e) != UPPER(?) ) OR ( UPPER(e) != UPPER(?) ) ) AND UPPER(q) NOT IN ( UPPER(?), UPPER(?), UPPER(?), UPPER(?), UPPER(?), UPPER(?), UPPER(?) ) ) )', where => [ { ticket => [11, 12, 13], hostname => { in => ['ntf', 'avd', 'bvd', '123'] } }, { tack => { between => [qw/tick tock/] } }, { a => [qw/b c d/], e => { '!=', [qw(f g)] }, q => { 'not in', [14..20] } } ], warns => qr/\QA multi-element arrayref as an argument to the inequality op '!=' is technically equivalent to an always-true 1=1/, }, ); for (@handle_tests) { my $sqla = SQL::Abstract->new($_->{args}); my $stmt; warnings_exist { $stmt = $sqla->select( 'test', '*', $_->{where} || { a => 4, b => 0} ); } $_->{warns} || []; is_same_sql($stmt, $_->{stmt}); } done_testing; SQL-Abstract-1.81/t/09refkind.t0000644000175000017500000000167512361730666015401 0ustar rabbitrabbituse strict; use warnings; use Test::More; use SQL::Abstract; my $obj = bless {}, "Foo::Bar"; is(SQL::Abstract->_refkind(undef), 'UNDEF', 'UNDEF'); is(SQL::Abstract->_refkind({}), 'HASHREF', 'HASHREF'); is(SQL::Abstract->_refkind([]), 'ARRAYREF', 'ARRAYREF'); is(SQL::Abstract->_refkind(\{}), 'HASHREFREF', 'HASHREFREF'); is(SQL::Abstract->_refkind(\[]), 'ARRAYREFREF', 'ARRAYREFREF'); is(SQL::Abstract->_refkind(\\{}), 'HASHREFREFREF', 'HASHREFREFREF'); is(SQL::Abstract->_refkind(\\[]), 'ARRAYREFREFREF', 'ARRAYREFREFREF'); is(SQL::Abstract->_refkind("foo"), 'SCALAR', 'SCALAR'); is(SQL::Abstract->_refkind(\"foo"), 'SCALARREF', 'SCALARREF'); is(SQL::Abstract->_refkind(\\"foo"), 'SCALARREFREF', 'SCALARREFREF'); # objects are treated like scalars is(SQL::Abstract->_refkind($obj), 'SCALAR', 'SCALAR'); is(SQL::Abstract->_refkind(\$obj), 'SCALARREF', 'SCALARREF'); is(SQL::Abstract->_refkind(\\$obj), 'SCALARREFREF', 'SCALARREFREF'); done_testing; SQL-Abstract-1.81/t/14roundtrippin.t0000644000175000017500000001045212361730666016501 0ustar rabbitrabbituse warnings; use strict; use Test::More; use Test::Exception; use SQL::Abstract::Test import => [qw(is_same_sql dumper)]; use SQL::Abstract::Tree; my $sqlat = SQL::Abstract::Tree->new; my @sql = ( "INSERT INTO artist DEFAULT VALUES", "INSERT INTO artist VALUES ()", "SELECT a, b, c FROM foo WHERE foo.a = 1 and foo.b LIKE 'station'", "SELECT COUNT( * ) FROM foo", "SELECT COUNT( * ), SUM( blah ) FROM foo", "SELECT * FROM (SELECT * FROM foobar) WHERE foo.a = 1 and foo.b LIKE 'station'", "SELECT * FROM lolz WHERE ( foo.a = 1 ) and foo.b LIKE 'station'", "SELECT [screen].[id], [screen].[name], [screen].[section_id], [screen].[xtype] FROM [users_roles] [me] JOIN [roles] [role] ON [role].[id] = [me].[role_id] JOIN [roles_permissions] [role_permissions] ON [role_permissions].[role_id] = [role].[id] JOIN [permissions] [permission] ON [permission].[id] = [role_permissions].[permission_id] JOIN [permissionscreens] [permission_screens] ON [permission_screens].[permission_id] = [permission].[id] JOIN [screens] [screen] ON [screen].[id] = [permission_screens].[screen_id] WHERE ( [me].[user_id] = ? ) GROUP BY [screen].[id], [screen].[name], [screen].[section_id], [screen].[xtype]", "SELECT * FROM foo WHERE NOT EXISTS (SELECT bar FROM baz)", "SELECT * FROM (SELECT SUM (CASE WHEN me.artist = 'foo' THEN 1 ELSE 0 END AS artist_sum) FROM foobar) WHERE foo.a = 1 and foo.b LIKE 'station'", "SELECT * FROM (SELECT SUM (CASE WHEN GETUTCDATE() > DATEADD(second, 4 * 60, last_checkin) THEN 1 ELSE 0 END) FROM foobar) WHERE foo.a = 1 and foo.b LIKE 'station'", "SELECT COUNT( * ) FROM foo me JOIN bar rel_bar ON rel_bar.id_bar = me.fk_bar WHERE NOT EXISTS (SELECT inner_baz.id_baz FROM baz inner_baz WHERE ( ( inner_baz.fk_a != ? AND ( fk_bar = me.fk_bar AND name = me.name ) ) ) )", "SELECT foo AS bar FROM baz ORDER BY x + ? DESC, oomph, y - ? DESC, unf, baz.g / ? ASC, buzz * 0 DESC, foo DESC, ickk ASC", "SELECT inner_forum_roles.forum_id FROM forum_roles AS inner_forum_roles LEFT JOIN user_roles AS inner_user_roles USING(user_role_type_id) WHERE inner_user_roles.user_id = users__row.user_id", "SELECT * FROM foo WHERE foo.a @@ to_tsquery('word')", "SELECT * FROM foo ORDER BY name + ?, [me].[id]", "SELECT foo AS bar FROM baz ORDER BY x + ? DESC, baz.g", "SELECT [me].[id], ROW_NUMBER() OVER (ORDER BY (SELECT 1)) AS [rno__row__index] FROM ( SELECT [me].[id] FROM [LogParents] [me]) [me]", # deliberate batshit insanity "SELECT foo FROM bar WHERE > 12", ); # FIXME FIXME FIXME # The formatter/unparser accumulated a ton of technical debt, # and I don't have time to fix it all :( Some of the problems: # - format() does an implicit parenthesis unroll for prettyness # which makes it hard to do exact comparisons # - there is no space preservation framework (also makes comparisons # problematic) # - there is no operator case preservation framework either # # So what we do instead is resort to some monkey patching and # lowercasing and stuff to get something we can compare to the # original SQL string # Ugly but somewhat effective for my $orig (@sql) { my $plain_formatted = $sqlat->format($orig); is_same_sql( $plain_formatted, $orig, 'Formatted string is_same_sql()-matched' ); my $ast = $sqlat->parse($orig); my $reassembled = do { no warnings 'redefine'; local *SQL::Abstract::Tree::_parenthesis_unroll = sub {}; $sqlat->unparse($ast); }; # deal with whitespace around parenthesis readjustment $_ =~ s/ \s* ( [ \(\) ] ) \s* /$1/gx for ($orig, $reassembled); is ( lc($reassembled), lc($orig), sprintf( 'roundtrip works (%s...)', substr $orig, 0, 20 ) ) or do { my ($ast1, $ast2) = map { dumper( $sqlat->parse($_) ) } ( $orig, $reassembled ); note "ast1: $ast1"; note "ast2: $ast2"; }; } # this is invalid SQL, we are just checking that the parser # does not inadvertently make it right my $sql = 'SELECT * FROM foo WHERE x IN ( ( 1 ) )'; is( $sqlat->unparse($sqlat->parse($sql)), $sql, 'Multi-parens around IN survive', ); lives_ok { $sqlat->unparse( $sqlat->parse( <<'EOS' ) ) } 'Able to parse/unparse grossly malformed sql'; SELECT ( SELECT *, * FROM EXISTS bar JOIN ON a = b NOT WHERE c !!= d ), NOT x, ( SELECT * FROM bar WHERE NOT NOT EXISTS (SELECT 1) ), WHERE NOT NOT 1 AND OR foo IN (1,2,,,3,,,), GROUP BY bar EOS done_testing; SQL-Abstract-1.81/t/13whitespace_keyword.t0000644000175000017500000000126112254322025017624 0ustar rabbitrabbituse strict; use warnings; use Test::More; use SQL::Abstract::Tree; my $sqlat = SQL::Abstract::Tree->new({ newline => "\n", indent_string => " ", indent_amount => 1, indentmap => { select => 0, where => 1, from => 2, join => 3, on => 4, 'group by' => 5, 'order by' => 6, }, }); for ( keys %{$sqlat->indentmap}) { my ($l, $r) = @{$sqlat->pad_keyword($_, 1)}; is($r, '', "right is empty for $_"); is($l, "\n " . ' ' x $sqlat->indentmap->{$_}, "left calculated correctly for $_" ); } is($sqlat->pad_keyword('select', 0)->[0], '', 'Select gets no newline or indent for depth 0'); done_testing; SQL-Abstract-1.81/t/04modifiers.t0000644000175000017500000003146212361730666015730 0ustar rabbitrabbituse strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; use SQL::Abstract::Test import => [qw(is_same_sql_bind diag_where)]; use SQL::Abstract; use Storable 'dclone'; #### WARNING #### # # -nest has been undocumented on purpose, but is still supported for the # foreseable future. Do not rip out the -nest tests before speaking to # someone on the DBIC mailing list or in irc.perl.org#dbix-class # ################# =begin Test -and -or and -nest modifiers, assuming the following: * Modifiers are respected in both hashrefs and arrayrefs (with the obvious limitation of one modifier type per hahsref) * When in condition context i.e. where => { -or => { a = 1 } }, each modifier affects only the immediate element following it. * When in column multi-condition context i.e. where => { x => { '!=', [-and => [qw/1 2 3/]] } }, a modifier affects the OUTER ARRAYREF if and only if it is the first element of said ARRAYREF =cut # no warnings (the -or/-and => { } warning is silly, there is nothing wrong with such usage) my $and_or_args = { and => { stmt => 'WHERE a = ? AND b = ?', bind => [qw/1 2/] }, or => { stmt => 'WHERE a = ? OR b = ?', bind => [qw/1 2/] }, or_and => { stmt => 'WHERE ( foo = ? OR bar = ? ) AND baz = ? ', bind => [qw/1 2 3/] }, or_or => { stmt => 'WHERE foo = ? OR bar = ? OR baz = ?', bind => [qw/1 2 3/] }, and_or => { stmt => 'WHERE ( foo = ? AND bar = ? ) OR baz = ?', bind => [qw/1 2 3/] }, }; my @and_or_tests = ( # basic tests { where => { -and => [a => 1, b => 2] }, %{$and_or_args->{and}}, }, { where => [ -and => [a => 1, b => 2] ], %{$and_or_args->{and}}, }, { where => { -or => [a => 1, b => 2] }, %{$and_or_args->{or}}, }, { where => [ -or => [a => 1, b => 2] ], %{$and_or_args->{or}}, }, { where => { -and => {a => 1, b => 2} }, %{$and_or_args->{and}}, }, { where => [ -and => {a => 1, b => 2} ], %{$and_or_args->{and}}, }, { where => { -or => {a => 1, b => 2} }, %{$and_or_args->{or}}, }, { where => [ -or => {a => 1, b => 2} ], %{$and_or_args->{or}}, }, # test modifiers within hashrefs { where => { -or => [ [ foo => 1, bar => 2 ], baz => 3, ]}, %{$and_or_args->{or_or}}, }, { where => { -and => [ [ foo => 1, bar => 2 ], baz => 3, ]}, %{$and_or_args->{or_and}}, }, # test modifiers within arrayrefs { where => [ -or => [ [ foo => 1, bar => 2 ], baz => 3, ]], %{$and_or_args->{or_or}}, }, { where => [ -and => [ [ foo => 1, bar => 2 ], baz => 3, ]], %{$and_or_args->{or_and}}, }, # test ambiguous modifiers within hashrefs (op extends to to immediate RHS only) { where => { -and => [ -or => [ foo => 1, bar => 2 ], baz => 3, ]}, %{$and_or_args->{or_and}}, }, { where => { -or => [ -and => [ foo => 1, bar => 2 ], baz => 3, ]}, %{$and_or_args->{and_or}}, }, # test ambiguous modifiers within arrayrefs (op extends to to immediate RHS only) { where => [ -and => [ -or => [ foo => 1, bar => 2 ], baz => 3, ]], %{$and_or_args->{or_and}}, }, { where => [ -or => [ -and => [ foo => 1, bar => 2 ], baz => 3 ]], %{$and_or_args->{and_or}}, }, # test column multi-cond in arrayref (useless example) { where => { x => [ -and => (1 .. 3) ] }, stmt => 'WHERE x = ? AND x = ? AND x = ?', bind => [1..3], }, # test column multi-cond in arrayref (more useful) { where => { x => [ -and => {'!=' => 1}, {'!=' => 2}, {'!=' => 3} ] }, stmt => 'WHERE x != ? AND x != ? AND x != ?', bind => [1..3], }, # test column multi-cond in arrayref (even more useful) { where => { x => { '!=' => [ -and => (1 .. 3) ] } }, stmt => 'WHERE x != ? AND x != ? AND x != ?', bind => [1..3], }, # the -or should affect only the inner hashref, as we are not in an outer arrayref { where => { x => { -or => { '!=', 1, '>=', 2 }, -like => 'x%' }}, stmt => 'WHERE x LIKE ? AND ( x != ? OR x >= ? )', bind => [qw/x% 1 2/], }, # the -and should affect the OUTER arrayref, while the internal structures remain intact { where => { x => [ -and => [ 1, 2 ], { -like => 'x%' } ]}, stmt => 'WHERE (x = ? OR x = ?) AND x LIKE ?', bind => [qw/1 2 x%/], }, { where => { -and => [a => 1, b => 2], x => 9, -or => { c => 3, d => 4 } }, stmt => 'WHERE a = ? AND b = ? AND ( c = ? OR d = ? ) AND x = ?', bind => [qw/1 2 3 4 9/], }, { where => { -and => [a => 1, b => 2, k => [11, 12] ], x => 9, -or => { c => 3, d => 4, l => { '=' => [21, 22] } } }, stmt => 'WHERE a = ? AND b = ? AND (k = ? OR k = ?) AND (c = ? OR d = ? OR (l = ? OR l = ?) ) AND x = ?', bind => [qw/1 2 11 12 3 4 21 22 9/], }, { where => { -or => [a => 1, b => 2, k => [11, 12] ], x => 9, -and => { c => 3, d => 4, l => { '=' => [21, 22] } } }, stmt => 'WHERE c = ? AND d = ? AND ( l = ? OR l = ?) AND (a = ? OR b = ? OR k = ? OR k = ?) AND x = ?', bind => [qw/3 4 21 22 1 2 11 12 9/], }, { where => [ -or => [a => 1, b => 2], -or => { c => 3, d => 4}, e => 5, -and => [ f => 6, g => 7], [ h => 8, i => 9, -and => [ k => 10, l => 11] ], { m => 12, n => 13 }], stmt => 'WHERE a = ? OR b = ? OR c = ? OR d = ? OR e = ? OR ( f = ? AND g = ?) OR h = ? OR i = ? OR ( k = ? AND l = ? ) OR (m = ? AND n = ?)', bind => [1 .. 13], }, { # explicit OR logic in arrays should leave everything intact args => { logic => 'or' }, where => { -and => [a => 1, b => 2, k => [11, 12] ], x => 9, -or => { c => 3, d => 4, l => { '=' => [21, 22] } } }, stmt => 'WHERE a = ? AND b = ? AND (k = ? OR k = ?) AND ( c = ? OR d = ? OR l = ? OR l = ? ) AND x = ? ', bind => [qw/1 2 11 12 3 4 21 22 9/], }, { # flip logic in arrays except where excplicitly requested otherwise args => { logic => 'and' }, where => [ -or => [a => 1, b => 2], -or => { c => 3, d => 4}, e => 5, -and => [ f => 6, g => 7], [ h => 8, i => 9, -and => [ k => 10, l => 11] ], { m => 12, n => 13 }], stmt => 'WHERE (a = ? OR b = ?) AND (c = ? OR d = ?) AND e = ? AND f = ? AND g = ? AND h = ? AND i = ? AND k = ? AND l = ? AND m = ? AND n = ?', bind => [1 .. 13], }, # 1st -and is in column mode, thus flips the entire array, whereas the # 2nd one is just a condition modifier { where => [ col => [ -and => {'<' => 123}, {'>' => 456 }, {'!=' => 789} ], -and => [ col2 => [ -or => { -like => 'crap' }, { -like => 'crop' } ], col3 => [ -and => { -like => 'chap' }, { -like => 'chop' } ], ], ], stmt => 'WHERE (col < ? AND col > ? AND col != ?) OR ( ( col2 LIKE ? OR col2 LIKE ? ) AND ( col3 LIKE ? AND col3 LIKE ? ) ) ', bind => [qw/123 456 789 crap crop chap chop/], }, ########## # some corner cases by ldami (some produce useless SQL, just for clarification on 1.5 direction) # { where => { foo => [ -and => [ { -like => 'foo%'}, {'>' => 'moo'} ], { -like => '%bar', '<' => 'baz'}, [ {-like => '%alpha'}, {-like => '%beta'} ], [ {'!=' => 'toto', '=' => 'koko'} ], ] }, stmt => 'WHERE (foo LIKE ? OR foo > ?) AND (foo LIKE ? AND foo < ?) AND (foo LIKE ? OR foo LIKE ?) AND (foo != ? AND foo = ?)', bind => [qw/foo% moo %bar baz %alpha %beta toto koko/], }, { where => [ -and => [a => 1, b => 2], -or => [c => 3, d => 4], e => [-and => {-like => 'foo%'}, {-like => '%bar'} ], ], stmt => 'WHERE (a = ? AND b = ?) OR c = ? OR d = ? OR (e LIKE ? AND e LIKE ?)', bind => [qw/1 2 3 4 foo% %bar/], }, # -or has nothing to flip { where => [-and => [{foo => 1}, {bar => 2}, -or => {baz => 3}] ], stmt => 'WHERE foo = ? AND bar = ? AND baz = ?', bind => [1 .. 3], }, { where => [-and => [{foo => 1}, {bar => 2}, -or => {baz => 3, woz => 4} ] ], stmt => 'WHERE foo = ? AND bar = ? AND (baz = ? OR woz = ?)', bind => [1 .. 4], }, # -and has only 1 following element, thus all still ORed { where => { col => [ -and => [{'<' => 123}, {'>' => 456 }, {'!=' => 789}] ] }, stmt => 'WHERE col < ? OR col > ? OR col != ?', bind => [qw/123 456 789/], }, # flipping array logic affects both column value and condition arrays { args => { logic => 'and' }, where => [ col => [ {'<' => 123}, {'>' => 456 }, {'!=' => 789} ], col2 => 0 ], stmt => 'WHERE col < ? AND col > ? AND col != ? AND col2 = ?', bind => [qw/123 456 789 0/], }, # flipping array logic with explicit -and works { args => { logic => 'and' }, where => [ col => [ -and => {'<' => 123}, {'>' => 456 }, {'!=' => 789} ], col2 => 0 ], stmt => 'WHERE col < ? AND col > ? AND col != ? AND col2 = ?', bind => [qw/123 456 789 0/], }, # flipping array logic with explicit -or flipping it back { args => { logic => 'and' }, where => [ col => [ -or => {'<' => 123}, {'>' => 456 }, {'!=' => 789} ], col2 => 0 ], stmt => 'WHERE (col < ? OR col > ? OR col != ?) AND col2 = ?', bind => [qw/123 456 789 0/], }, ); # modN and mod_N were a bad design decision - they go away in SQLA2, warn now my @numbered_mods = ( { backcompat => { -and => [a => 10, b => 11], -and2 => [ c => 20, d => 21 ], -nest => [ x => 1 ], -nest2 => [ y => 2 ], -or => { m => 7, n => 8 }, -or2 => { m => 17, n => 18 }, }, correct => { -and => [ -and => [a => 10, b => 11], -and => [ c => 20, d => 21 ], -nest => [ x => 1 ], -nest => [ y => 2 ], -or => { m => 7, n => 8 }, -or => { m => 17, n => 18 }, ] }, }, { backcompat => { -and2 => [a => 10, b => 11], -and_3 => [ c => 20, d => 21 ], -nest2 => [ x => 1 ], -nest_3 => [ y => 2 ], -or2 => { m => 7, n => 8 }, -or_3 => { m => 17, n => 18 }, }, correct => [ -and => [ -and => [a => 10, b => 11], -and => [ c => 20, d => 21 ], -nest => [ x => 1 ], -nest => [ y => 2 ], -or => { m => 7, n => 8 }, -or => { m => 17, n => 18 }, ] ], }, ); my @nest_tests = ( { where => {a => 1, -nest => [b => 2, c => 3]}, stmt => 'WHERE ( ( (b = ? OR c = ?) AND a = ? ) )', bind => [qw/2 3 1/], }, { where => {a => 1, -nest => {b => 2, c => 3}}, stmt => 'WHERE ( ( (b = ? AND c = ?) AND a = ? ) )', bind => [qw/2 3 1/], }, { where => {a => 1, -or => {-nest => {b => 2, c => 3}}}, stmt => 'WHERE ( ( (b = ? AND c = ?) AND a = ? ) )', bind => [qw/2 3 1/], }, { where => {a => 1, -or => {-nest => [b => 2, c => 3]}}, stmt => 'WHERE ( ( (b = ? OR c = ?) AND a = ? ) )', bind => [qw/2 3 1/], }, { where => {a => 1, -nest => {-or => {b => 2, c => 3}}}, stmt => 'WHERE ( ( (b = ? OR c = ?) AND a = ? ) )', bind => [qw/2 3 1/], }, { where => [a => 1, -nest => {b => 2, c => 3}, -nest => [d => 4, e => 5]], stmt => 'WHERE ( ( a = ? OR ( b = ? AND c = ? ) OR ( d = ? OR e = ? ) ) )', bind => [qw/1 2 3 4 5/], }, ); for my $case (@and_or_tests) { TODO: { local $TODO = $case->{todo} if $case->{todo}; my $sql = SQL::Abstract->new ($case->{args} || {}); my $where_copy = dclone($case->{where}); warnings_are { my ($stmt, @bind) = $sql->where($case->{where}); is_same_sql_bind( $stmt, \@bind, $case->{stmt}, $case->{bind}, ) || diag_where( $case->{where} ); } [], 'No warnings within and-or tests'; is_deeply ($case->{where}, $where_copy, 'Where conditions unchanged'); } } for my $case (@nest_tests) { TODO: { local $TODO = $case->{todo} if $case->{todo}; local $SQL::Abstract::Test::parenthesis_significant = 1; my $sql = SQL::Abstract->new ($case->{args} || {}); lives_ok (sub { my ($stmt, @bind) = $sql->where($case->{where}); is_same_sql_bind( $stmt, \@bind, $case->{stmt}, $case->{bind}, ) || diag_where ( $case->{where} ); }); } } for my $case (@numbered_mods) { TODO: { local $TODO = $case->{todo} if $case->{todo}; # not using Test::Warn here - variable amount of warnings my @w; local $SIG{__WARN__} = sub { push @w, @_ }; my $sql = SQL::Abstract->new ($case->{args} || {}); { my ($old_s, @old_b) = $sql->where($case->{backcompat}); my ($new_s, @new_b) = $sql->where($case->{correct}); is_same_sql_bind( $old_s, \@old_b, $new_s, \@new_b, 'Backcompat and the correct(tm) syntax result in identical statements', ) || diag_where ( { backcompat => $case->{backcompat}, correct => $case->{correct}, }); }; ok ( (grep { $_ =~ qr/\QUse of [and|or|nest]_N modifiers is deprecated and will be removed in SQLA v2.0/ } @w ), 'Warnings were emitted about a mod_N construct'); } } done_testing; SQL-Abstract-1.81/examples/0000755000175000017500000000000012422705003014744 5ustar rabbitrabbitSQL-Abstract-1.81/examples/sqla-format0000755000175000017500000000251212361730666017137 0ustar rabbitrabbit#!/usr/bin/env perl use warnings; use strict; use Getopt::Long; my $p = Getopt::Long::Parser->new(config => [qw( gnu_getopt no_ignore_case )]); my $opts = { profile => 'console', help => \&showhelp }; $p->getoptions( $opts, qw( profile|p=s help|h )) or showhelp(); sub showhelp { require Pod::Usage; Pod::Usage::pod2usage( -verbose => 0, -exitval => 2 ); } require SQL::Abstract::Tree; my $sqlat = SQL::Abstract::Tree->new({ profile => $opts->{profile}, fill_in_placeholders => 0 }); my $chunk = ''; my $leftover = ''; do { $chunk = $leftover . $chunk if length $leftover; if ($chunk =~ / \A (.+?) (?: (?<=\S)\:\s+\'[^\n]+ # pasting DBIC_TRACE output directly | \;(?: \s | \z) | \z | ^ \s* (?=SELECT|INSERT|UPDATE|DELETE) ) (.*) /smix) { $leftover = $2; print $sqlat->format($1); print "\n"; } else { $leftover = $chunk; } } while ( (read *STDIN, $chunk, 4096) or length $leftover ); =head1 NAME sqla-format - An intelligent SQL formatter =head1 SYNOPSIS ~$ sqla-format << log.sql ~$ myprogram -v | sqla-format -p html > sqltrace.html =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2014 by Arthur Axel "fREW" Schmidt. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. SQL-Abstract-1.81/examples/dbic-console.pl0000644000175000017500000000065412361730666017666 0ustar rabbitrabbit#!/sur/bin/env perl use warnings; use strict; use DBIx::Class::Storage::Debug::PrettyPrint; my $pp = DBIx::Class::Storage::Debug::PrettyPrint->new({ profile => 'console', show_progress => 1, }); $pp->txn_begin; $pp->query_start("SELECT a, b, c FROM foo WHERE foo.a =1 and foo.b LIKE ?", q('station')); sleep 1; $pp->query_end("SELECT a, b, c FROM foo WHERE foo.a =1 and foo.b LIKE ?", q('station')); $pp->txn_commit; SQL-Abstract-1.81/examples/console.pl0000644000175000017500000000757712361730666017002 0ustar rabbitrabbit#!/sur/bin/env perl use warnings; use strict; use SQL::Abstract::Tree; my $sqlat = SQL::Abstract::Tree->new({ profile => 'console' }); my @sql = ( "BEGIN WORK", "SELECT a, b, c FROM foo WHERE foo.a =1 and foo.b LIKE 'station'", "SELECT * FROM (SELECT * FROM foobar) WHERE foo.a =1 and foo.b LIKE 'station'", "SELECT * FROM lolz WHERE ( foo.a =1 ) and foo.b LIKE 'station'", "SELECT * LIMIT 5 OFFSET 5 FROM lolz ", "SELECT * LIMIT 5 5 FROM lolz ", "SELECT SKIP 5 FIRST 5 * FROM lolz ", "SELECT FIRST 5 SKIP 5 * FROM lolz ", "UPDATE session SET expires = ? WHERE (id = ?)", "INSERT INTO Request (creation_date, is_private, owner_id, request) VALUES (? , ? , ? , ?)", "SELECT [screen].[id], [screen].[name], [screen].[section_id], [screen].[xtype] FROM [users_roles] [me] JOIN [roles] [role] ON [role].[id] = [me].[role_id] JOIN [roles_permissions] [role_permissions] ON [role_permissions].[role_id] = [role].[id] JOIN [permissions] [permission] ON [permission].[id] = [role_permissions].[permission_id] JOIN [permissionscreens] [permission_screens] ON [permission_screens].[permission_id] = [permission].[id] JOIN [screens] [screen] ON [screen].[id] = [permission_screens].[screen_id] WHERE ( [me].[user_id] = ? ) GROUP BY [screen].[id], [screen].[name], [screen].[section_id], [screen].[xtype]", "SELECT [status], [supplier_id], [ship_to_supplier_id], [request_by_user_id], [is_printed], [creation_date], [id], [date], [fob_state], [is_confirmed], [is_outside_process], [ship_via], [special_instructions], [when_shipped] FROM ( SELECT [status], [supplier_id], [ship_to_supplier_id], [request_by_user_id], [is_printed], [creation_date], [id], [date], [fob_state], [is_confirmed], [is_outside_process], [ship_via], [special_instructions], [when_shipped], ROW_NUMBER() OVER( ORDER BY [me].[id] DESC ) AS [rno__row__index] FROM ( SELECT [me].[status], [me].[supplier_id], [me].[ship_to_supplier_id], [me].[request_by_user_id], [me].[is_printed], [me].[creation_date], [me].[id], [me].[date], [me].[fob_state], [me].[is_confirmed], [me].[is_outside_process], [me].[ship_via], [me].[special_instructions], [me].[when_shipped] FROM [PurchaseOrders] [me] WHERE ( [me].[status] = ? ) ) [me] ) [me] WHERE [rno__row__index] BETWEEN 1 AND 25", "SELECT me.id, me.name, me.creator_id, group_users.group_id, group_users.user_id, user.id, user.first_name, user.last_name, user.nickname, user.email, user.password, user.is_active, user.logins FROM Group me LEFT JOIN GroupUser group_users ON group_users.group_id = me.id LEFT JOIN User user ON user.id = group_users.user_id WHERE (me.creator_id = ?) ORDER BY name, group_users.group_id", "COMMIT", 'ROLLBACK', 'SAVEPOINT station', 'ROLLBACK TO SAVEPOINT station', 'RELEASE SAVEPOINT station', "SELECT COUNT( * ) FROM message_children me WHERE( ( me.phone_number NOT IN ( SELECT message_child.phone_number FROM blocked_destinations me JOIN message_children_status reason ON reason.id = me.reason_id JOIN message_children message_child ON message_child.id = reason.message_child_id) AND ( ( me.api_id IS NULL ) ) ) )" ); print "\n\n'" . $sqlat->format($_) . "'\n" for @sql; print "\n\n'" . $sqlat->format( "UPDATE session SET expires = ? WHERE (id = ?)", ['2010-12-02', 1] ) . "'\n"; print "\n\n'" . $sqlat->format( "SELECT raw_scores FROM ( SELECT raw_scores, ROW_NUMBER() OVER ( ORDER BY ( SELECT (1))) AS rno__row__index FROM ( SELECT rpt_score.raw_scores FROM users me JOIN access access ON access.userid = me.userid JOIN mgmt mgmt ON mgmt.mgmtid = access.mgmtid JOIN [order] orders ON orders.mgmtid = mgmt.mgmtid JOIN shop shops ON shops.orderno = orders.orderno JOIN rpt_scores rpt_score ON rpt_score.shopno = shops.shopno WHERE ( datecompleted IS NOT NULL AND ( (shops.datecompleted BETWEEN ? AND ?) AND (type = ? AND me.userid = ?)))) rpt_score) rpt_score WHERE rno__row__index BETWEEN ? AND ? )", ['2009-10-01', '2009-10-08', 1, 'frew', 1, 1] ) . "'\n"; SQL-Abstract-1.81/inc/0000755000175000017500000000000012422705003013677 5ustar rabbitrabbitSQL-Abstract-1.81/inc/Module/0000755000175000017500000000000012422705003015124 5ustar rabbitrabbitSQL-Abstract-1.81/inc/Module/Install.pm0000644000175000017500000003013512422704761017104 0ustar rabbitrabbit#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.06'; # 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 $/; }; 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 $/; }; 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. SQL-Abstract-1.81/inc/Module/Install/0000755000175000017500000000000012422705003016532 5ustar rabbitrabbitSQL-Abstract-1.81/inc/Module/Install/AutoInstall.pm0000644000175000017500000000416212422704761021344 0ustar rabbitrabbit#line 1 package Module::Install::AutoInstall; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @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; SQL-Abstract-1.81/inc/Module/Install/Makefile.pm0000644000175000017500000002743712422704761020634 0ustar rabbitrabbit#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.06'; @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 =~ 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 SQL-Abstract-1.81/inc/Module/Install/Include.pm0000644000175000017500000000101512422704761020462 0ustar rabbitrabbit#line 1 package Module::Install::Include; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @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; SQL-Abstract-1.81/inc/Module/Install/Metadata.pm0000644000175000017500000004327712422704761020637 0ustar rabbitrabbit#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency 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; SQL-Abstract-1.81/inc/Module/Install/WriteAll.pm0000644000175000017500000000237612422704761020635 0ustar rabbitrabbit#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @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; SQL-Abstract-1.81/inc/Module/Install/Win32.pm0000644000175000017500000000340312422704761020004 0ustar rabbitrabbit#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @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; SQL-Abstract-1.81/inc/Module/Install/Fetch.pm0000644000175000017500000000462712422704761020144 0ustar rabbitrabbit#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @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; SQL-Abstract-1.81/inc/Module/Install/Base.pm0000644000175000017500000000214712422704761017760 0ustar rabbitrabbit#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.06'; } # 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 SQL-Abstract-1.81/inc/Module/Install/Can.pm0000644000175000017500000000615712422704761017614 0ustar rabbitrabbit#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.06'; @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 SQL-Abstract-1.81/inc/Module/AutoInstall.pm0000644000175000017500000006216212422704761017742 0ustar rabbitrabbit#line 1 package Module::AutoInstall; use strict; use Cwd (); use File::Spec (); use ExtUtils::MakeMaker (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.06'; } # 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() : == 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 () { 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 SQL-Abstract-1.81/Changes0000644000175000017500000003633112422704670014440 0ustar rabbitrabbitRevision history for SQL::Abstract revision 1.81 2014-10-25 ---------------------------- - Fix overly-enthusiastic parenthesis unroller (RT#99503) revision 1.80 2014-10-05 ---------------------------- - Fix erroneous behavior of is_literal_value($) wrt { -ident => ... } - Explicitly croak on top-level special ops (they didn't work anyway) revision 1.79 2014-09-25 ---------------------------- - New exportable functions: is_literal_value($) and is_plain_value($) - New attribute 'escape_char' allowing for proper escape of quote_chars present in an identifier - Deprecate { "" => \... } constructs - Treat { -value => undef } as plain undef in all cases - Explicitly throw on { -ident => undef } revision 1.78 2014-05-28 ---------------------------- - Fix parsing of binary ops to correctly take up only a single LHS element, instead of gobbling up the entire parse-to-date - Explicitly handle ROW_NUMBER() OVER as the snowflake-operator it is - Improve signatures/documentation of is_same_sql_bind / eq_sql_bind - Retire script/format-sql - the utility needs more work to be truly end-user convenient revision 1.77 2014-01-17 ---------------------------- - Reintroduce { -not => undef } column operator (regression from 1.75) revision 1.75 2013-12-27 ---------------------------- - *UPCOMING INCOMPATIBLE BUGFIX*: SQLA used to generate incorrect SQL on undef-containing lists fed to -in and -not_in. An exception will be raised for a while before properly fixing this, to avoid quiet but subtle changes to query results in production - Deprecate and warn when supplying an empty arrayref to like/not_like operators (likely to be removed before 2.0) - Warn when using an inequality operator with a multi-value array to arrive at what amounts to a 1=1 condition (no pre-2.0 plans to fix this behavior due to backwards comp concerns) - Fix false negative comparison of ORDER BY ASC - More improvements of incorrect parsing (placeholder at end of list element) - Fix typos in POD and comments (RT#87776) - Augment -not_bool example with nesting (RT#89601) revision 1.74 2013-06-04 ---------------------------- - Fix insufficient parenthesis unroll during operator comparison - 'ORDER BY foo' and 'ORDER BY foo ASC' are now considered equal by default (with a switch to reenable old behavior when necessary) - Change parser to not eagerly slurp RHS expressions it doesn't recognize revision 1.73 2012-07-10 ---------------------------- - Fix parsing of ORDER BY foo + ? - Stop filling in placeholders in `format-sql` since it does not support passing values for them anyway - Fix parsing of NOT EXISTS - Fix over-eager parenthesis unrolling - Fix deep recursion warnings while parsing obnoxiously long sql statements - Fix incorrect comparison of malformed lists - Fix incorrect reporting of mismatch-members in SQLA::Test - Migrate the -ident operator from DBIC into SQLA - Migrate the -value operator from DBIC into SQLA revision 1.72 2010-12-21 ---------------------------- - Extra checks of search arguments for possible SQL injection attacks - Remove excess parentheses in debug SQL - Fix parsing of foo.* in SQLA::Tree - Fix bindtype fail when using -between with arrayrefref literals - Add handling for NULL for -in - The -nest operator has entered semi-deprecated status and has been undocumented. Please do not use it in new code revision 1.71 2010-11-09 ---------------------------- - Add EXECUTING for clarity of long running SQL - Add "squash_repeats" option to fix it such that repeated SQL gets ellided except for placeholders - Highlight transaction keywords - Highlight HAVING - Leave quotes from DBIC in bindargs - Add error checking on "profile" for SQLA::Tree - Hide bulk inserts from DBIx::Class - Fix missing doc (RT#62587) - Format functions in MySQL-friendly manner foo( ... ) vs foo ( ... ) revision 1.69 2010-10-22 ---------------------------- - Add quotes for populated placeholders and make the background magenta instead of cyan - Color and indent pagination keywords - Fix a silly bug which broke placeholder fill-in in DBIC - Installs format-sql to format SQL passed in over STDIN - Switch the tokenizer to precompiled regexes (massive speedup) - Rudimentary handling of quotes ( 'WHERE' vs WHERE ) - Fix extended argument parsing by IN/BETWEEN - Add proper handling of lists (foo,bar,?) - Better handling of generic -function's during AST construction - Special handle IS NOT? NULL - Make sure unparse() does not destroy a passed in \@bindargs - Support ops with _'s in them (valid in Oracle) - Properly parse both types of default value inserts - Allow { -func => $val } as arguments to UPDATE revision 1.68 2010-09-16 ---------------------------- - Document methods on Tree - Add affordances for color coding placeholders - Change ::Tree::whitespace to whitespace_keyword revision 1.67_03 2010-09-11 ---------------------------- - Add docs for SQL::Abstract::Tree->new - correcty merge profile and parameters - added fill_in_placeholders option for excellent copy/pasta revision 1.67_02 2010-09-08 ---------------------------- - rename DBIx::Class::Storage::PrettyPrinter to DBIx::Class::Storage::Debug::PrettyPrint - decreased a lot of indentation from ::Tree - cleaned up handling of newlines inside of parens revision 1.67_01 2010-09-06 ---------------------------- - Add SQL::Abstract::Tree - Add unindexed DBIx::Class::Storage::PrettyPrinter - Better documentation of undef/NULL in where clause - Depend on bugfixed Module::Install (now again installs on old < 5.8.3 perls) revision 1.67 2010-05-31 14:21 (UTC) ---------------------------- - Fix SQL::Test failure when first chunk is an unrecognized literal - Generic -not operator tests - More columns-bindtype assertion checks revision 1.66 2010-04-27 02:44 (UTC) ---------------------------- - Optimized the quoting mechanism, winning nearly 10% speedup on repeatable sql generation revision 1.65 2010-04-11 19:59 (UTC) ---------------------------- - Rerelease last version to not include .svn files and grab MANIFEST.SKIP from DBIx::Class so it won't happen again revision 1.64 2010-04-11 16:58 (UTC) ---------------------------- - Fix multiple generic op handling regressions by reverting the auto-equality assumption (turned out to be a very very bad idea) revision 1.63 2010-03-24 09:56 (UTC) ---------------------------- - Add ILIKE to the core list of comparision ops revision 1.62 2010-03-15 11:06 (UTC) ---------------------------- - Fixed open outer parens for a multi-line literal - Allow recursively-nested column-functions in WHERE - Bumped minimum perl to 5.6.2 and changed tests to rely on core dependencies revision 1.61 2010-02-05 16:28 (UTC) ---------------------------- - Allow INSERT to take additional attributes - Support for INSERT ... RETURNING - Another iteration of SQL::Abstract::Test fixes and improvements revision 1.60 2009-09-22 11:03 (UTC) ---------------------------- - fix a well masked error in the sql-test tokenizer revision 1.59 2009-09-22 08:39 (UTC) ---------------------------- - fixed a couple of untrapped undefined warnings - allow -in/-between to accept literal sql in all logical variants - see POD for details - unroll multiple parenthesis around IN arguments to accomodate crappy databases revision 1.58 2009-09-04 15:20 (UTC) ---------------------------- - expanded the scope of -bool and -not_bool operators - added proper testing support revision 1.57 2009-09-03 20:18 (UTC) ---------------------------- - added -bool and -not_bool operators revision 1.56 2009-05-30 16:31 (UTC) ---------------------------- - support for \[$sql, @bind] in order_by clauses e.g.: { -desc => \['colA LIKE ?', 'somestring'] } revision 1.55 2009-05-17 22:54 (UTC) ---------------------------- - make sure that sql generation does not mutate the supplied where condition structure revision 1.54 2009-05-07 17:23 (UTC) ---------------------------- - allow special_operators to take both code refs and method names (makes it possible to properly subclass the builtin ones) revision 1.53 2009-04-30 14:58 (UTC) ---------------------------- - make sure hash keys are sorted in all search sub-conditions - switch installer from EU::MM to M::I revision 1.52 2009-04-28 23:14 (UTC) ---------------------------- - allow -between to handle [\"", \""] and \["", @bind] - allow order_by to handle -asc|desc => [qw/colA colB/] (artifact from DBIx::Class) - more tests and clearing up of some corner cases - t/10test.t does not run by default (developer only, too cpu intensive) ---------------------------- revision 1.51 2009-03-28 10:00 (UTC) - fixed behavior of [-and => ... ] depending on the current condition scope. This introduces backwards comp with 1.24 ---------------------------- revision 1.50 2009-03-10 12:30 (UTC) - fixed the problem with values() not behaving the same as the rest of the code (RT#43483) - fixed interjecting arrayrefref into a where clause - added value-only insert test with a literal SQL snippet - cleanup and enhancement of t/03values.t - better handling of borked SQL in tests - deal properly with parentheses in is_same_sql_bind() - fixed test subs (is_same_*) in SQL::Abstract::Test to return the correct test value - do not version MANIFEST Version 1.50 was a major internal refactoring of SQL::Abstract. Great care has been taken to preserve the published behavior documented in previous versions in the 1.* family; however, some features that were previously undocumented, or behaved. differently from the documentation, had to be changed in order to clarify the semantics. Hence, client code that was relying on some dark areas of SQL::Abstract v1.* might behave differently in v1.50. ---------------------------- revision 1.49_04 2009-03-03 - add support for a [\%column_meta => value] bind value format ---------------------------- revision 1.49_03 2009-02-17 - clarify syntax of \['...', @bind] when used with a bindtype of 'columns' ---------------------------- revision 1.49_02 2009-02-16 - added an AST-aware SQL::Abstract::Test library for sql syntax tests - vastly expanded test coverage - support for the { operator => \'...'|\['...', @bind] } syntax allowing to embed arbitrary operators on the LHS - fixed multiple regressions wrt DBIx::Class ---------------------------- revision 1.49_01 2009-02-11 - support for literal SQL through the [$sql, bind] syntax. - added -nest1, -nest2 or -nest_1, -nest_2, ... - optional support for array datatypes - defensive programming : check arguments to functions/methods - fixed bug with global logic of -and/-or (no side-effects any more) - changed logic for distributing an op over arrayrefs - fixed semantics of _bindtype on array args - dropped the _anoncopy of the %where tree. No longer necessary. - dropped the _modlogic function - Make col => [] and col => {$op => [] } DTRT or die instead of generating broken SQL. Added tests for this. - Added { -desc => 'column' } order by support - Tiny "$_"-related fix for { -desc => 'columns'} order by support tests + docs ---------------------------- revision 1.20 date: 2005/08/18 18:41:58; author: nwiger; state: Exp; lines: +104 -50 - added patch from Dan Kubb enabling quote_char and name_sep options - added patch from Andy Grundman to enhance _anoncopy for deep refs ---------------------------- revision 1.19 date: 2005/04/29 18:20:30; author: nwiger; state: Exp; lines: +34 -20 added _anoncopy to prevent destroying original; updated docs ---------------------------- revision 1.18 date: 2005/03/07 20:14:12; author: nwiger; state: Exp; lines: +201 -65 added support for -and, -or, and -nest; see docs for details ---------------------------- revision 1.17 date: 2004/08/25 20:11:27; author: nwiger; state: Exp; lines: +58 -46 added patch from Eric Kolve to iterate over all hashref elements ---------------------------- revision 1.16 date: 2004/06/10 17:20:01; author: nwiger; state: Exp; lines: +178 -12 added bindtype param to allow this to work with Orasuck 9+ ---------------------------- revision 1.15 date: 2003/11/05 23:40:40; author: nwiger; state: Exp; lines: +18 -6 several bugfixes, including _convert being applied wrong and the edge case field => { '!=', [qw/this that/] } not working ---------------------------- revision 1.14 date: 2003/11/04 21:20:33; author: nwiger; state: Exp; lines: +115 -34 added patch from Philip Collins, and also added 'convert' option ---------------------------- revision 1.13 date: 2003/05/21 17:22:29; author: nwiger; state: Exp; lines: +230 -74 added "IN" and "BETWEEN" operator support, as well as "NOT" modified where() to support ORDER BY, and fixed some bugs too added PERFORMANCE and FORMBUILDER doc sections fixed several bugs in _recurse_where(), it now works as expected added test suite, many thanks to Chas Owens modified all hash access to return keys sorted, to allow cached queries ---------------------------- revision 1.12 date: 2003/05/08 20:10:56; author: nwiger; state: Exp; lines: +181 -96 1.11 interim checking; major bugfixes and order_by, 1.12 will go to CPAN ---------------------------- revision 1.11 date: 2003/05/02 00:07:30; author: nwiger; state: Exp; lines: +52 -12 many minor enhancements to add querying flexibility ---------------------------- revision 1.10 date: 2002/09/27 18:06:25; author: nwiger; state: Exp; lines: +6 -2 added precatch for messed up where string ---------------------------- revision 1.9 date: 2002/08/29 18:04:35; author: nwiger; state: Exp; lines: +4 -3 CPAN ---------------------------- revision 1.8 date: 2001/11/07 22:18:12; author: nwiger; state: Exp; lines: +31 -14 added embedded SCALAR ref capability to insert() and update() ---------------------------- revision 1.7 date: 2001/11/07 01:23:28; author: nwiger; state: Exp; lines: +3 -3 damn uninit warning ---------------------------- revision 1.6 date: 2001/11/06 21:09:44; author: nwiger; state: Exp; lines: +14 -6 oops, had to actually *implement* the order by for select()! ---------------------------- revision 1.5 date: 2001/11/06 03:13:16; author: nwiger; state: Exp; lines: +43 -4 lots of docs ---------------------------- revision 1.4 date: 2001/11/06 03:07:42; author: nwiger; state: Exp; lines: +16 -7 added extra layer of ()'s to ensure correct semantics on AND ---------------------------- revision 1.3 date: 2001/11/06 01:16:31; author: nwiger; state: Exp; lines: +11 -10 updated all statements so that they use wantarray to just return SQL if asked ---------------------------- revision 1.2 date: 2001/10/26 22:23:46; author: nwiger; state: Exp; lines: +112 -15 added scalar ref for SQL verbatim in where, fixed bugs, array ref, docs ---------------------------- revision 1.1 date: 2001/10/24 00:26:43; author: nwiger; state: Exp; Initial revision SQL-Abstract-1.81/MANIFEST0000644000175000017500000000172312422704771014275 0ustar rabbitrabbitChanges examples/console.pl examples/dbic-console.pl examples/sqla-format 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/DBIx/Class/Storage/Debug/PrettyPrint.pm lib/SQL/Abstract.pm lib/SQL/Abstract/Test.pm lib/SQL/Abstract/Tree.pm Makefile.PL MANIFEST This list of files META.yml t/00new.t t/01generate.t t/02where.t t/03values.t t/04modifiers.t t/05in_between.t t/06order_by.t t/07subqueries.t t/08special_ops.t t/09refkind.t t/10test.t t/11parser.t t/12confmerge.t t/12format_keyword.t t/13whitespace_keyword.t t/14roundtrippin.t t/15placeholders.t t/16no_sideeffects.t t/20injection_guard.t t/21op_ident.t t/22op_value.t t/23_is_X_value.t t/dbic/bulk-insert.t t/dbic/no-repeats.t t/dbic/show-progress.t SQL-Abstract-1.81/META.yml0000644000175000017500000000175012422704761014414 0ustar rabbitrabbit--- abstract: 'Generate SQL from Perl data structures' author: - 'Nathan Wiger ' build_requires: ExtUtils::MakeMaker: 6.59 Storable: 0 Test::Deep: 0.101 Test::Exception: 0.31 Test::More: 0.88 Test::Warn: 0 configure_requires: ExtUtils::MakeMaker: 6.59 distribution_type: module dynamic_config: 0 generated_by: 'Module::Install version 1.06' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: SQL-Abstract no_index: directory: - examples - inc - t - xt package: - DBIx::Class::Storage::Debug::PrettyPrint requires: Exporter: 5.57 Hash::Merge: 0.12 List::Util: 0 MRO::Compat: 0.12 Moo: 1.004002 Scalar::Util: 0 Text::Balanced: 2.00 perl: 5.6.0 resources: IRC: irc://irc.perl.org/#dbix-class bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=SQL-Abstract license: http://dev.perl.org/licenses/ repository: https://github.com/dbsrgits/sql-abstract/ version: 1.81 SQL-Abstract-1.81/lib/0000755000175000017500000000000012422705003013674 5ustar rabbitrabbitSQL-Abstract-1.81/lib/SQL/0000755000175000017500000000000012422705003014333 5ustar rabbitrabbitSQL-Abstract-1.81/lib/SQL/Abstract/0000755000175000017500000000000012422705003016076 5ustar rabbitrabbitSQL-Abstract-1.81/lib/SQL/Abstract/Tree.pm0000644000175000017500000006365212410407515017353 0ustar rabbitrabbitpackage SQL::Abstract::Tree; # DO NOT edit away without talking to riba first, he will just put it back # BEGIN pre-Moo2 import block BEGIN { require warnings; my $initial_fatal_bits = (${^WARNING_BITS}||'') & $warnings::DeadBits{all}; local $ENV{PERL_STRICTURES_EXTRA} = 0; # load all of these now, so that lazy-loading does not escape # the current PERL_STRICTURES_EXTRA setting require Sub::Quote; require Sub::Defer; require Moo; require Moo::Object; require Method::Generate::Accessor; require Method::Generate::Constructor; Moo->import; Sub::Quote->import('quote_sub'); ${^WARNING_BITS} &= ( $initial_fatal_bits | ~ $warnings::DeadBits{all} ); } # END pre-Moo2 import block use strict; use warnings; no warnings 'qw'; use Carp; my $op_look_ahead = '(?: (?= [\s\)\(\;] ) | \z)'; my $op_look_behind = '(?: (?<= [\,\s\)\(] ) | \A )'; my $quote_left = qr/[\`\'\"\[]/; my $quote_right = qr/[\`\'\"\]]/; my $placeholder_re = qr/(?: \? | \$\d+ )/x; # These SQL keywords always signal end of the current expression (except inside # of a parenthesized subexpression). # Format: A list of strings that will be compiled to extended syntax ie. # /.../x) regexes, without capturing parentheses. They will be automatically # anchored to op boundaries (excluding quotes) to match the whole token. my @expression_start_keywords = ( 'SELECT', 'UPDATE', 'SET', 'INSERT \s+ INTO', 'DELETE \s+ FROM', 'FROM', '(?: (?: (?: (?: LEFT | RIGHT | FULL ) \s+ )? (?: (?: CROSS | INNER | OUTER ) \s+ )? )? JOIN )', 'ON', 'WHERE', '(?: DEFAULT \s+ )? VALUES', 'GROUP \s+ BY', 'HAVING', 'ORDER \s+ BY', 'SKIP', 'FETCH', 'FIRST', 'LIMIT', 'OFFSET', 'FOR', 'UNION', 'INTERSECT', 'EXCEPT', 'BEGIN \s+ WORK', 'COMMIT', 'ROLLBACK \s+ TO \s+ SAVEPOINT', 'ROLLBACK', 'SAVEPOINT', 'RELEASE \s+ SAVEPOINT', 'RETURNING', ); my $expr_start_re = join ("\n\t|\n", @expression_start_keywords ); $expr_start_re = qr/ $op_look_behind (?i: $expr_start_re ) $op_look_ahead /x; # These are binary operator keywords always a single LHS and RHS # * AND/OR are handled separately as they are N-ary # * so is NOT as being unary # * BETWEEN without parentheses around the ANDed arguments (which # makes it a non-binary op) is detected and accommodated in # _recurse_parse() # * AS is not really an operator but is handled here as it's also LHS/RHS # this will be included in the $binary_op_re, the distinction is interesting during # testing as one is tighter than the other, plus alphanum cmp ops have different # look ahead/behind (e.g. "x"="y" ) my @alphanum_cmp_op_keywords = (qw/< > != <> = <= >= /); my $alphanum_cmp_op_re = join ("\n\t|\n", map { "(?: (?<= [\\w\\s] | $quote_right ) | \\A )" . quotemeta ($_) . "(?: (?= [\\w\\s] | $quote_left ) | \\z )" } @alphanum_cmp_op_keywords ); $alphanum_cmp_op_re = qr/$alphanum_cmp_op_re/x; my $binary_op_re = '(?: NOT \s+)? (?:' . join ('|', qw/IN BETWEEN R?LIKE/) . ')'; $binary_op_re = join "\n\t|\n", "$op_look_behind (?i: $binary_op_re | AS ) $op_look_ahead", $alphanum_cmp_op_re, $op_look_behind . 'IS (?:\s+ NOT)?' . "(?= \\s+ NULL \\b | $op_look_ahead )", ; $binary_op_re = qr/$binary_op_re/x; my $rno_re = qr/ROW_NUMBER \s* \( \s* \) \s+ OVER/ix; my $unary_op_re = 'NOT \s+ EXISTS | NOT | ' . $rno_re; $unary_op_re = join "\n\t|\n", "$op_look_behind (?i: $unary_op_re ) $op_look_ahead", ; $unary_op_re = qr/$unary_op_re/x; my $asc_desc_re = qr/$op_look_behind (?i: ASC | DESC ) $op_look_ahead /x; my $and_or_re = qr/$op_look_behind (?i: AND | OR ) $op_look_ahead /x; my $tokenizer_re = join("\n\t|\n", $expr_start_re, $binary_op_re, $unary_op_re, $asc_desc_re, $and_or_re, $op_look_behind . ' \* ' . $op_look_ahead, (map { quotemeta $_ } qw/, ( )/), $placeholder_re, ); # this one *is* capturing for the split below # splits on whitespace if all else fails # has to happen before the composing qr's are anchored (below) $tokenizer_re = qr/ \s* ( $tokenizer_re ) \s* | \s+ /x; # Parser states for _recurse_parse() use constant PARSE_TOP_LEVEL => 0; use constant PARSE_IN_EXPR => 1; use constant PARSE_IN_PARENS => 2; use constant PARSE_IN_FUNC => 3; use constant PARSE_RHS => 4; use constant PARSE_LIST_ELT => 5; my $expr_term_re = qr/$expr_start_re | \)/x; my $rhs_term_re = qr/ $expr_term_re | $binary_op_re | $unary_op_re | $asc_desc_re | $and_or_re | \, /x; my $all_std_keywords_re = qr/ $rhs_term_re | \( | $placeholder_re /x; # anchor everything - even though keywords are separated by the tokenizer, leakage may occur for ( $quote_left, $quote_right, $placeholder_re, $expr_start_re, $alphanum_cmp_op_re, $binary_op_re, $unary_op_re, $asc_desc_re, $and_or_re, $expr_term_re, $rhs_term_re, $all_std_keywords_re, ) { $_ = qr/ \A $_ \z /x; } # what can be bunched together under one MISC in an AST my $compressable_node_re = qr/^ \- (?: MISC | LITERAL | PLACEHOLDER ) $/x; my %indents = ( select => 0, update => 0, 'insert into' => 0, 'delete from' => 0, from => 1, where => 0, join => 1, 'left join' => 1, on => 2, having => 0, 'group by' => 0, 'order by' => 0, set => 1, into => 1, values => 1, limit => 1, offset => 1, skip => 1, first => 1, ); has [qw( newline indent_string indent_amount fill_in_placeholders placeholder_surround )] => (is => 'ro'); has [qw( indentmap colormap )] => ( is => 'ro', default => quote_sub('{}') ); # class global is in fact desired my $merger; sub BUILDARGS { my $class = shift; my $args = ref $_[0] eq 'HASH' ? $_[0] : {@_}; if (my $p = delete $args->{profile}) { my %extra_args; if ($p eq 'console') { %extra_args = ( fill_in_placeholders => 1, placeholder_surround => ['?/', ''], indent_string => ' ', indent_amount => 2, newline => "\n", colormap => {}, indentmap => \%indents, ! ( eval { require Term::ANSIColor } ) ? () : do { my $c = \&Term::ANSIColor::color; my $red = [$c->('red') , $c->('reset')]; my $cyan = [$c->('cyan') , $c->('reset')]; my $green = [$c->('green') , $c->('reset')]; my $yellow = [$c->('yellow') , $c->('reset')]; my $blue = [$c->('blue') , $c->('reset')]; my $magenta = [$c->('magenta'), $c->('reset')]; my $b_o_w = [$c->('black on_white'), $c->('reset')]; ( placeholder_surround => [$c->('black on_magenta'), $c->('reset')], colormap => { 'begin work' => $b_o_w, commit => $b_o_w, rollback => $b_o_w, savepoint => $b_o_w, 'rollback to savepoint' => $b_o_w, 'release savepoint' => $b_o_w, select => $red, 'insert into' => $red, update => $red, 'delete from' => $red, set => $cyan, from => $cyan, where => $green, values => $yellow, join => $magenta, 'left join' => $magenta, on => $blue, 'group by' => $yellow, having => $yellow, 'order by' => $yellow, skip => $green, first => $green, limit => $green, offset => $green, } ); }, ); } elsif ($p eq 'console_monochrome') { %extra_args = ( fill_in_placeholders => 1, placeholder_surround => ['?/', ''], indent_string => ' ', indent_amount => 2, newline => "\n", indentmap => \%indents, ); } elsif ($p eq 'html') { %extra_args = ( fill_in_placeholders => 1, placeholder_surround => ['', ''], indent_string => ' ', indent_amount => 2, newline => "
\n", colormap => { map { (my $class = $_) =~ s/\s+/-/g; ( $_ => [ qq||, '' ] ) } ( keys %indents, qw(commit rollback savepoint), 'begin work', 'rollback to savepoint', 'release savepoint', ) }, indentmap => \%indents, ); } elsif ($p eq 'none') { # nada } else { croak "No such profile '$p'"; } # see if we got any duplicates and merge if needed if (scalar grep { exists $args->{$_} } keys %extra_args) { # heavy-duty merge $args = ($merger ||= do { require Hash::Merge; my $m = Hash::Merge->new; $m->specify_behavior({ SCALAR => { SCALAR => sub { $_[1] }, ARRAY => sub { [ $_[0], @{$_[1]} ] }, HASH => sub { $_[1] }, }, ARRAY => { SCALAR => sub { $_[1] }, ARRAY => sub { $_[1] }, HASH => sub { $_[1] }, }, HASH => { SCALAR => sub { $_[1] }, ARRAY => sub { [ values %{$_[0]}, @{$_[1]} ] }, HASH => sub { Hash::Merge::_merge_hashes( $_[0], $_[1] ) }, }, }, 'SQLA::Tree Behavior' ); $m; })->merge(\%extra_args, $args ); } else { $args = { %extra_args, %$args }; } } $args; } sub parse { my ($self, $s) = @_; return [] unless defined $s; # tokenize string, and remove all optional whitespace my $tokens = []; foreach my $token (split $tokenizer_re, $s) { push @$tokens, $token if ( defined $token and length $token and $token =~ /\S/ ); } return [ $self->_recurse_parse($tokens, PARSE_TOP_LEVEL) ]; } sub _recurse_parse { my ($self, $tokens, $state) = @_; my @left; while (1) { # left-associative parsing if ( ! @$tokens or ($state == PARSE_IN_PARENS && $tokens->[0] eq ')') or ($state == PARSE_IN_EXPR && $tokens->[0] =~ $expr_term_re ) or ($state == PARSE_RHS && $tokens->[0] =~ $rhs_term_re ) or ($state == PARSE_LIST_ELT && ( $tokens->[0] eq ',' or $tokens->[0] =~ $expr_term_re ) ) ) { return @left; } my $token = shift @$tokens; # nested expression in () if ($token eq '(' ) { my @right = $self->_recurse_parse($tokens, PARSE_IN_PARENS); $token = shift @$tokens or croak "missing closing ')' around block " . $self->unparse(\@right); $token eq ')' or croak "unexpected token '$token' terminating block " . $self->unparse(\@right); push @left, [ '-PAREN' => \@right ]; } # AND/OR elsif ($token =~ $and_or_re) { my $op = uc $token; my @right = $self->_recurse_parse($tokens, PARSE_IN_EXPR); # Merge chunks if "logic" matches @left = [ $op => [ @left, (@right and $op eq $right[0][0]) ? @{ $right[0][1] } : @right ] ]; } # LIST (,) elsif ($token eq ',') { my @right = $self->_recurse_parse($tokens, PARSE_LIST_ELT); # deal with malformed lists ( foo, bar, , baz ) @right = [] unless @right; @right = [ -MISC => [ @right ] ] if @right > 1; if (!@left) { @left = [ -LIST => [ [], @right ] ]; } elsif ($left[0][0] eq '-LIST') { push @{$left[0][1]}, (@{$right[0]} and $right[0][0] eq '-LIST') ? @{$right[0][1]} : @right ; } else { @left = [ -LIST => [ @left, @right ] ]; } } # binary operator keywords elsif ($token =~ $binary_op_re) { my $op = uc $token; my @right = $self->_recurse_parse($tokens, PARSE_RHS); # A between with a simple LITERAL for a 1st RHS argument needs a # rerun of the search to (hopefully) find the proper AND construct if ($op eq 'BETWEEN' and $right[0] eq '-LITERAL') { unshift @$tokens, $right[1][0]; @right = $self->_recurse_parse($tokens, PARSE_IN_EXPR); } push @left, [$op => [ (@left ? pop @left : ''), @right ]]; } # unary op keywords elsif ( $token =~ $unary_op_re ) { my $op = uc $token; # normalize RNO explicitly $op = 'ROW_NUMBER() OVER' if $op =~ /^$rno_re$/; my @right = $self->_recurse_parse ($tokens, PARSE_RHS); push @left, [ $op => \@right ]; } # expression terminator keywords elsif ( $token =~ $expr_start_re ) { my $op = uc $token; my @right = $self->_recurse_parse($tokens, PARSE_IN_EXPR); push @left, [ $op => \@right ]; } # a '?' elsif ( $token =~ $placeholder_re) { push @left, [ -PLACEHOLDER => [ $token ] ]; } # check if the current token is an unknown op-start elsif (@$tokens and ($tokens->[0] eq '(' or $tokens->[0] =~ $placeholder_re ) ) { push @left, [ $token => [ $self->_recurse_parse($tokens, PARSE_RHS) ] ]; } # we're now in "unknown token" land - start eating tokens until # we see something familiar, OR in the case of RHS (binop) stop # after the first token # Also stop processing when we could end up with an unknown func else { my @lits = [ -LITERAL => [$token] ]; unshift @lits, pop @left if @left == 1; unless ( $state == PARSE_RHS ) { while ( @$tokens and $tokens->[0] !~ $all_std_keywords_re and ! ( @$tokens > 1 and $tokens->[1] eq '(' ) ) { push @lits, [ -LITERAL => [ shift @$tokens ] ]; } } @lits = [ -MISC => [ @lits ] ] if @lits > 1; push @left, @lits; } # compress -LITERAL -MISC and -PLACEHOLDER pieces into a single # -MISC container if (@left > 1) { my $i = 0; while ($#left > $i) { if ($left[$i][0] =~ $compressable_node_re and $left[$i+1][0] =~ $compressable_node_re) { splice @left, $i, 2, [ -MISC => [ map { $_->[0] eq '-MISC' ? @{$_->[1]} : $_ } (@left[$i, $i+1]) ]]; } else { $i++; } } } return @left if $state == PARSE_RHS; # deal with post-fix operators if (@$tokens) { # asc/desc if ($tokens->[0] =~ $asc_desc_re) { @left = [ ('-' . uc (shift @$tokens)) => [ @left ] ]; } } } } sub format_keyword { my ($self, $keyword) = @_; if (my $around = $self->colormap->{lc $keyword}) { $keyword = "$around->[0]$keyword$around->[1]"; } return $keyword } my %starters = ( select => 1, update => 1, 'insert into' => 1, 'delete from' => 1, ); sub pad_keyword { my ($self, $keyword, $depth) = @_; my $before = ''; if (defined $self->indentmap->{lc $keyword}) { $before = $self->newline . $self->indent($depth + $self->indentmap->{lc $keyword}); } $before = '' if $depth == 0 and defined $starters{lc $keyword}; return [$before, '']; } sub indent { ($_[0]->indent_string||'') x ( ( $_[0]->indent_amount || 0 ) * $_[1] ) } sub _is_key { my ($self, $tree) = @_; $tree = $tree->[0] while ref $tree; defined $tree && defined $self->indentmap->{lc $tree}; } sub fill_in_placeholder { my ($self, $bindargs) = @_; if ($self->fill_in_placeholders) { my $val = shift @{$bindargs} || ''; my $quoted = $val =~ s/^(['"])(.*)\1$/$2/; my ($left, $right) = @{$self->placeholder_surround}; $val =~ s/\\/\\\\/g; $val =~ s/'/\\'/g; $val = qq('$val') if $quoted; return qq($left$val$right) } return '?' } # FIXME - terrible name for a user facing API sub unparse { my ($self, $tree, $bindargs) = @_; $self->_unparse($tree, [@{$bindargs||[]}], 0); } sub _unparse { my ($self, $tree, $bindargs, $depth) = @_; if (not $tree or not @$tree) { return ''; } # FIXME - needs a config switch to disable $self->_parenthesis_unroll($tree); my ($op, $args) = @{$tree}[0,1]; if (! defined $op or (! ref $op and ! defined $args) ) { require Data::Dumper; Carp::confess( sprintf ( "Internal error - malformed branch at depth $depth:\n%s", Data::Dumper::Dumper($tree) ) ); } if (ref $op) { return join (' ', map $self->_unparse($_, $bindargs, $depth), @$tree); } elsif ($op eq '-LITERAL') { # literal has different sig return $args->[0]; } elsif ($op eq '-PLACEHOLDER') { return $self->fill_in_placeholder($bindargs); } elsif ($op eq '-PAREN') { return sprintf ('( %s )', join (' ', map { $self->_unparse($_, $bindargs, $depth + 2) } @{$args} ) . ($self->_is_key($args) ? ( $self->newline||'' ) . $self->indent($depth + 1) : '' ) ); } elsif ($op eq 'AND' or $op eq 'OR' or $op =~ $binary_op_re ) { return join (" $op ", map $self->_unparse($_, $bindargs, $depth), @{$args}); } elsif ($op eq '-LIST' ) { return join (', ', map $self->_unparse($_, $bindargs, $depth), @{$args}); } elsif ($op eq '-MISC' ) { return join (' ', map $self->_unparse($_, $bindargs, $depth), @{$args}); } elsif ($op =~ qr/^-(ASC|DESC)$/ ) { my $dir = $1; return join (' ', (map $self->_unparse($_, $bindargs, $depth), @{$args}), $dir); } else { my ($l, $r) = @{$self->pad_keyword($op, $depth)}; my $rhs = $self->_unparse($args, $bindargs, $depth); return sprintf "$l%s$r", join( ( ref $args eq 'ARRAY' and @{$args} == 1 and $args->[0][0] eq '-PAREN' ) ? '' # mysql-- : ' ' , $self->format_keyword($op), (length $rhs ? $rhs : () ), ); } } # All of these keywords allow their parameters to be specified with or without parenthesis without changing the semantics my @unrollable_ops = ( 'ON', 'WHERE', 'GROUP \s+ BY', 'HAVING', 'ORDER \s+ BY', 'I?LIKE', ); my $unrollable_ops_re = join ' | ', @unrollable_ops; $unrollable_ops_re = qr/$unrollable_ops_re/xi; sub _parenthesis_unroll { my $self = shift; my $ast = shift; return unless (ref $ast and ref $ast->[1]); my $changes; do { my @children; $changes = 0; for my $child (@{$ast->[1]}) { # the current node in this loop is *always* a PAREN if (! ref $child or ! @$child or $child->[0] ne '-PAREN') { push @children, $child; next; } my $parent_op = $ast->[0]; # unroll nested parenthesis while ( $parent_op ne 'IN' and @{$child->[1]} == 1 and $child->[1][0][0] eq '-PAREN') { $child = $child->[1][0]; $changes++; } # set to CHILD in the case of PARENT ( CHILD ) # but NOT in the case of PARENT( CHILD1, CHILD2 ) my $single_child_op = (@{$child->[1]} == 1) ? $child->[1][0][0] : ''; my $child_op_argc = $single_child_op ? scalar @{$child->[1][0][1]} : undef; my $single_grandchild_op = ( $child_op_argc||0 == 1 and ref $child->[1][0][1][0] eq 'ARRAY' ) ? $child->[1][0][1][0][0] : '' ; # if the parent operator explicitly allows it AND the child isn't a subselect # nuke the parenthesis if ($parent_op =~ $unrollable_ops_re and $single_child_op ne 'SELECT') { push @children, @{$child->[1]}; $changes++; } # if the parenthesis are wrapped around an AND/OR matching the parent AND/OR - open the parenthesis up and merge the list elsif ( $single_child_op eq $parent_op and ( $parent_op eq 'AND' or $parent_op eq 'OR') ) { push @children, @{$child->[1][0][1]}; $changes++; } # only *ONE* LITERAL or placeholder element # as an AND/OR/NOT argument elsif ( ( $single_child_op eq '-LITERAL' or $single_child_op eq '-PLACEHOLDER' ) and ( $parent_op eq 'AND' or $parent_op eq 'OR' or $parent_op eq 'NOT' ) ) { push @children, @{$child->[1]}; $changes++; } # an AND/OR expression with only one binop in the parenthesis # with exactly two grandchildren # the only time when we can *not* unroll this is when both # the parent and the child are mathops (in which case we'll # break precedence) or when the child is BETWEEN (special # case) elsif ( ($parent_op eq 'AND' or $parent_op eq 'OR') and $single_child_op =~ $binary_op_re and $single_child_op ne 'BETWEEN' and $child_op_argc == 2 and ! ( $single_child_op =~ $alphanum_cmp_op_re and $parent_op =~ $alphanum_cmp_op_re ) ) { push @children, @{$child->[1]}; $changes++; } # a function binds tighter than a mathop - see if our ancestor is a # mathop, and our content is: # a single non-mathop child with a single PAREN grandchild which # would indicate mathop ( nonmathop ( ... ) ) # or a single non-mathop with a single LITERAL ( nonmathop foo ) # or a single non-mathop with a single PLACEHOLDER ( nonmathop ? ) elsif ( $single_child_op and $parent_op =~ $alphanum_cmp_op_re and $single_child_op !~ $alphanum_cmp_op_re and $child_op_argc == 1 and ( $single_grandchild_op eq '-PAREN' or $single_grandchild_op eq '-LITERAL' or $single_grandchild_op eq '-PLACEHOLDER' ) ) { push @children, @{$child->[1]}; $changes++; } # a construct of ... ( somefunc ( ... ) ) ... can safely lose the outer parens # except for the case of ( NOT ( ... ) ) which has already been handled earlier # and except for the case of RNO, where the double are explicit syntax elsif ( $parent_op ne 'ROW_NUMBER() OVER' and $single_child_op and $single_child_op ne 'NOT' and $child_op_argc == 1 and $single_grandchild_op eq '-PAREN' ) { push @children, @{$child->[1]}; $changes++; } # otherwise no more mucking for this pass else { push @children, $child; } } $ast->[1] = \@children; } while ($changes); } sub _strip_asc_from_order_by { my ($self, $ast) = @_; return $ast if ( ref $ast ne 'ARRAY' or $ast->[0] ne 'ORDER BY' ); my $to_replace; if (@{$ast->[1]} == 1 and $ast->[1][0][0] eq '-ASC') { $to_replace = [ $ast->[1][0] ]; } elsif (@{$ast->[1]} == 1 and $ast->[1][0][0] eq '-LIST') { $to_replace = [ grep { $_->[0] eq '-ASC' } @{$ast->[1][0][1]} ]; } @$_ = @{$_->[1][0]} for @$to_replace; $ast; } sub format { my $self = shift; $self->unparse($self->parse($_[0]), $_[1]) } 1; =pod =head1 NAME SQL::Abstract::Tree - Represent SQL as an AST =head1 SYNOPSIS my $sqla_tree = SQL::Abstract::Tree->new({ profile => 'console' }); print $sqla_tree->format('SELECT * FROM foo WHERE foo.a > 2'); # SELECT * # FROM foo # WHERE foo.a > 2 =head1 METHODS =head2 new my $sqla_tree = SQL::Abstract::Tree->new({ profile => 'console' }); $args = { profile => 'console', # predefined profile to use (default: 'none') fill_in_placeholders => 1, # true for placeholder population placeholder_surround => # The strings that will be wrapped around [GREEN, RESET], # populated placeholders if the above is set indent_string => ' ', # the string used when indenting indent_amount => 2, # how many of above string to use for a single # indent level newline => "\n", # string for newline colormap => { select => [RED, RESET], # a pair of strings defining what to surround # the keyword with for colorization # ... }, indentmap => { select => 0, # A zero means that the keyword will start on # a new line from => 1, # Any other positive integer means that after on => 2, # said newline it will get that many indents # ... }, } Returns a new SQL::Abstract::Tree object. All arguments are optional. =head3 profiles There are four predefined profiles, C, C, C, and C. Typically a user will probably just use C or C, but if something about a profile bothers you, merely use the profile and override the parts that you don't like. =head2 format $sqlat->format('SELECT * FROM bar WHERE x = ?', [1]) Takes C<$sql> and C<\@bindargs>. Returns a formatting string based on the string passed in =head2 parse $sqlat->parse('SELECT * FROM bar WHERE x = ?') Returns a "tree" representing passed in SQL. Please do not depend on the structure of the returned tree. It may be stable at some point, but not yet. =head2 unparse $sqlat->unparse($tree_structure, \@bindargs) Transform "tree" into SQL, applying various transforms on the way. =head2 format_keyword $sqlat->format_keyword('SELECT') Currently this just takes a keyword and puts the C stuff around it. Later on it may do more and allow for coderef based transforms. =head2 pad_keyword my ($before, $after) = @{$sqlat->pad_keyword('SELECT')}; Returns whitespace to be inserted around a keyword. =head2 fill_in_placeholder my $value = $sqlat->fill_in_placeholder(\@bindargs) Removes last arg from passed arrayref and returns it, surrounded with the values in placeholder_surround, and then surrounded with single quotes. =head2 indent Returns as many indent strings as indent amounts times the first argument. =head1 ACCESSORS =head2 colormap See L =head2 fill_in_placeholders See L =head2 indent_amount See L =head2 indent_string See L =head2 indentmap See L =head2 newline See L =head2 placeholder_surround See L SQL-Abstract-1.81/lib/SQL/Abstract/Test.pm0000644000175000017500000002511612406777003017373 0ustar rabbitrabbitpackage SQL::Abstract::Test; # see doc at end of file use strict; use warnings; use base qw(Test::Builder::Module Exporter); use Test::Builder; use Test::Deep (); use SQL::Abstract::Tree; our @EXPORT_OK = qw( is_same_sql_bind is_same_sql is_same_bind eq_sql_bind eq_sql eq_bind dumper diag_where $case_sensitive $sql_differ ); my $sqlat = SQL::Abstract::Tree->new; our $case_sensitive = 0; our $parenthesis_significant = 0; our $order_by_asc_significant = 0; our $sql_differ; # keeps track of differing portion between SQLs our $tb = __PACKAGE__->builder; sub _unpack_arrayrefref { my @args; for (1,2) { my $chunk = shift @_; if ( ref $chunk eq 'REF' and ref $$chunk eq 'ARRAY' ) { my ($sql, @bind) = @$$chunk; push @args, ($sql, \@bind); } else { push @args, $chunk, shift @_; } } # maybe $msg and ... stuff push @args, @_; @args; } sub is_same_sql_bind { my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = &_unpack_arrayrefref; # compare my $same_sql = eq_sql($sql1, $sql2); my $same_bind = eq_bind($bind_ref1, $bind_ref2); # call Test::Builder::ok my $ret = $tb->ok($same_sql && $same_bind, $msg); # add debugging info if (!$same_sql) { _sql_differ_diag($sql1, $sql2); } if (!$same_bind) { _bind_differ_diag($bind_ref1, $bind_ref2); } # pass ok() result further return $ret; } sub is_same_sql { my ($sql1, $sql2, $msg) = @_; # compare my $same_sql = eq_sql($sql1, $sql2); # call Test::Builder::ok my $ret = $tb->ok($same_sql, $msg); # add debugging info if (!$same_sql) { _sql_differ_diag($sql1, $sql2); } # pass ok() result further return $ret; } sub is_same_bind { my ($bind_ref1, $bind_ref2, $msg) = @_; # compare my $same_bind = eq_bind($bind_ref1, $bind_ref2); # call Test::Builder::ok my $ret = $tb->ok($same_bind, $msg); # add debugging info if (!$same_bind) { _bind_differ_diag($bind_ref1, $bind_ref2); } # pass ok() result further return $ret; } sub dumper { # FIXME # if we save the instance, we will end up with $VARx references # no time to figure out how to avoid this (Deepcopy is *not* an option) require Data::Dumper; Data::Dumper->new([])->Terse(1)->Indent(1)->Useqq(1)->Deparse(1)->Quotekeys(0)->Sortkeys(1)->Maxdepth(0) ->Values([@_])->Dump; } sub diag_where{ $tb->diag( "Search term:\n" . &dumper ); } sub _sql_differ_diag { my $sql1 = shift || ''; my $sql2 = shift || ''; $tb->${\( $tb->in_todo ? 'note' : 'diag')} ( "SQL expressions differ\n" ." got: $sql1\n" ."want: $sql2\n" ."\nmismatch around\n$sql_differ\n" ); } sub _bind_differ_diag { my ($bind_ref1, $bind_ref2) = @_; $tb->${\( $tb->in_todo ? 'note' : 'diag')} ( "BIND values differ " . dumper({ got => $bind_ref1, want => $bind_ref2 }) ); } sub eq_sql_bind { my ($sql1, $bind_ref1, $sql2, $bind_ref2) = &_unpack_arrayrefref; return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2); } sub eq_bind { goto &Test::Deep::eq_deeply }; sub eq_sql { my ($sql1, $sql2) = @_; # parse my $tree1 = $sqlat->parse($sql1); my $tree2 = $sqlat->parse($sql2); undef $sql_differ; return 1 if _eq_sql($tree1, $tree2); } sub _eq_sql { my ($left, $right) = @_; # one is defined the other not if ( (defined $left) xor (defined $right) ) { $sql_differ = sprintf ("[%s] != [%s]\n", map { defined $_ ? $sqlat->unparse ($_) : 'N/A' } ($left, $right) ); return 0; } # one is undefined, then so is the other elsif (not defined $left) { return 1; } # both are empty elsif (@$left == 0 and @$right == 0) { return 1; } # one is empty if (@$left == 0 or @$right == 0) { $sql_differ = sprintf ("left: %s\nright: %s\n", map { @$_ ? $sqlat->unparse ($_) : 'N/A'} ($left, $right) ); return 0; } # one is a list, the other is an op with a list elsif (ref $left->[0] xor ref $right->[0]) { $sql_differ = sprintf ("[%s] != [%s]\nleft: %s\nright: %s\n", map { ref $_ ? $sqlat->unparse ($_) : $_ } ($left->[0], $right->[0], $left, $right) ); return 0; } # both are lists elsif (ref $left->[0]) { for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) { if (not _eq_sql ($left->[$i], $right->[$i]) ) { if (! $sql_differ or $sql_differ !~ /left\:\s .+ right:\s/xs) { $sql_differ ||= ''; $sql_differ .= "\n" unless $sql_differ =~ /\n\z/; $sql_differ .= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) ); } return 0; } } return 1; } # both are ops else { # unroll parenthesis if possible/allowed unless ( $parenthesis_significant ) { $sqlat->_parenthesis_unroll($_) for $left, $right; } # unroll ASC order by's unless ($order_by_asc_significant) { $sqlat->_strip_asc_from_order_by($_) for $left, $right; } if ( $left->[0] ne $right->[0] ) { $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n", $sqlat->unparse($left), $sqlat->unparse($right) ; return 0; } # literals have a different arg-sig elsif ($left->[0] eq '-LITERAL') { (my $l = " $left->[1][0] " ) =~ s/\s+/ /g; (my $r = " $right->[1][0] ") =~ s/\s+/ /g; my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r); $sql_differ = "[$l] != [$r]\n" if not $eq; return $eq; } # if operators are identical, compare operands else { my $eq = _eq_sql($left->[1], $right->[1]); $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) ) if not $eq; return $eq; } } } sub parse { $sqlat->parse(@_) } 1; __END__ =head1 NAME SQL::Abstract::Test - Helper function for testing SQL::Abstract =head1 SYNOPSIS use SQL::Abstract; use Test::More; use SQL::Abstract::Test import => [qw/ is_same_sql_bind is_same_sql is_same_bind eq_sql_bind eq_sql eq_bind /]; my ($sql, @bind) = SQL::Abstract->new->select(%args); is_same_sql_bind($given_sql, \@given_bind, $expected_sql, \@expected_bind, $test_msg); is_same_sql($given_sql, $expected_sql, $test_msg); is_same_bind(\@given_bind, \@expected_bind, $test_msg); my $is_same = eq_sql_bind($given_sql, \@given_bind, $expected_sql, \@expected_bind); my $sql_same = eq_sql($given_sql, $expected_sql); my $bind_same = eq_bind(\@given_bind, \@expected_bind); =head1 DESCRIPTION This module is only intended for authors of tests on L and related modules; it exports functions for comparing two SQL statements and their bound values. The SQL comparison is performed on I, ignoring differences in spaces or in levels of parentheses. Therefore the tests will pass as long as the semantics is preserved, even if the surface syntax has changed. B : the semantic equivalence handling is pretty limited. A lot of effort goes into distinguishing significant from non-significant parenthesis, including AND/OR operator associativity. Currently this module does not support commutativity and more intelligent transformations like L, etc. For a good overview of what this test framework is currently capable of refer to C =head1 FUNCTIONS =head2 is_same_sql_bind is_same_sql_bind( $given_sql, \@given_bind, $expected_sql, \@expected_bind, $test_msg ); is_same_sql_bind( \[$given_sql, @given_bind], \[$expected_sql, @expected_bind], $test_msg ); is_same_sql_bind( $dbic_rs->as_query $expected_sql, \@expected_bind, $test_msg ); Compares given and expected pairs of C<($sql, \@bind)> by unpacking C<@_> as shown in the examples above and passing the arguments to L and L. Calls L with the combined result, with C<$test_msg> as message. If the test fails, a detailed diagnostic is printed. =head2 is_same_sql is_same_sql( $given_sql, $expected_sql, $test_msg ); Compares given and expected SQL statements via L, and calls L on the result, with C<$test_msg> as message. If the test fails, a detailed diagnostic is printed. =head2 is_same_bind is_same_bind( \@given_bind, \@expected_bind, $test_msg ); Compares given and expected bind values via L, and calls L on the result, with C<$test_msg> as message. If the test fails, a detailed diagnostic is printed. =head2 eq_sql_bind my $is_same = eq_sql_bind( $given_sql, \@given_bind, $expected_sql, \@expected_bind, ); my $is_same = eq_sql_bind( \[$given_sql, @given_bind], \[$expected_sql, @expected_bind], ); my $is_same = eq_sql_bind( $dbic_rs->as_query $expected_sql, \@expected_bind, ); Unpacks C<@_> depending on the given arguments and calls L and L, returning their combined result. =head2 eq_sql my $is_same = eq_sql($given_sql, $expected_sql); Compares the abstract syntax of two SQL statements. Similar to L, but it just returns a boolean value and does not print diagnostics or talk to L. If the result is false, the global variable L will contain the SQL portion where a difference was encountered; this is useful for printing diagnostics. =head2 eq_bind my $is_same = eq_sql(\@given_bind, \@expected_bind); Compares two lists of bind values, taking into account the fact that some of the values may be arrayrefs (see L). Similar to L, but it just returns a boolean value and does not print diagnostics or talk to L. =head1 GLOBAL VARIABLES =head2 $case_sensitive If true, SQL comparisons will be case-sensitive. Default is false; =head2 $parenthesis_significant If true, SQL comparison will preserve and report difference in nested parenthesis. Useful while testing C vs C. Defaults to false; =head2 $order_by_asc_significant If true SQL comparison will consider C and C to be different. Default is false; =head2 $sql_differ When L returns false, the global variable C<$sql_differ> contains the SQL portion where a difference was encountered. =head1 SEE ALSO L, L, L. =head1 AUTHORS Laurent Dami Norbert Buchmuller Peter Rabbitson =head1 COPYRIGHT AND LICENSE Copyright 2008 by Laurent Dami. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. SQL-Abstract-1.81/lib/SQL/Abstract.pm0000644000175000017500000027227112422704640016455 0ustar rabbitrabbitpackage SQL::Abstract; # see doc at end of file use strict; use warnings; use Carp (); use List::Util (); use Scalar::Util (); use Exporter 'import'; our @EXPORT_OK = qw(is_plain_value is_literal_value); BEGIN { if ($] < 5.009_005) { require MRO::Compat; } else { require mro; } *SQL::Abstract::_ENV_::DETECT_AUTOGENERATED_STRINGIFICATION = $ENV{SQLA_ISVALUE_IGNORE_AUTOGENERATED_STRINGIFICATION} ? sub () { 0 } : sub () { 1 } ; } #====================================================================== # GLOBALS #====================================================================== our $VERSION = '1.81'; # This would confuse some packagers $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases our $AUTOLOAD; # special operators (-in, -between). May be extended/overridden by user. # See section WHERE: BUILTIN SPECIAL OPERATORS below for implementation my @BUILTIN_SPECIAL_OPS = ( {regex => qr/^ (?: not \s )? between $/ix, handler => '_where_field_BETWEEN'}, {regex => qr/^ (?: not \s )? in $/ix, handler => '_where_field_IN'}, {regex => qr/^ ident $/ix, handler => '_where_op_IDENT'}, {regex => qr/^ value $/ix, handler => '_where_op_VALUE'}, {regex => qr/^ is (?: \s+ not )? $/ix, handler => '_where_field_IS'}, ); # unaryish operators - key maps to handler my @BUILTIN_UNARY_OPS = ( # the digits are backcompat stuff { regex => qr/^ and (?: [_\s]? \d+ )? $/xi, handler => '_where_op_ANDOR' }, { regex => qr/^ or (?: [_\s]? \d+ )? $/xi, handler => '_where_op_ANDOR' }, { regex => qr/^ nest (?: [_\s]? \d+ )? $/xi, handler => '_where_op_NEST' }, { regex => qr/^ (?: not \s )? bool $/xi, handler => '_where_op_BOOL' }, { regex => qr/^ ident $/xi, handler => '_where_op_IDENT' }, { regex => qr/^ value $/xi, handler => '_where_op_VALUE' }, ); #====================================================================== # DEBUGGING AND ERROR REPORTING #====================================================================== sub _debug { return unless $_[0]->{debug}; shift; # a little faster my $func = (caller(1))[3]; warn "[$func] ", @_, "\n"; } sub belch (@) { my($func) = (caller(1))[3]; Carp::carp "[$func] Warning: ", @_; } sub puke (@) { my($func) = (caller(1))[3]; Carp::croak "[$func] Fatal: ", @_; } sub is_literal_value ($) { ref $_[0] eq 'SCALAR' ? [ ${$_[0]} ] : ( ref $_[0] eq 'REF' and ref ${$_[0]} eq 'ARRAY' ) ? [ @${ $_[0] } ] : undef; } # FIXME XSify - this can be done so much more efficiently sub is_plain_value ($) { no strict 'refs'; ! length ref $_[0] ? \($_[0]) : ( ref $_[0] eq 'HASH' and keys %{$_[0]} == 1 and exists $_[0]->{-value} ) ? \($_[0]->{-value}) : ( # reuse @_ for even moar speedz defined ( $_[1] = Scalar::Util::blessed $_[0] ) and # deliberately not using Devel::OverloadInfo - the checks we are # intersted in are much more limited than the fullblown thing, and # this is a very hot piece of code ( # simply using ->can('(""') can leave behind stub methods that # break actually using the overload later (see L and the source of overload::mycan()) # # either has stringification which DBI SHOULD prefer out of the box grep { *{ (qq[${_}::(""]) }{CODE} } @{ $_[2] = mro::get_linear_isa( $_[1] ) } or # has nummification or boolification, AND fallback is *not* disabled ( SQL::Abstract::_ENV_::DETECT_AUTOGENERATED_STRINGIFICATION and ( grep { *{"${_}::(0+"}{CODE} } @{$_[2]} or grep { *{"${_}::(bool"}{CODE} } @{$_[2]} ) and ( # no fallback specified at all ! ( ($_[3]) = grep { *{"${_}::()"}{CODE} } @{$_[2]} ) or # fallback explicitly undef ! defined ${"$_[3]::()"} or # explicitly true !! ${"$_[3]::()"} ) ) ) ) ? \($_[0]) : undef; } #====================================================================== # NEW #====================================================================== sub new { my $self = shift; my $class = ref($self) || $self; my %opt = (ref $_[0] eq 'HASH') ? %{$_[0]} : @_; # choose our case by keeping an option around delete $opt{case} if $opt{case} && $opt{case} ne 'lower'; # default logic for interpreting arrayrefs $opt{logic} = $opt{logic} ? uc $opt{logic} : 'OR'; # how to return bind vars $opt{bindtype} ||= 'normal'; # default comparison is "=", but can be overridden $opt{cmp} ||= '='; # try to recognize which are the 'equality' and 'inequality' ops # (temporary quickfix (in 2007), should go through a more seasoned API) $opt{equality_op} = qr/^( \Q$opt{cmp}\E | \= )$/ix; $opt{inequality_op} = qr/^( != | <> )$/ix; $opt{like_op} = qr/^ (is\s+)? r?like $/xi; $opt{not_like_op} = qr/^ (is\s+)? not \s+ r?like $/xi; # SQL booleans $opt{sqltrue} ||= '1=1'; $opt{sqlfalse} ||= '0=1'; # special operators $opt{special_ops} ||= []; # regexes are applied in order, thus push after user-defines push @{$opt{special_ops}}, @BUILTIN_SPECIAL_OPS; # unary operators $opt{unary_ops} ||= []; push @{$opt{unary_ops}}, @BUILTIN_UNARY_OPS; # rudimentary sanity-check for user supplied bits treated as functions/operators # If a purported function matches this regular expression, an exception is thrown. # Literal SQL is *NOT* subject to this check, only functions (and column names # when quoting is not in effect) # FIXME # need to guard against ()'s in column names too, but this will break tons of # hacks... ideas anyone? $opt{injection_guard} ||= qr/ \; | ^ \s* go \s /xmi; return bless \%opt, $class; } sub _assert_pass_injection_guard { if ($_[1] =~ $_[0]->{injection_guard}) { my $class = ref $_[0]; puke "Possible SQL injection attempt '$_[1]'. If this is indeed a part of the " . "desired SQL use literal SQL ( \'...' or \[ '...' ] ) or supply your own " . "{injection_guard} attribute to ${class}->new()" } } #====================================================================== # INSERT methods #====================================================================== sub insert { my $self = shift; my $table = $self->_table(shift); my $data = shift || return; my $options = shift; my $method = $self->_METHOD_FOR_refkind("_insert", $data); my ($sql, @bind) = $self->$method($data); $sql = join " ", $self->_sqlcase('insert into'), $table, $sql; if ($options->{returning}) { my ($s, @b) = $self->_insert_returning ($options); $sql .= $s; push @bind, @b; } return wantarray ? ($sql, @bind) : $sql; } sub _insert_returning { my ($self, $options) = @_; my $f = $options->{returning}; my $fieldlist = $self->_SWITCH_refkind($f, { ARRAYREF => sub {join ', ', map { $self->_quote($_) } @$f;}, SCALAR => sub {$self->_quote($f)}, SCALARREF => sub {$$f}, }); return $self->_sqlcase(' returning ') . $fieldlist; } sub _insert_HASHREF { # explicit list of fields and then values my ($self, $data) = @_; my @fields = sort keys %$data; my ($sql, @bind) = $self->_insert_values($data); # assemble SQL $_ = $self->_quote($_) foreach @fields; $sql = "( ".join(", ", @fields).") ".$sql; return ($sql, @bind); } sub _insert_ARRAYREF { # just generate values(?,?) part (no list of fields) my ($self, $data) = @_; # no names (arrayref) so can't generate bindtype $self->{bindtype} ne 'columns' or belch "can't do 'columns' bindtype when called with arrayref"; # fold the list of values into a hash of column name - value pairs # (where the column names are artificially generated, and their # lexicographical ordering keep the ordering of the original list) my $i = "a"; # incremented values will be in lexicographical order my $data_in_hash = { map { ($i++ => $_) } @$data }; return $self->_insert_values($data_in_hash); } sub _insert_ARRAYREFREF { # literal SQL with bind my ($self, $data) = @_; my ($sql, @bind) = @${$data}; $self->_assert_bindval_matches_bindtype(@bind); return ($sql, @bind); } sub _insert_SCALARREF { # literal SQL without bind my ($self, $data) = @_; return ($$data); } sub _insert_values { 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}) { # if array datatype are activated push @values, '?'; push @all_bind, $self->_bindtype($column, $v); } else { # else 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 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')." ( ".join(", ", @values)." )"; return ($sql, @all_bind); } #====================================================================== # UPDATE methods #====================================================================== sub update { 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); 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}) { # array datatype 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; 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 ') . 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; } #====================================================================== # SELECT #====================================================================== sub select { my $self = shift; my $table = $self->_table(shift); my $fields = shift || '*'; my $where = shift; my $order = shift; my($where_sql, @bind) = $self->where($where, $order); my $f = (ref $fields eq 'ARRAY') ? join ', ', map { $self->_quote($_) } @$fields : $fields; my $sql = join(' ', $self->_sqlcase('select'), $f, $self->_sqlcase('from'), $table) . $where_sql; return wantarray ? ($sql, @bind) : $sql; } #====================================================================== # DELETE #====================================================================== sub delete { my $self = shift; my $table = $self->_table(shift); my $where = shift; my($where_sql, @bind) = $self->where($where); my $sql = $self->_sqlcase('delete from') . " $table" . $where_sql; return wantarray ? ($sql, @bind) : $sql; } #====================================================================== # WHERE: entry point #====================================================================== # Finally, a separate routine just to handle WHERE clauses sub where { my ($self, $where, $order) = @_; # where ? my ($sql, @bind) = $self->_recurse_where($where); $sql = $sql ? $self->_sqlcase(' where ') . "( $sql )" : ''; # order by? if ($order) { $sql .= $self->_order_by($order); } return wantarray ? ($sql, @bind) : $sql; } sub _recurse_where { my ($self, $where, $logic) = @_; # dispatch on appropriate method according to refkind of $where my $method = $self->_METHOD_FOR_refkind("_where", $where); my ($sql, @bind) = $self->$method($where, $logic); # DBIx::Class used to call _recurse_where in scalar context # something else might too... if (wantarray) { return ($sql, @bind); } else { belch "Calling _recurse_where in scalar context is deprecated and will go away before 2.0"; return $sql; } } #====================================================================== # WHERE: top-level ARRAYREF #====================================================================== sub _where_ARRAYREF { my ($self, $where, $logic) = @_; $logic = uc($logic || $self->{logic}); $logic eq 'AND' or $logic eq 'OR' or puke "unknown logic: $logic"; my @clauses = @$where; my (@sql_clauses, @all_bind); # need to use while() so can shift() for pairs while (@clauses) { my $el = shift @clauses; $el = undef if (defined $el and ! length $el); # switch according to kind of $el and get corresponding ($sql, @bind) my ($sql, @bind) = $self->_SWITCH_refkind($el, { # skip empty elements, otherwise get invalid trailing AND stuff ARRAYREF => sub {$self->_recurse_where($el) if @$el}, ARRAYREFREF => sub { my ($s, @b) = @$$el; $self->_assert_bindval_matches_bindtype(@b); ($s, @b); }, HASHREF => sub {$self->_recurse_where($el, 'and') if %$el}, SCALARREF => sub { ($$el); }, SCALAR => sub { # top-level arrayref with scalars, recurse in pairs $self->_recurse_where({$el => shift(@clauses)}) }, UNDEF => sub {puke "Supplying an empty left hand side argument is not supported in array-pairs" }, }); if ($sql) { push @sql_clauses, $sql; push @all_bind, @bind; } } return $self->_join_sql_clauses($logic, \@sql_clauses, \@all_bind); } #====================================================================== # WHERE: top-level ARRAYREFREF #====================================================================== sub _where_ARRAYREFREF { my ($self, $where) = @_; my ($sql, @bind) = @$$where; $self->_assert_bindval_matches_bindtype(@bind); return ($sql, @bind); } #====================================================================== # WHERE: top-level HASHREF #====================================================================== sub _where_HASHREF { my ($self, $where) = @_; my (@sql_clauses, @all_bind); for my $k (sort keys %$where) { my $v = $where->{$k}; # ($k => $v) is either a special unary op or a regular hashpair my ($sql, @bind) = do { if ($k =~ /^-./) { # put the operator in canonical form my $op = $k; $op = substr $op, 1; # remove initial dash $op =~ s/^\s+|\s+$//g;# remove leading/trailing space $op =~ s/\s+/ /g; # compress whitespace # so that -not_foo works correctly $op =~ s/^not_/NOT /i; $self->_debug("Unary OP(-$op) within hashref, recursing..."); my ($s, @b) = $self->_where_unary_op ($op, $v); # top level vs nested # we assume that handled unary ops will take care of their ()s $s = "($s)" unless ( List::Util::first {$op =~ $_->{regex}} @{$self->{unary_ops}} or ( defined $self->{_nested_func_lhs} and $self->{_nested_func_lhs} eq $k ) ); ($s, @b); } else { if (! length $k) { if (is_literal_value ($v) ) { belch 'Hash-pairs consisting of an empty string with a literal are deprecated, and will be removed in 2.0: use -and => [ $literal ] instead'; } else { puke "Supplying an empty left hand side argument is not supported in hash-pairs"; } } my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $v); $self->$method($k, $v); } }; push @sql_clauses, $sql; push @all_bind, @bind; } return $self->_join_sql_clauses('and', \@sql_clauses, \@all_bind); } sub _where_unary_op { my ($self, $op, $rhs) = @_; # top level special ops are illegal in general # this includes the -ident/-value ops (dual purpose unary and special) puke "Illegal use of top-level '-$op'" if ! defined $self->{_nested_func_lhs} and List::Util::first {$op =~ $_->{regex}} @{$self->{special_ops}}; if (my $op_entry = List::Util::first {$op =~ $_->{regex}} @{$self->{unary_ops}}) { my $handler = $op_entry->{handler}; if (not ref $handler) { if ($op =~ s/ [_\s]? \d+ $//x ) { belch 'Use of [and|or|nest]_N modifiers is deprecated and will be removed in SQLA v2.0. ' . "You probably wanted ...-and => [ -$op => COND1, -$op => COND2 ... ]"; } return $self->$handler ($op, $rhs); } elsif (ref $handler eq 'CODE') { return $handler->($self, $op, $rhs); } else { puke "Illegal handler for operator $op - expecting a method name or a coderef"; } } $self->_debug("Generic unary OP: $op - recursing as function"); $self->_assert_pass_injection_guard($op); my ($sql, @bind) = $self->_SWITCH_refkind ($rhs, { SCALAR => sub { puke "Illegal use of top-level '-$op'" unless defined $self->{_nested_func_lhs}; return ( $self->_convert('?'), $self->_bindtype($self->{_nested_func_lhs}, $rhs) ); }, FALLBACK => sub { $self->_recurse_where ($rhs) }, }); $sql = sprintf ('%s %s', $self->_sqlcase($op), $sql, ); return ($sql, @bind); } sub _where_op_ANDOR { my ($self, $op, $v) = @_; $self->_SWITCH_refkind($v, { ARRAYREF => sub { return $self->_where_ARRAYREF($v, $op); }, HASHREF => sub { return ( $op =~ /^or/i ) ? $self->_where_ARRAYREF( [ map { $_ => $v->{$_} } ( sort keys %$v ) ], $op ) : $self->_where_HASHREF($v); }, SCALARREF => sub { puke "-$op => \\\$scalar makes little sense, use " . ($op =~ /^or/i ? '[ \$scalar, \%rest_of_conditions ] instead' : '-and => [ \$scalar, \%rest_of_conditions ] instead' ); }, ARRAYREFREF => sub { puke "-$op => \\[...] makes little sense, use " . ($op =~ /^or/i ? '[ \[...], \%rest_of_conditions ] instead' : '-and => [ \[...], \%rest_of_conditions ] instead' ); }, SCALAR => sub { # permissively interpreted as SQL puke "-$op => \$value makes little sense, use -bool => \$value instead"; }, UNDEF => sub { puke "-$op => undef not supported"; }, }); } sub _where_op_NEST { my ($self, $op, $v) = @_; $self->_SWITCH_refkind($v, { SCALAR => sub { # permissively interpreted as SQL belch "literal SQL should be -nest => \\'scalar' " . "instead of -nest => 'scalar' "; return ($v); }, UNDEF => sub { puke "-$op => undef not supported"; }, FALLBACK => sub { $self->_recurse_where ($v); }, }); } sub _where_op_BOOL { my ($self, $op, $v) = @_; my ($s, @b) = $self->_SWITCH_refkind($v, { SCALAR => sub { # interpreted as SQL column $self->_convert($self->_quote($v)); }, UNDEF => sub { puke "-$op => undef not supported"; }, FALLBACK => sub { $self->_recurse_where ($v); }, }); $s = "(NOT $s)" if $op =~ /^not/i; ($s, @b); } sub _where_op_IDENT { my $self = shift; my ($op, $rhs) = splice @_, -2; if (! defined $rhs or length ref $rhs) { puke "-$op requires a single plain scalar argument (a quotable identifier)"; } # in case we are called as a top level special op (no '=') my $lhs = shift; $_ = $self->_convert($self->_quote($_)) for ($lhs, $rhs); return $lhs ? "$lhs = $rhs" : $rhs ; } sub _where_op_VALUE { my $self = shift; my ($op, $rhs) = splice @_, -2; # in case we are called as a top level special op (no '=') my $lhs = shift; # special-case NULL if (! defined $rhs) { return defined $lhs ? $self->_convert($self->_quote($lhs)) . ' IS NULL' : undef ; } my @bind = $self->_bindtype ( ( defined $lhs ? $lhs : $self->{_nested_func_lhs} ), $rhs, ) ; return $lhs ? ( $self->_convert($self->_quote($lhs)) . ' = ' . $self->_convert('?'), @bind ) : ( $self->_convert('?'), @bind, ) ; } sub _where_hashpair_ARRAYREF { my ($self, $k, $v) = @_; if( @$v ) { my @v = @$v; # need copy because of shift below $self->_debug("ARRAY($k) means distribute over elements"); # put apart first element if it is an operator (-and, -or) my $op = ( (defined $v[0] && $v[0] =~ /^ - (?: AND|OR ) $/ix) ? shift @v : '' ); my @distributed = map { {$k => $_} } @v; if ($op) { $self->_debug("OP($op) reinjected into the distributed array"); unshift @distributed, $op; } my $logic = $op ? substr($op, 1) : ''; return $self->_recurse_where(\@distributed, $logic); } else { $self->_debug("empty ARRAY($k) means 0=1"); return ($self->{sqlfalse}); } } sub _where_hashpair_HASHREF { my ($self, $k, $v, $logic) = @_; $logic ||= 'and'; local $self->{_nested_func_lhs} = defined $self->{_nested_func_lhs} ? $self->{_nested_func_lhs} : $k ; my ($all_sql, @all_bind); for my $orig_op (sort keys %$v) { my $val = $v->{$orig_op}; # put the operator in canonical form my $op = $orig_op; # FIXME - we need to phase out dash-less ops $op =~ s/^-//; # remove possible initial dash $op =~ s/^\s+|\s+$//g;# remove leading/trailing space $op =~ s/\s+/ /g; # compress whitespace $self->_assert_pass_injection_guard($op); # fixup is_not $op =~ s/^is_not/IS NOT/i; # so that -not_foo works correctly $op =~ s/^not_/NOT /i; # another retarded special case: foo => { $op => { -value => undef } } if (ref $val eq 'HASH' and keys %$val == 1 and exists $val->{-value} and ! defined $val->{-value} ) { $val = undef; } my ($sql, @bind); # CASE: col-value logic modifiers if ( $orig_op =~ /^ \- (and|or) $/xi ) { ($sql, @bind) = $self->_where_hashpair_HASHREF($k, $val, $1); } # CASE: special operators like -in or -between elsif ( my $special_op = List::Util::first {$op =~ $_->{regex}} @{$self->{special_ops}} ) { my $handler = $special_op->{handler}; if (! $handler) { puke "No handler supplied for special operator $orig_op"; } elsif (not ref $handler) { ($sql, @bind) = $self->$handler ($k, $op, $val); } elsif (ref $handler eq 'CODE') { ($sql, @bind) = $handler->($self, $k, $op, $val); } else { puke "Illegal handler for special operator $orig_op - expecting a method name or a coderef"; } } else { $self->_SWITCH_refkind($val, { ARRAYREF => sub { # CASE: col => {op => \@vals} ($sql, @bind) = $self->_where_field_op_ARRAYREF($k, $op, $val); }, ARRAYREFREF => sub { # CASE: col => {op => \[$sql, @bind]} (literal SQL with bind) my ($sub_sql, @sub_bind) = @$$val; $self->_assert_bindval_matches_bindtype(@sub_bind); $sql = join ' ', $self->_convert($self->_quote($k)), $self->_sqlcase($op), $sub_sql; @bind = @sub_bind; }, UNDEF => sub { # CASE: col => {op => undef} : sql "IS (NOT)? NULL" my $is = $op =~ /^not$/i ? 'is not' # legacy : $op =~ $self->{equality_op} ? 'is' : $op =~ $self->{like_op} ? belch("Supplying an undefined argument to '@{[ uc $op]}' is deprecated") && 'is' : $op =~ $self->{inequality_op} ? 'is not' : $op =~ $self->{not_like_op} ? belch("Supplying an undefined argument to '@{[ uc $op]}' is deprecated") && 'is not' : puke "unexpected operator '$orig_op' with undef operand"; $sql = $self->_quote($k) . $self->_sqlcase(" $is null"); }, FALLBACK => sub { # CASE: col => {op/func => $stuff} ($sql, @bind) = $self->_where_unary_op ($op, $val); $sql = join (' ', $self->_convert($self->_quote($k)), $self->{_nested_func_lhs} eq $k ? $sql : "($sql)", # top level vs nested ); }, }); } ($all_sql) = (defined $all_sql and $all_sql) ? $self->_join_sql_clauses($logic, [$all_sql, $sql], []) : $sql; push @all_bind, @bind; } return ($all_sql, @all_bind); } sub _where_field_IS { my ($self, $k, $op, $v) = @_; my ($s) = $self->_SWITCH_refkind($v, { UNDEF => sub { join ' ', $self->_convert($self->_quote($k)), map { $self->_sqlcase($_)} ($op, 'null') }, FALLBACK => sub { puke "$op can only take undef as argument"; }, }); $s; } sub _where_field_op_ARRAYREF { my ($self, $k, $op, $vals) = @_; my @vals = @$vals; #always work on a copy if(@vals) { $self->_debug(sprintf '%s means multiple elements: [ %s ]', $vals, join (', ', map { defined $_ ? "'$_'" : 'NULL' } @vals ), ); # see if the first element is an -and/-or op my $logic; if (defined $vals[0] && $vals[0] =~ /^ - ( AND|OR ) $/ix) { $logic = uc $1; shift @vals; } # a long standing API wart - an attempt to change this behavior during # the 1.50 series failed *spectacularly*. Warn instead and leave the # behavior as is if ( @vals > 1 and (!$logic or $logic eq 'OR') and ( $op =~ $self->{inequality_op} or $op =~ $self->{not_like_op} ) ) { my $o = uc($op); belch "A multi-element arrayref as an argument to the inequality op '$o' " . 'is technically equivalent to an always-true 1=1 (you probably wanted ' . "to say ...{ \$inequality_op => [ -and => \@values ] }... instead)" ; } # distribute $op over each remaining member of @vals, append logic if exists return $self->_recurse_where([map { {$k => {$op, $_}} } @vals], $logic); } else { # try to DWIM on equality operators return $op =~ $self->{equality_op} ? $self->{sqlfalse} : $op =~ $self->{like_op} ? belch("Supplying an empty arrayref to '@{[ uc $op]}' is deprecated") && $self->{sqlfalse} : $op =~ $self->{inequality_op} ? $self->{sqltrue} : $op =~ $self->{not_like_op} ? belch("Supplying an empty arrayref to '@{[ uc $op]}' is deprecated") && $self->{sqltrue} : puke "operator '$op' applied on an empty array (field '$k')"; } } sub _where_hashpair_SCALARREF { my ($self, $k, $v) = @_; $self->_debug("SCALAR($k) means literal SQL: $$v"); my $sql = $self->_quote($k) . " " . $$v; return ($sql); } # literal SQL with bind sub _where_hashpair_ARRAYREFREF { my ($self, $k, $v) = @_; $self->_debug("REF($k) means literal SQL: @${$v}"); my ($sql, @bind) = @$$v; $self->_assert_bindval_matches_bindtype(@bind); $sql = $self->_quote($k) . " " . $sql; return ($sql, @bind ); } # literal SQL without bind sub _where_hashpair_SCALAR { my ($self, $k, $v) = @_; $self->_debug("NOREF($k) means simple key=val: $k $self->{cmp} $v"); my $sql = join ' ', $self->_convert($self->_quote($k)), $self->_sqlcase($self->{cmp}), $self->_convert('?'); my @bind = $self->_bindtype($k, $v); return ( $sql, @bind); } sub _where_hashpair_UNDEF { my ($self, $k, $v) = @_; $self->_debug("UNDEF($k) means IS NULL"); my $sql = $self->_quote($k) . $self->_sqlcase(' is null'); return ($sql); } #====================================================================== # WHERE: TOP-LEVEL OTHERS (SCALARREF, SCALAR, UNDEF) #====================================================================== sub _where_SCALARREF { my ($self, $where) = @_; # literal sql $self->_debug("SCALAR(*top) means literal SQL: $$where"); return ($$where); } sub _where_SCALAR { my ($self, $where) = @_; # literal sql $self->_debug("NOREF(*top) means literal SQL: $where"); return ($where); } sub _where_UNDEF { my ($self) = @_; return (); } #====================================================================== # WHERE: BUILTIN SPECIAL OPERATORS (-in, -between) #====================================================================== sub _where_field_BETWEEN { my ($self, $k, $op, $vals) = @_; my ($label, $and, $placeholder); $label = $self->_convert($self->_quote($k)); $and = ' ' . $self->_sqlcase('and') . ' '; $placeholder = $self->_convert('?'); $op = $self->_sqlcase($op); my $invalid_args = "Operator '$op' requires either an arrayref with two defined values or expressions, or a single literal scalarref/arrayref-ref"; my ($clause, @bind) = $self->_SWITCH_refkind($vals, { ARRAYREFREF => sub { my ($s, @b) = @$$vals; $self->_assert_bindval_matches_bindtype(@b); ($s, @b); }, SCALARREF => sub { return $$vals; }, ARRAYREF => sub { puke $invalid_args if @$vals != 2; my (@all_sql, @all_bind); foreach my $val (@$vals) { my ($sql, @bind) = $self->_SWITCH_refkind($val, { SCALAR => sub { return ($placeholder, $self->_bindtype($k, $val) ); }, SCALARREF => sub { return $$val; }, ARRAYREFREF => sub { my ($sql, @bind) = @$$val; $self->_assert_bindval_matches_bindtype(@bind); return ($sql, @bind); }, HASHREF => sub { my ($func, $arg, @rest) = %$val; puke ("Only simple { -func => arg } functions accepted as sub-arguments to BETWEEN") if (@rest or $func !~ /^ \- (.+)/x); $self->_where_unary_op ($1 => $arg); }, FALLBACK => sub { puke $invalid_args, }, }); push @all_sql, $sql; push @all_bind, @bind; } return ( (join $and, @all_sql), @all_bind ); }, FALLBACK => sub { puke $invalid_args, }, }); my $sql = "( $label $op $clause )"; return ($sql, @bind) } sub _where_field_IN { my ($self, $k, $op, $vals) = @_; # backwards compatibility : if scalar, force into an arrayref $vals = [$vals] if defined $vals && ! ref $vals; my ($label) = $self->_convert($self->_quote($k)); my ($placeholder) = $self->_convert('?'); $op = $self->_sqlcase($op); my ($sql, @bind) = $self->_SWITCH_refkind($vals, { ARRAYREF => sub { # list of choices if (@$vals) { # nonempty list my (@all_sql, @all_bind); for my $val (@$vals) { my ($sql, @bind) = $self->_SWITCH_refkind($val, { SCALAR => sub { return ($placeholder, $val); }, SCALARREF => sub { return $$val; }, ARRAYREFREF => sub { my ($sql, @bind) = @$$val; $self->_assert_bindval_matches_bindtype(@bind); return ($sql, @bind); }, HASHREF => sub { my ($func, $arg, @rest) = %$val; puke ("Only simple { -func => arg } functions accepted as sub-arguments to IN") if (@rest or $func !~ /^ \- (.+)/x); $self->_where_unary_op ($1 => $arg); }, UNDEF => sub { puke( 'SQL::Abstract before v1.75 used to generate incorrect SQL when the ' . "-$op operator was given an undef-containing list: !!!AUDIT YOUR CODE " . 'AND DATA!!! (the upcoming Data::Query-based version of SQL::Abstract ' . 'will emit the logically correct SQL instead of raising this exception)' ); }, }); push @all_sql, $sql; push @all_bind, @bind; } return ( sprintf ('%s %s ( %s )', $label, $op, join (', ', @all_sql) ), $self->_bindtype($k, @all_bind), ); } else { # empty list : some databases won't understand "IN ()", so DWIM my $sql = ($op =~ /\bnot\b/i) ? $self->{sqltrue} : $self->{sqlfalse}; return ($sql); } }, SCALARREF => sub { # literal SQL my $sql = $self->_open_outer_paren ($$vals); return ("$label $op ( $sql )"); }, ARRAYREFREF => sub { # literal SQL with bind my ($sql, @bind) = @$$vals; $self->_assert_bindval_matches_bindtype(@bind); $sql = $self->_open_outer_paren ($sql); return ("$label $op ( $sql )", @bind); }, UNDEF => sub { puke "Argument passed to the '$op' operator can not be undefined"; }, FALLBACK => sub { puke "special op $op requires an arrayref (or scalarref/arrayref-ref)"; }, }); return ($sql, @bind); } # Some databases (SQLite) treat col IN (1, 2) different from # col IN ( (1, 2) ). Use this to strip all outer parens while # adding them back in the corresponding method sub _open_outer_paren { my ($self, $sql) = @_; while ( my ($inner) = $sql =~ /^ \s* \( (.*) \) \s* $/xs ) { # there are closing parens inside, need the heavy duty machinery # to reevaluate the extraction starting from $sql (full reevaluation) if ( $inner =~ /\)/ ) { require Text::Balanced; my (undef, $remainder) = do { # idiotic design - writes to $@ but *DOES NOT* throw exceptions local $@; Text::Balanced::extract_bracketed( $sql, '()', qr/\s*/ ); }; # the entire expression needs to be a balanced bracketed thing # (after an extract no remainder sans trailing space) last if defined $remainder and $remainder =~ /\S/; } $sql = $inner; } $sql; } #====================================================================== # ORDER BY #====================================================================== sub _order_by { my ($self, $arg) = @_; my (@sql, @bind); for my $c ($self->_order_by_chunks ($arg) ) { $self->_SWITCH_refkind ($c, { SCALAR => sub { push @sql, $c }, ARRAYREF => sub { push @sql, shift @$c; push @bind, @$c }, }); } my $sql = @sql ? sprintf ('%s %s', $self->_sqlcase(' order by'), join (', ', @sql) ) : '' ; return wantarray ? ($sql, @bind) : $sql; } sub _order_by_chunks { my ($self, $arg) = @_; return $self->_SWITCH_refkind($arg, { ARRAYREF => sub { map { $self->_order_by_chunks ($_ ) } @$arg; }, ARRAYREFREF => sub { my ($s, @b) = @$$arg; $self->_assert_bindval_matches_bindtype(@b); [ $s, @b ]; }, SCALAR => sub {$self->_quote($arg)}, UNDEF => sub {return () }, SCALARREF => sub {$$arg}, # literal SQL, no quoting HASHREF => sub { # get first pair in hash my ($key, $val, @rest) = %$arg; return () unless $key; if ( @rest or not $key =~ /^-(desc|asc)/i ) { puke "hash passed to _order_by must have exactly one key (-desc or -asc)"; } my $direction = $1; my @ret; for my $c ($self->_order_by_chunks ($val)) { my ($sql, @bind); $self->_SWITCH_refkind ($c, { SCALAR => sub { $sql = $c; }, ARRAYREF => sub { ($sql, @bind) = @$c; }, }); $sql = $sql . ' ' . $self->_sqlcase($direction); push @ret, [ $sql, @bind]; } return @ret; }, }); } #====================================================================== # DATASOURCE (FOR NOW, JUST PLAIN TABLE OR LIST OF TABLES) #====================================================================== sub _table { my $self = shift; my $from = shift; $self->_SWITCH_refkind($from, { ARRAYREF => sub {join ', ', map { $self->_quote($_) } @$from;}, SCALAR => sub {$self->_quote($from)}, SCALARREF => sub {$$from}, }); } #====================================================================== # UTILITY FUNCTIONS #====================================================================== # highly optimized, as it's called way too often sub _quote { # my ($self, $label) = @_; return '' unless defined $_[1]; return ${$_[1]} if ref($_[1]) eq 'SCALAR'; unless ($_[0]->{quote_char}) { $_[0]->_assert_pass_injection_guard($_[1]); return $_[1]; } my $qref = ref $_[0]->{quote_char}; my ($l, $r); if (!$qref) { ($l, $r) = ( $_[0]->{quote_char}, $_[0]->{quote_char} ); } elsif ($qref eq 'ARRAY') { ($l, $r) = @{$_[0]->{quote_char}}; } else { puke "Unsupported quote_char format: $_[0]->{quote_char}"; } my $esc = $_[0]->{escape_char} || $r; # parts containing * are naturally unquoted return join( $_[0]->{name_sep}||'', map { $_ eq '*' ? $_ : do { (my $n = $_) =~ s/(\Q$esc\E|\Q$r\E)/$esc$1/g; $l . $n . $r } } ( $_[0]->{name_sep} ? split (/\Q$_[0]->{name_sep}\E/, $_[1] ) : $_[1] ) ); } # Conversion, if applicable sub _convert ($) { #my ($self, $arg) = @_; if ($_[0]->{convert}) { return $_[0]->_sqlcase($_[0]->{convert}) .'(' . $_[1] . ')'; } return $_[1]; } # And bindtype sub _bindtype (@) { #my ($self, $col, @vals) = @_; # called often - tighten code return $_[0]->{bindtype} eq 'columns' ? map {[$_[1], $_]} @_[2 .. $#_] : @_[2 .. $#_] ; } # Dies if any element of @bind is not in [colname => value] format # if bindtype is 'columns'. sub _assert_bindval_matches_bindtype { # my ($self, @bind) = @_; my $self = shift; if ($self->{bindtype} eq 'columns') { for (@_) { if (!defined $_ || ref($_) ne 'ARRAY' || @$_ != 2) { puke "bindtype 'columns' selected, you need to pass: [column_name => bind_value]" } } } } sub _join_sql_clauses { my ($self, $logic, $clauses_aref, $bind_aref) = @_; if (@$clauses_aref > 1) { my $join = " " . $self->_sqlcase($logic) . " "; my $sql = '( ' . join($join, @$clauses_aref) . ' )'; return ($sql, @$bind_aref); } elsif (@$clauses_aref) { return ($clauses_aref->[0], @$bind_aref); # no parentheses } else { return (); # if no SQL, ignore @$bind_aref } } # Fix SQL case, if so requested sub _sqlcase { # LDNOTE: if $self->{case} is true, then it contains 'lower', so we # don't touch the argument ... crooked logic, but let's not change it! return $_[0]->{case} ? $_[1] : uc($_[1]); } #====================================================================== # DISPATCHING FROM REFKIND #====================================================================== sub _refkind { my ($self, $data) = @_; return 'UNDEF' unless defined $data; # blessed objects are treated like scalars my $ref = (Scalar::Util::blessed $data) ? '' : ref $data; return 'SCALAR' unless $ref; my $n_steps = 1; while ($ref eq 'REF') { $data = $$data; $ref = (Scalar::Util::blessed $data) ? '' : ref $data; $n_steps++ if $ref; } return ($ref||'SCALAR') . ('REF' x $n_steps); } sub _try_refkind { my ($self, $data) = @_; my @try = ($self->_refkind($data)); push @try, 'SCALAR_or_UNDEF' if $try[0] eq 'SCALAR' || $try[0] eq 'UNDEF'; push @try, 'FALLBACK'; return \@try; } sub _METHOD_FOR_refkind { my ($self, $meth_prefix, $data) = @_; my $method; for (@{$self->_try_refkind($data)}) { $method = $self->can($meth_prefix."_".$_) and last; } return $method || puke "cannot dispatch on '$meth_prefix' for ".$self->_refkind($data); } sub _SWITCH_refkind { my ($self, $data, $dispatch_table) = @_; my $coderef; for (@{$self->_try_refkind($data)}) { $coderef = $dispatch_table->{$_} and last; } puke "no dispatch entry for ".$self->_refkind($data) unless $coderef; $coderef->(); } #====================================================================== # VALUES, GENERATE, AUTOLOAD #====================================================================== # LDNOTE: original code from nwiger, didn't touch code in that section # I feel the AUTOLOAD stuff should not be the default, it should # only be activated on explicit demand by user. sub values { my $self = shift; my $data = shift || return; puke "Argument to ", __PACKAGE__, "->values must be a \\%hash" unless ref $data eq 'HASH'; my @all_bind; foreach my $k ( sort keys %$data ) { my $v = $data->{$k}; $self->_SWITCH_refkind($v, { ARRAYREF => sub { if ($self->{array_datatypes}) { # array datatype push @all_bind, $self->_bindtype($k, $v); } else { # literal SQL with bind my ($sql, @bind) = @$v; $self->_assert_bindval_matches_bindtype(@bind); push @all_bind, @bind; } }, ARRAYREFREF => sub { # literal SQL with bind my ($sql, @bind) = @${$v}; $self->_assert_bindval_matches_bindtype(@bind); push @all_bind, @bind; }, SCALARREF => sub { # literal SQL without bind }, SCALAR_or_UNDEF => sub { push @all_bind, $self->_bindtype($k, $v); }, }); } return @all_bind; } sub generate { my $self = shift; my(@sql, @sqlq, @sqlv); for (@_) { my $ref = ref $_; if ($ref eq 'HASH') { for my $k (sort keys %$_) { my $v = $_->{$k}; my $r = ref $v; my $label = $self->_quote($k); if ($r eq 'ARRAY') { # literal SQL with bind my ($sql, @bind) = @$v; $self->_assert_bindval_matches_bindtype(@bind); push @sqlq, "$label = $sql"; push @sqlv, @bind; } elsif ($r eq 'SCALAR') { # literal SQL without bind push @sqlq, "$label = $$v"; } else { push @sqlq, "$label = ?"; push @sqlv, $self->_bindtype($k, $v); } } push @sql, $self->_sqlcase('set'), join ', ', @sqlq; } elsif ($ref eq 'ARRAY') { # unlike insert(), assume these are ONLY the column names, i.e. for SQL for my $v (@$_) { my $r = ref $v; if ($r eq 'ARRAY') { # literal SQL with bind my ($sql, @bind) = @$v; $self->_assert_bindval_matches_bindtype(@bind); push @sqlq, $sql; push @sqlv, @bind; } elsif ($r eq 'SCALAR') { # literal SQL without bind # embedded literal SQL push @sqlq, $$v; } else { push @sqlq, '?'; push @sqlv, $v; } } push @sql, '(' . join(', ', @sqlq) . ')'; } elsif ($ref eq 'SCALAR') { # literal SQL push @sql, $$_; } else { # strings get case twiddled push @sql, $self->_sqlcase($_); } } my $sql = join ' ', @sql; # this is pretty tricky # if ask for an array, return ($stmt, @bind) # otherwise, s/?/shift @sqlv/ to put it inline if (wantarray) { return ($sql, @sqlv); } else { 1 while $sql =~ s/\?/my $d = shift(@sqlv); ref $d ? $d->[1] : $d/e; return $sql; } } sub DESTROY { 1 } sub AUTOLOAD { # This allows us to check for a local, then _form, attr my $self = shift; my($name) = $AUTOLOAD =~ /.*::(.+)/; return $self->generate($name, @_); } 1; __END__ =head1 NAME SQL::Abstract - Generate SQL from Perl data structures =head1 SYNOPSIS use SQL::Abstract; my $sql = SQL::Abstract->new; my($stmt, @bind) = $sql->select($source, \@fields, \%where, \@order); my($stmt, @bind) = $sql->insert($table, \%fieldvals || \@values); my($stmt, @bind) = $sql->update($table, \%fieldvals, \%where); my($stmt, @bind) = $sql->delete($table, \%where); # Then, use these in your DBI statements my $sth = $dbh->prepare($stmt); $sth->execute(@bind); # Just generate the WHERE clause my($stmt, @bind) = $sql->where(\%where, \@order); # Return values in the same order, for hashed queries # See PERFORMANCE section for more details my @bind = $sql->values(\%fieldvals); =head1 DESCRIPTION This module was inspired by the excellent L. However, in using that module I found that what I really wanted to do was generate SQL, but still retain complete control over my statement handles and use the DBI interface. So, I set out to create an abstract SQL generation module. While based on the concepts used by L, there are several important differences, especially when it comes to WHERE clauses. I have modified the concepts used to make the SQL easier to generate from Perl data structures and, IMO, more intuitive. The underlying idea is for this module to do what you mean, based on the data structures you provide it. The big advantage is that you don't have to modify your code every time your data changes, as this module figures it out. To begin with, an SQL INSERT is as easy as just specifying a hash of C pairs: my %data = ( name => 'Jimbo Bobson', phone => '123-456-7890', address => '42 Sister Lane', city => 'St. Louis', state => 'Louisiana', ); The SQL can then be generated with this: my($stmt, @bind) = $sql->insert('people', \%data); Which would give you something like this: $stmt = "INSERT INTO people (address, city, name, phone, state) VALUES (?, ?, ?, ?, ?)"; @bind = ('42 Sister Lane', 'St. Louis', 'Jimbo Bobson', '123-456-7890', 'Louisiana'); These are then used directly in your DBI code: my $sth = $dbh->prepare($stmt); $sth->execute(@bind); =head2 Inserting and Updating Arrays If your database has array types (like for example Postgres), activate the special option C<< array_datatypes => 1 >> when creating the C object. Then you may use an arrayref to insert and update database array types: my $sql = SQL::Abstract->new(array_datatypes => 1); my %data = ( planets => [qw/Mercury Venus Earth Mars/] ); my($stmt, @bind) = $sql->insert('solar_system', \%data); This results in: $stmt = "INSERT INTO solar_system (planets) VALUES (?)" @bind = (['Mercury', 'Venus', 'Earth', 'Mars']); =head2 Inserting and Updating SQL In order to apply SQL functions to elements of your C<%data> you may specify a reference to an arrayref for the given hash value. For example, if you need to execute the Oracle C function on a value, you can say something like this: my %data = ( name => 'Bill', date_entered => \[ "to_date(?,'MM/DD/YYYY')", "03/02/2003" ], ); The first value in the array is the actual SQL. Any other values are optional and would be included in the bind values array. This gives you: my($stmt, @bind) = $sql->insert('people', \%data); $stmt = "INSERT INTO people (name, date_entered) VALUES (?, to_date(?,'MM/DD/YYYY'))"; @bind = ('Bill', '03/02/2003'); An UPDATE is just as easy, all you change is the name of the function: my($stmt, @bind) = $sql->update('people', \%data); Notice that your C<%data> isn't touched; the module will generate the appropriately quirky SQL for you automatically. Usually you'll want to specify a WHERE clause for your UPDATE, though, which is where handling C<%where> hashes comes in handy... =head2 Complex where statements This module can generate pretty complicated WHERE statements easily. For example, simple C pairs are taken to mean equality, and if you want to see if a field is within a set of values, you can use an arrayref. Let's say we wanted to SELECT some data based on this criteria: my %where = ( requestor => 'inna', worker => ['nwiger', 'rcwe', 'sfz'], status => { '!=', 'completed' } ); my($stmt, @bind) = $sql->select('tickets', '*', \%where); The above would give you something like this: $stmt = "SELECT * FROM tickets WHERE ( requestor = ? ) AND ( status != ? ) AND ( worker = ? OR worker = ? OR worker = ? )"; @bind = ('inna', 'completed', 'nwiger', 'rcwe', 'sfz'); Which you could then use in DBI code like so: my $sth = $dbh->prepare($stmt); $sth->execute(@bind); Easy, eh? =head1 METHODS The methods are simple. There's one for every major SQL operation, and a constructor you use first. The arguments are specified in a similar order for each method (table, then fields, then a where clause) to try and simplify things. =head2 new(option => 'value') The C function takes a list of options and values, and returns a new B object which can then be used to generate SQL through the methods below. The options accepted are: =over =item case If set to 'lower', then SQL will be generated in all lowercase. By default SQL is generated in "textbook" case meaning something like: SELECT a_field FROM a_table WHERE some_field LIKE '%someval%' Any setting other than 'lower' is ignored. =item cmp This determines what the default comparison operator is. By default it is C<=>, meaning that a hash like this: %where = (name => 'nwiger', email => 'nate@wiger.org'); Will generate SQL like this: WHERE name = 'nwiger' AND email = 'nate@wiger.org' However, you may want loose comparisons by default, so if you set C to C you would get SQL such as: WHERE name like 'nwiger' AND email like 'nate@wiger.org' You can also override the comparison on an individual basis - see the huge section on L at the bottom. =item sqltrue, sqlfalse Expressions for inserting boolean values within SQL statements. By default these are C<1=1> and C<1=0>. They are used by the special operators C<-in> and C<-not_in> for generating correct SQL even when the argument is an empty array (see below). =item logic This determines the default logical operator for multiple WHERE statements in arrays or hashes. If absent, the default logic is "or" for arrays, and "and" for hashes. This means that a WHERE array of the form: @where = ( event_date => {'>=', '2/13/99'}, event_date => {'<=', '4/24/03'}, ); will generate SQL like this: WHERE event_date >= '2/13/99' OR event_date <= '4/24/03' This is probably not what you want given this query, though (look at the dates). To change the "OR" to an "AND", simply specify: my $sql = SQL::Abstract->new(logic => 'and'); Which will change the above C to: WHERE event_date >= '2/13/99' AND event_date <= '4/24/03' The logic can also be changed locally by inserting a modifier in front of an arrayref : @where = (-and => [event_date => {'>=', '2/13/99'}, event_date => {'<=', '4/24/03'} ]); See the L section for explanations. =item convert This will automatically convert comparisons using the specified SQL function for both column and value. This is mostly used with an argument of C or C, so that the SQL will have the effect of case-insensitive "searches". For example, this: $sql = SQL::Abstract->new(convert => 'upper'); %where = (keywords => 'MaKe iT CAse inSeNSItive'); Will turn out the following SQL: WHERE upper(keywords) like upper('MaKe iT CAse inSeNSItive') The conversion can be C, C, or any other SQL function that can be applied symmetrically to fields (actually B does not validate this option; it will just pass through what you specify verbatim). =item bindtype This is a kludge because many databases suck. For example, you can't just bind values using DBI's C for Oracle C or C fields. Instead, you have to use C: $sth->bind_param(1, 'reg data'); $sth->bind_param(2, $lots, {ora_type => ORA_CLOB}); The problem is, B will normally just return a C<@bind> array, which loses track of which field each slot refers to. Fear not. If you specify C in new, you can determine how C<@bind> is returned. Currently, you can specify either C (default) or C. If you specify C, you will get an array that looks like this: my $sql = SQL::Abstract->new(bindtype => 'columns'); my($stmt, @bind) = $sql->insert(...); @bind = ( [ 'column1', 'value1' ], [ 'column2', 'value2' ], [ 'column3', 'value3' ], ); You can then iterate through this manually, using DBI's C. $sth->prepare($stmt); my $i = 1; for (@bind) { my($col, $data) = @$_; if ($col eq 'details' || $col eq 'comments') { $sth->bind_param($i, $data, {ora_type => ORA_CLOB}); } elsif ($col eq 'image') { $sth->bind_param($i, $data, {ora_type => ORA_BLOB}); } else { $sth->bind_param($i, $data); } $i++; } $sth->execute; # execute without @bind now Now, why would you still use B if you have to do this crap? Basically, the advantage is still that you don't have to care which fields are or are not included. You could wrap that above C loop in a simple sub called C or something and reuse it repeatedly. You still get a layer of abstraction over manual SQL specification. Note that if you set L to C, the C<\[ $sql, @bind ]> construct (see L) will expect the bind values in this format. =item quote_char This is the character that a table or column name will be quoted with. By default this is an empty string, but you could set it to the character C<`>, to generate SQL like this: SELECT `a_field` FROM `a_table` WHERE `some_field` LIKE '%someval%' Alternatively, you can supply an array ref of two items, the first being the left hand quote character, and the second the right hand quote character. For example, you could supply C<['[',']']> for SQL Server 2000 compliant quotes that generates SQL like this: SELECT [a_field] FROM [a_table] WHERE [some_field] LIKE '%someval%' Quoting is useful if you have tables or columns names that are reserved words in your database's SQL dialect. =item escape_char This is the character that will be used to escape Ls appearing in an identifier before it has been quoted. The parameter default in case of a single L character is the quote character itself. When opening-closing-style quoting is used (L is an arrayref) this parameter defaults to the B L. Occurences of the B L within the identifier are currently left untouched. The default for opening-closing-style quotes may change in future versions, thus you are B to specify the escape character explicitly. =item name_sep This is the character that separates a table and column name. It is necessary to specify this when the C option is selected, so that tables and column names can be individually quoted like this: SELECT `table`.`one_field` FROM `table` WHERE `table`.`other_field` = 1 =item injection_guard A regular expression C that is applied to any C<-function> and unquoted column name specified in a query structure. This is a safety mechanism to avoid injection attacks when mishandling user input e.g.: my %condition_as_column_value_pairs = get_values_from_user(); $sqla->select( ... , \%condition_as_column_value_pairs ); If the expression matches an exception is thrown. Note that literal SQL supplied via C<\'...'> or C<\['...']> is B checked in any way. Defaults to checking for C<;> and the C keyword (TransactSQL) =item array_datatypes When this option is true, arrayrefs in INSERT or UPDATE are interpreted as array datatypes and are passed directly to the DBI layer. When this option is false, arrayrefs are interpreted as literal SQL, just like refs to arrayrefs (but this behavior is for backwards compatibility; when writing new queries, use the "reference to arrayref" syntax for literal SQL). =item special_ops Takes a reference to a list of "special operators" to extend the syntax understood by L. See section L for details. =item unary_ops Takes a reference to a list of "unary operators" to extend the syntax understood by L. See section L for details. =back =head2 insert($table, \@values || \%fieldvals, \%options) This is the simplest function. You simply give it a table name and either an arrayref of values or hashref of field/value pairs. It returns an SQL INSERT statement and a list of bind values. See the sections on L and L for information on how to insert with those data types. The optional C<\%options> hash reference may contain additional options to generate the insert SQL. Currently supported options are: =over 4 =item returning Takes either a scalar of raw SQL fields, or an array reference of field names, and adds on an SQL C statement at the end. This allows you to return data generated by the insert statement (such as row IDs) without performing another C