@@ -1,5 +1,11 @@
Revision history for DBIx-Perlish
+0.62 Fri Aug 8 13:37:34 CEST 2014
+ Work around DBD::Pg NAME_uc/NAME_lc quoted fields bug
+
+0.61 Wed Dec 4 12:50:25 CET 2013
+ Initial support for HAVING.
+
0.60 Wed Aug 28 13:35:17 CEST 2013
Fixes for perl 5.18.
@@ -1,6 +1,6 @@
---
name: DBIx-Perlish
-version: 0.60
+version: 0.62
author:
- 'Anton Berezin <tobez@tobez.org>'
abstract: a perlish interface to SQL databases
@@ -11,7 +11,7 @@ requires:
provides:
DBIx::Perlish:
file: lib/DBIx/Perlish.pm
- version: 0.60
+ version: 0.62
DBIx::Perlish::Parse:
file: lib/DBIx/Perlish/Parse.pm
generated_by: hand
@@ -1,4 +1,4 @@
-DBIx-Perlish version 0.60
+DBIx-Perlish version 0.62
DBIx::Perlish - a perlish interface to SQL databases.
@@ -44,12 +44,12 @@ Perl 5.8.2, DBI, PadWalker (optional).
COPYRIGHT AND LICENCE
-Copyright (C) 2007, 2008, Anton Berezin
+Copyright (C) 2007-2013, Anton Berezin
The software known as DBIx::Perlish is distributed under the following
terms:
-Copyright (C) 2007, 2008 Anton Berezin. All rights reserved.
+Copyright (C) 2007-2013 Anton Berezin. All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
@@ -4,7 +4,7 @@ package Module::Install::Base;
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
- $VERSION = '1.06';
+ $VERSION = '1.08';
}
# Suspend handler for "redefined" warnings
@@ -8,7 +8,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.06';
+ $VERSION = '1.08';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.06';
+ $VERSION = '1.08';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -8,7 +8,7 @@ use Fcntl qw/:flock :seek/;
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.06';
+ $VERSION = '1.08';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.06';
+ $VERSION = '1.08';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.06';
+ $VERSION = '1.08';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.06';
+ $VERSION = '1.08';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
@@ -31,7 +31,7 @@ BEGIN {
# This is not enforced yet, but will be some time in the next few
# releases once we can make sure it won't clash with custom
# Module::Install extensions.
- $VERSION = '1.06';
+ $VERSION = '1.08';
# Storage for the pseudo-singleton
$MAIN = undef;
@@ -451,6 +451,9 @@ sub parse_return
} else {
if ($rv{key_field}) {
my $kf = '$kf-' . $S->{key_field};
+ if ($S->{gen_args}{kf_convert}) {
+ $kf = $S->{gen_args}{kf_convert}->($kf);
+ }
$S->{key_field}++;
push @{$S->{returns}}, "$rv{field} as \"$kf\"";
push @{$S->{key_fields}}, $kf;
@@ -921,6 +924,10 @@ sub try_funcall
$S->{autogroup_needed} = 1;
$S->{inside_aggregate} = 1;
}
+ if (!$S->{parsing_return} && $S->{aggregates}{lc $func}) {
+ $S->{this_is_having} = 1;
+ $S->{autogroup_needed} = 1;
+ }
my @terms = map { scalar parse_term($S, $_) } @args;
@@ -1717,6 +1724,13 @@ sub parse_selfmod
return "$f = $f $oper";
}
+sub where_or_having
+{
+ my ($S, @what) = @_;
+ push @{$S->{$S->{this_is_having} ? "having" : "where"}}, @what;
+ $S->{this_is_having} = 0;
+}
+
sub parse_op
{
my ($S, $op) = @_;
@@ -1737,21 +1751,23 @@ sub parse_op
} elsif (is_listop($op, "return")) {
parse_return($S, $op);
} elsif (is_binop($op)) {
- push @{$S->{where}}, parse_expr($S, $op);
+ where_or_having($S, parse_expr($S, $op));
} elsif (is_unop($op, "not")) {
- push @{$S->{where}}, scalar parse_term($S, $op);
+ where_or_having($S, scalar parse_term($S, $op));
} elsif (is_logop($op, "or")) {
my $or = parse_or($S, $op);
- push @{$S->{where}}, "($or)" if $or;
+ where_or_having($S, "($or)") if $or;
+ $S->{this_is_having} = 0;
} elsif (is_logop($op, "and")) {
my $and = parse_and($S, $op);
- push @{$S->{where}}, $and if $and;
+ where_or_having($S, $and) if $and;
+ $S->{this_is_having} = 0;
} elsif (is_unop($op, "leavesub")) {
parse_op($S, $op->first);
} elsif (is_unop($op, "null")) {
parse_op($S, $op->first);
} elsif (is_unop($op, "defined")) {
- push @{$S->{where}}, scalar parse_term($S, $op);
+ where_or_having($S, scalar parse_term($S, $op));
} elsif (is_op($op, "padsv")) {
# XXX Skip for now, it is either a variable
# that does not represent a table, or else
@@ -1779,9 +1795,9 @@ sub parse_op
$S->{line} = $op->line;
# skip
} elsif (is_unop($op, "entersub")) {
- push @{$S->{where}}, parse_entersub($S, $op);
+ where_or_having($S, parse_entersub($S, $op));
} elsif (is_pmop($op, "match")) {
- push @{$S->{where}}, parse_regex($S, $op, 0);
+ where_or_having($S, parse_regex($S, $op, 0));
} elsif ( $op->name eq 'join') {
push @{$S->{joins}}, parse_join($S, $op);
} elsif ($op->name eq 'sort') {
@@ -1,5 +1,4 @@
package DBIx::Perlish;
-# $Id$
use 5.008;
use warnings;
@@ -10,7 +9,7 @@ use vars qw($VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS $SQL @BIND_VALUES);
require Exporter;
use base 'Exporter';
-$VERSION = '0.60';
+$VERSION = '0.62';
@EXPORT = qw(db_fetch db_select db_update db_delete db_insert sql);
@EXPORT_OK = qw(union intersect except);
%EXPORT_TAGS = (all => [@EXPORT, @EXPORT_OK]);
@@ -160,11 +159,21 @@ sub fetch
my $nret;
my $dbh = $me->{dbh} || get_dbh(3);
my @kf;
+ my $flavor = _get_flavor($dbh);
+ my $kf_convert = sub { return $_[0] };
+ if ($flavor eq "pg" && $dbh->{FetchHashKeyName}) {
+ if ($dbh->{FetchHashKeyName} eq "NAME_uc") {
+ $kf_convert = sub { return uc $_[0] };
+ } elsif ($dbh->{FetchHashKeyName} eq "NAME_lc") {
+ $kf_convert = sub { return lc $_[0] };
+ }
+ }
($me->{sql}, $me->{bind_values}, $nret) = gen_sql($sub, "select",
- flavor => _get_flavor($dbh),
+ flavor => $flavor,
dbh => $dbh,
quirks => $me->{quirks} || $non_object_quirks,
key_fields => \@kf,
+ kf_convert => $kf_convert,
);
$SQL = $me->{sql}; @BIND_VALUES = @{$me->{bind_values}};
if (@kf) {
@@ -374,6 +383,7 @@ sub gen_sql
my @sets = grep { $_ ne "" } @{$S->{sets}};
my @where = grep { $_ ne "" } @{$S->{where}};
+ my @having = grep { $_ ne "" } @{$S->{having}};
my @group_by = grep { $_ ne "" } @{$S->{group_by}};
my @order_by = grep { $_ ne "" } @{$S->{order_by}};
@@ -387,6 +397,7 @@ sub gen_sql
$sql .= " set " . join ", ", @sets if @sets;
$sql .= " where " . join " and ", @where if @where;
$sql .= " group by " . join ", ", @group_by if @group_by;
+ $sql .= " having " . join " and ", @having if @having;
$sql .= " order by " . join ", ", @order_by if @order_by;
if ($dangerous && !@where && !$S->{seen_exec}) {
@@ -423,7 +434,7 @@ DBIx::Perlish - a perlish interface to SQL databases
=head1 VERSION
-This document describes DBIx::Perlish version 0.60
+This document describes DBIx::Perlish version 0.62
=head1 SYNOPSIS
@@ -1460,6 +1471,19 @@ will execute the equivalent of the following SQL statement:
The C<avg()>, C<count()>, C<max()>, C<min()>, and C<sum()>
functions are considered to be aggregate.
+Similarly, using an aggregate function in a filtering expression
+will lead to automatic introduction of a HAVING clause:
+
+ db_fetch {
+ my $w : weather;
+ max($w->temp_lo) < 40;
+ return $w->city;
+ };
+
+will translate into an equivalent of
+
+ select city from weather group by city having max(temp_lo) < 40
+
Specifying label C<table:> followed by a lexical variable
declaration, followed by an assignment introduces an alternative
table declaration syntax. The value of the expression on the right
@@ -1916,7 +1940,7 @@ There is also the project website at
=head1 LICENSE AND COPYRIGHT
-Copyright (c) 2007-2009, Anton Berezin C<< <tobez@tobez.org> >>. All rights reserved.
+Copyright (c) 2007-2013, Anton Berezin C<< <tobez@tobez.org> >>. All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
@@ -1,6 +1,6 @@
use warnings;
use strict;
-use Test::More tests => 437;
+use Test::More tests => 439;
use DBIx::Perlish qw/:all/;
use t::test_utils;
@@ -1196,3 +1196,12 @@ test_select_sql {
} "not a hash 3",
"select null",
[];
+
+# having
+test_select_sql {
+ my $w : weather;
+ max($w->temp_lo) < 40;
+ return $w->city;
+} "simple having",
+"select t01.city from weather t01 group by t01.city having max(t01.temp_lo) < 40",
+[];