SQL-Abstract-Classic-1.91/0000755000175000017500000000000013552041031014505 5ustar rabbitrabbitSQL-Abstract-Classic-1.91/t/0000755000175000017500000000000013552041031014750 5ustar rabbitrabbitSQL-Abstract-Classic-1.91/t/06order_by.t0000644000175000017500000001005713551736136017133 0ustar rabbitrabbituse strict; use warnings; use Test::More; use Test::Exception; use SQL::Abstract::Classic; 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::Classic->new; my $sqlq = SQL::Abstract::Classic->new({quote_char => '`'}); for my $case( @cases) { my ($stat, @bind); ($stat, @bind) = $sql->where(undef, $case->{given}); is_same_sql_bind ( $stat, \@bind, $case->{expects}, $case->{bind} || [], ); ($stat, @bind) = $sqlq->where(undef, $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-Classic-1.91/t/21op_ident.t0000644000175000017500000000216013551736252017117 0ustar rabbitrabbituse strict; use warnings; use Test::More; use Test::Exception; use SQL::Abstract::Classic; use SQL::Abstract::Test import => [qw/is_same_sql_bind/]; for my $q ('', '"') { my $sql_maker = SQL::Abstract::Classic->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-Classic-1.91/t/20injection_guard.t0000644000175000017500000000214713551736370020467 0ustar rabbitrabbituse strict; use warnings; use Test::More; use Test::Exception; use SQL::Abstract::Test import => ['is_same_sql_bind']; use SQL::Abstract::Classic; my $sqlac = SQL::Abstract::Classic->new; my $sqlac_q = SQL::Abstract::Classic->new(quote_char => '"'); throws_ok( sub { $sqlac->select( 'foo', [ 'bar' ], { 'bobby; tables' => 'bar' }, ); }, qr/Possible SQL injection attempt/, 'Injection thwarted on unquoted column' ); my ($sql, @bind) = $sqlac_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 ($sqlac, $sqlac_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-Classic-1.91/t/01generate.t0000644000175000017500000011177313551736110017112 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::Classic; #### 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::Classic->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-Classic-1.91/t/05in_between.t0000644000175000017500000002173513551741545017451 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::Classic; 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/NULL-within-IN not implemented/, where => { x => { -in => [ 1, undef ] } }, stmt => " WHERE ( x IN ( ? ) OR x IS NULL )", bind => [ 1 ], test => '-in with undef as an element', }, { throws => qr/NULL-within-IN not implemented/, 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/NULL-within-IN not implemented/, 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/NULL-within-IN not implemented/, 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::Classic->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-Classic-1.91/t/23_is_X_value.t0000644000175000017500000001353013551736301017553 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::Util 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-Classic-1.91/t/07subqueries.t0000644000175000017500000000513513551736142017514 0ustar rabbitrabbituse strict; use warnings; use Test::More; use SQL::Abstract::Test import => ['is_same_sql_bind']; use SQL::Abstract::Classic; #### 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::Classic->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-Classic-1.91/t/02where.t0000644000175000017500000002514113551736115016431 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::Classic; 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 ], }, { where => \"0", stmt => " WHERE ( 0 ) ", bind => [ ], }, ); for my $case (@handle_tests) { my $sql = SQL::Abstract::Classic->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-Classic-1.91/t/03values.t0000644000175000017500000000603613551736121016616 0ustar rabbitrabbituse strict; use warnings; use Test::More; use SQL::Abstract::Test import => [qw/is_same_sql_bind is_same_bind/]; use SQL::Abstract::Classic; 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::Classic->new; my $h_sql = SQL::Abstract::Classic->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::Classic->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-Classic-1.91/t/09refkind.t0000644000175000017500000000207313551736155016753 0ustar rabbitrabbituse strict; use warnings; use Test::More; use SQL::Abstract::Classic; my $obj = bless {}, "Foo::Bar"; is(SQL::Abstract::Classic->_refkind(undef), 'UNDEF', 'UNDEF'); is(SQL::Abstract::Classic->_refkind({}), 'HASHREF', 'HASHREF'); is(SQL::Abstract::Classic->_refkind([]), 'ARRAYREF', 'ARRAYREF'); is(SQL::Abstract::Classic->_refkind(\{}), 'HASHREFREF', 'HASHREFREF'); is(SQL::Abstract::Classic->_refkind(\[]), 'ARRAYREFREF', 'ARRAYREFREF'); is(SQL::Abstract::Classic->_refkind(\\{}), 'HASHREFREFREF', 'HASHREFREFREF'); is(SQL::Abstract::Classic->_refkind(\\[]), 'ARRAYREFREFREF', 'ARRAYREFREFREF'); is(SQL::Abstract::Classic->_refkind("foo"), 'SCALAR', 'SCALAR'); is(SQL::Abstract::Classic->_refkind(\"foo"), 'SCALARREF', 'SCALARREF'); is(SQL::Abstract::Classic->_refkind(\\"foo"), 'SCALARREFREF', 'SCALARREFREF'); # objects are treated like scalars is(SQL::Abstract::Classic->_refkind($obj), 'SCALAR', 'SCALAR'); is(SQL::Abstract::Classic->_refkind(\$obj), 'SCALARREF', 'SCALARREF'); is(SQL::Abstract::Classic->_refkind(\\$obj), 'SCALARREFREF', 'SCALARREFREF'); done_testing; SQL-Abstract-Classic-1.91/t/00new.t0000644000175000017500000000714413551736104016107 0ustar rabbitrabbituse strict; use warnings; use Test::More; use Test::Warn; use SQL::Abstract::Test import => ['is_same_sql']; use SQL::Abstract::Classic; 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::Classic->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-Classic-1.91/t/08special_ops.t0000644000175000017500000000275613551736146017641 0ustar rabbitrabbituse strict; use warnings; use Test::More; use SQL::Abstract::Test import => ['is_same_sql_bind']; use SQL::Abstract::Classic; my $sqlmaker = SQL::Abstract::Classic->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-Classic-1.91/t/22op_value.t0000644000175000017500000000355513551736257017147 0ustar rabbitrabbituse strict; use warnings; use Test::More; use SQL::Abstract::Classic; use SQL::Abstract::Test import => [qw/is_same_sql_bind/]; for my $q ('', '"') { for my $col_btype (0,1) { my $sql_maker = SQL::Abstract::Classic->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-Classic-1.91/t/04modifiers.t0000644000175000017500000003152613551736126017310 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::Classic; 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::Classic->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::Classic->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::Classic->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-Classic-1.91/inc/0000755000175000017500000000000013552041031015256 5ustar rabbitrabbitSQL-Abstract-Classic-1.91/inc/Module/0000755000175000017500000000000013552041031016503 5ustar rabbitrabbitSQL-Abstract-Classic-1.91/inc/Module/Install.pm0000644000175000017500000002714513552041023020461 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.006; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.19'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::getcwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::getcwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::getcwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $base_path = VMS::Filespec::unixify($base_path) if $^O eq 'VMS'; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( {no_chdir => 1, wanted => sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($File::Find::name); my $in_pod = 0; foreach ( split /\n/, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }}, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; binmode FH; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; binmode FH; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp { _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2012 Adam Kennedy. SQL-Abstract-Classic-1.91/inc/Module/Install/0000755000175000017500000000000013552041031020111 5ustar rabbitrabbitSQL-Abstract-Classic-1.91/inc/Module/Install/AutoInstall.pm0000644000175000017500000000416213552041023022712 0ustar rabbitrabbit#line 1 package Module::Install::AutoInstall; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @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-Classic-1.91/inc/Module/Install/Fetch.pm0000644000175000017500000000462713552041024021513 0ustar rabbitrabbit#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; SQL-Abstract-Classic-1.91/inc/Module/Install/Makefile.pm0000644000175000017500000002743713552041023022202 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.19'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-separated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 SQL-Abstract-Classic-1.91/inc/Module/Install/Include.pm0000644000175000017500000000101513552041023022030 0ustar rabbitrabbit#line 1 package Module::Install::Include; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @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-Classic-1.91/inc/Module/Install/Base.pm0000644000175000017500000000214713552041023021326 0ustar rabbitrabbit#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.19'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 SQL-Abstract-Classic-1.91/inc/Module/Install/Metadata.pm0000644000175000017500000004330213552041023022172 0ustar rabbitrabbit#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) [\s|;]* /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashes delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; SQL-Abstract-Classic-1.91/inc/Module/Install/Can.pm0000644000175000017500000000640513552041024021157 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.19'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # Check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # Can we locate a (the) C compiler sub can_cc { my $self = shift; if ($^O eq 'VMS') { require ExtUtils::CBuilder; my $builder = ExtUtils::CBuilder->new( quiet => 1, ); return $builder->have_compiler; } my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 245 SQL-Abstract-Classic-1.91/inc/Module/Install/WriteAll.pm0000644000175000017500000000237613552041024022204 0ustar rabbitrabbit#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; SQL-Abstract-Classic-1.91/inc/Module/Install/Win32.pm0000644000175000017500000000340313552041024021353 0ustar rabbitrabbit#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; SQL-Abstract-Classic-1.91/inc/Module/AutoInstall.pm0000644000175000017500000006231113552041023021304 0ustar rabbitrabbit#line 1 package Module::AutoInstall; use strict; use Cwd (); use File::Spec (); use ExtUtils::MakeMaker (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.19'; } # 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::getcwd(); $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 compatibility 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, @modules_to_upgrade ); while (my ($pkg, $ver) = splice(@_, 0, 2)) { # grep out those already installed if (_version_cmp(_version_of($pkg), $ver) >= 0) { push @installed, $pkg; if ($UpgradeDeps) { push @modules_to_upgrade, $pkg, $ver; } } else { push @modules, $pkg, $ver; } } if ($UpgradeDeps) { push @modules, @modules_to_upgrade; @installed = (); @modules_to_upgrade = (); } 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} = $opt eq 'urllist' ? [$arg] : $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::getcwd() ); 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 1197 SQL-Abstract-Classic-1.91/Changes0000644000175000017500000003744313552037553016031 0ustar rabbitrabbitRevision history for SQL::Abstract revision 1.91 2019-10-17 ---------------------------- - New namespace providing path forward without SQL::Abstract churn - Allow puke() and belch() to be used as both functions and methods greatly simplifying subclassing - Fix order clauses with bind parameters in ->where - Documentation improvements for ORDER BY - Fix syntax errors in ORDER BY docs (GH#7) - Remove obsolete documentation about arrayrefref as the $source argument for ->select (removed in version 1.74) - Do not replace literal '0' with empty string in WHERE clauses (GH#14) 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-Classic-1.91/MANIFEST0000644000175000017500000000120313552041027015637 0ustar rabbitrabbitChanges inc/Module/AutoInstall.pm inc/Module/Install.pm inc/Module/Install/AutoInstall.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Include.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/SQL/Abstract/Classic.pm lib/SQL/Abstract/Util.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/20injection_guard.t t/21op_ident.t t/22op_value.t t/23_is_X_value.t SQL-Abstract-Classic-1.91/lib/0000755000175000017500000000000013552041031015253 5ustar rabbitrabbitSQL-Abstract-Classic-1.91/lib/SQL/0000755000175000017500000000000013552041031015712 5ustar rabbitrabbitSQL-Abstract-Classic-1.91/lib/SQL/Abstract/0000755000175000017500000000000013552041031017455 5ustar rabbitrabbitSQL-Abstract-Classic-1.91/lib/SQL/Abstract/Classic.pm0000644000175000017500000025713113552040777021425 0ustar rabbitrabbitpackage SQL::Abstract::Classic; use strict; use warnings; use Carp (); use List::Util (); use Scalar::Util (); use SQL::Abstract::Util (); #====================================================================== # GLOBALS #====================================================================== our $VERSION = '1.91'; # 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 (@) { # Fugly as hell - allow calls as functions ( backcompat ) and as methods ( subclassing ) shift if @_ > 1 and length( ref ( $_[0] ) ); my($func) = (caller(1))[3]; Carp::carp "[$func] Warning: ", @_; } sub puke (@) { # Fugly as hell - allow calls as functions ( backcompat ) and as methods ( subclassing ) shift if @_ > 1 and length( ref ( $_[0] ) ); my($func) = (caller(1))[3]; Carp::croak "[$func] Fatal: ", @_; } #====================================================================== # 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]; $_[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 $self->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 $self->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); $self->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; $self->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 = (defined $sql and length $sql) ? $self->_sqlcase(' where ') . "( $sql )" : ''; # order by? if ($order) { my ($order_sql, @order_bind) = $self->_order_by($order); $sql .= $order_sql; push @bind, @order_bind; } 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 { $self->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 $self->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 { $self->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 ( SQL::Abstract::Util::is_literal_value( $v ) ) { $self->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 { $self->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) $self->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 ) { $self->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 { $self->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 { $self->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 { $self->puke( "-$op => \\\$scalar makes little sense, use " . ($op =~ /^or/i ? '[ \$scalar, \%rest_of_conditions ] instead' : '-and => [ \$scalar, \%rest_of_conditions ] instead' ) ); }, ARRAYREFREF => sub { $self->puke( "-$op => \\[...] makes little sense, use " . ($op =~ /^or/i ? '[ \[...], \%rest_of_conditions ] instead' : '-and => [ \[...], \%rest_of_conditions ] instead' ) ); }, SCALAR => sub { # permissively interpreted as SQL $self->puke( "-$op => \$value makes little sense, use -bool => \$value instead" ); }, UNDEF => sub { $self->puke( "-$op => undef not supported" ); }, }); } sub _where_op_NEST { my ($self, $op, $v) = @_; $self->_SWITCH_refkind($v, { SCALAR => sub { # permissively interpreted as SQL $self->belch( "literal SQL should be -nest => \\'scalar' " . "instead of -nest => 'scalar' " ); return ($v); }, UNDEF => sub { $self->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 { $self->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) { $self->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) { $self->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 { $self->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} ? $self->belch("Supplying an undefined argument to '@{[ uc $op]}' is deprecated") && 'is' : $op =~ $self->{inequality_op} ? 'is not' : $op =~ $self->{not_like_op} ? $self->belch("Supplying an undefined argument to '@{[ uc $op]}' is deprecated") && 'is not' : $self->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 { $self->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); $self->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} ? $self->belch("Supplying an empty arrayref to '@{[ uc $op]}' is deprecated") && $self->{sqlfalse} : $op =~ $self->{inequality_op} ? $self->{sqltrue} : $op =~ $self->{not_like_op} ? $self->belch("Supplying an empty arrayref to '@{[ uc $op]}' is deprecated") && $self->{sqltrue} : $self->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 { $self->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; $self->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 { $self->puke( $invalid_args ), }, }); push @all_sql, $sql; push @all_bind, @bind; } return ( (join $and, @all_sql), @all_bind ); }, FALLBACK => sub { $self->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; $self->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 { $self->puke( 'NULL-within-IN not implemented: The upcoming SQL::Abstract::Classic 2.0 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 { $self->puke( "Argument passed to the '$op' operator can not be undefined" ); }, FALLBACK => sub { $self->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 ) { $self->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 { $_[0]->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) { $self->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 || $self->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; } $self->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; $self->puke( "Argument to ", (ref($self) || $self), "->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::Classic - Generate SQL from Perl data structures =head1 SYNOPSIS use SQL::Abstract::Classic; my $sql = SQL::Abstract::Classic->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 Low-impact fork of SQL::Abstract v1.81 ( 2014-10-25 ) This module is nearly identical to L. A recent flurry of activity on the original L namespace risks leaving downstream users without a way to opt out of impending developments. Therefore this module exists to preserve the ability of users to opt into the new way of doing things according to their own schedules. =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::Classic->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::Classic->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::Classic->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::Classic->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. Occurrences 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