Skip to content

Comparing changes

Choose two branches to see what’s changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
...
  • 15 commits
  • 5 files changed
  • 0 commit comments
  • 1 contributor
Commits on Feb 23, 2012
@mauzo Add [@%]ArgQ and %SelfQ.
These are identifier-quoted versions of ArgX and SelfX.

Also rationalise Arg{,X,Q} and Self{,X,Q}, using %P and %Q. This means
more qexs in appropriate places. I wonder if, if I were to make defer
and placeholder call qex, I could get rid of the recursive expansion in
expand? I'd be replacing it with Perl-level recursion, of course, but I
don't mind that.
5dc4820
@mauzo Force Queries using '%' rather than '!'.
It's considerably clearer.
b239d2e
@mauzo Optimise Query->concat("").
It turns out I was getting Querys full of empty strings, probably due to
all the djoin ""s. That's an easy case to catch, so catch it.
436f8ed
@mauzo Allow Query->expand to redefer.
This makes it possible to partially expand a Query with the currently-
available information, then finish later. In particular, this will be
needed to allow class methods which return Queries.

Currently this is used by %Q and %P; both redefer if the hash passed to
->expand didn't include a DB. This means that contexts which want a full
expansion will now need to explicitly pass in a 'db' parameter. Change
QS to do this.
22515df
@mauzo Move expand_query from DB to Irian.
'method' will need it, and it's of general utility anyway.
04331a5
@mauzo 'method' sugar on QuerySet.
This installs either a sub or a Query as a method. Installing a plain
sub like this has the advantage that it won't conflict with sugar subs
that are going to disappear before runtime.

Installing a Query gives you a method which expands that Query, but
without passing a 'db' parameter. This means it will effectively close
over the current %Self and @Args, leaving %P and %Q to expand later when
we've got a DB object to run them against.
3f05c70
@mauzo Trace queryset creation. d56e989
Commits on Feb 25, 2012
@mauzo Replace Exporter with exports from Irian.
This means I can clean up properly afterwards. It also means I get an
error if two modules try to export the same function, which seems like a
good idea.

Currently Query still uses Exporter for the variables, mostly because I
can't be bothered to replace it. I suspect a replacement based on
find_sym would be rather easy, and it would let me make the variable
exports lexically-scoped as well.

(I am assuming here that the replace-the-glob trick works for variables
as well as for functions. I see no reason it shouldn't: the glob is
compiled into the optree in exactly the same way. *However*, I do need
to check that is still the case under ithreads.)
87c92c8
@mauzo QuerySet needs to import Scalar::Util::blessed. ed0e898
@mauzo Irian::load_module.
This is just a trivial wrapper around eval"", but it makes things
cleaner. Later on I should probably put in checks that the module name
is safe, and probably map it to a /.pm-path by hand rather that using
eval.
0038ced
@mauzo Move expand_query into Query.
It ought to be using is_defer rather that ref to identify deferred
strings, and that isn't visible outside Query.
e5259bf
@mauzo Have DB supply db and row args to expand_query.
While I'm there, have it take $args as either an array or a hashref,
since it's really just a list at this point. This also means that
callers of do_* don't need to supply any $args at all if they only want
row and db expanded.
418d89e
@mauzo Trace calls to 'method's. b0abade
@mauzo Remove the redefer stuff for now.
This is a partial reversion of 22515, but that commit included quite a
lot of general cleanup as well.
fe25747
@mauzo Don't try to expand methods, now we can't redefer. 3f3056e
Showing with 203 additions and 110 deletions.
  1. +50 −24 lib/DBIx/Irian.pm
  2. +21 −14 lib/DBIx/Irian/DB.pm
  3. +2 −1 lib/DBIx/Irian/Inflate.pm
  4. +113 −68 lib/DBIx/Irian/Query.pm
  5. +17 −3 lib/DBIx/Irian/QuerySet.pm
View
74 lib/DBIx/Irian.pm
@@ -13,11 +13,10 @@ use B::Hooks::EndOfScope;
use B::Hooks::AtRuntime;
use Scope::Upper qw/reap CALLER/;
-our %UTILS = map +($_, __PACKAGE__->can($_)), qw(
- trace tracex
- install_sub find_sym qualify load_class
- register lookup
-);
+# The bootstrapping order is rather specific. Currently that means the
+# exports for this module are buried halfway down the file, in a call to
+# register_utils. Probably Trace, Sym, and Util should go into their own
+# modules.
{
my $TraceLog = sub { warn "$_[0]\n" };
@@ -105,6 +104,43 @@ sub uninstall_sub {
}
{
+ our %Utils;
+
+ sub register_utils {
+ my $pkg = caller;
+ my @u = @_;
+ for (@u) {
+ $Utils{$_} and croak "Util [$_] already registered";
+ $Utils{$_} = $pkg->can($_);
+ }
+ tracex { "REG [$pkg] [@u]" } "UTL";
+ }
+
+ sub export_utils {
+ my ($to, @utils) = @_;
+
+ tracex { "EXPORT [$to] [@utils]" } "UTL";
+ for my $n (@utils) {
+ my $cv = $Utils{$n} or croak
+ "$n is not exported by DBIx::Irian";
+ install_sub $to, $n, $cv;
+ }
+
+ on_scope_end { uninstall_sub $to, $_ for @utils };
+ }
+}
+
+register_utils qw(
+ trace tracex
+ register_utils
+ install_sub find_sym qualify load_class
+ register lookup
+);
+
+require DBIx::Irian::Query;
+require DBIx::Irian::Inflate;
+
+{
my %Pkg;
sub register {
@@ -130,6 +166,8 @@ sub uninstall_sub {
}
}
+sub load_module { eval "require $_[0]; 1;" or croak $@; $_[0] }
+
sub qualify {
my ($pkg, $base) = @_;
$pkg =~ s/^\+// ? $pkg : "$base\::$pkg";
@@ -147,7 +185,7 @@ sub load_class {
# we have to do this before loading the Row class, otherwise
# queries in that Row class won't know which DB they are in
register $class, db => $db;
- eval "require $class; 1" or croak $@;
+ load_module $class;
}
lookup($class, "type") eq $type or croak
"Not a $type class: $class";
@@ -168,13 +206,6 @@ sub setup_isa {
tracex { "[$class]: [@$isa]" } "ISA";
}
-# XXX this doesn't clean up
-sub export_utils {
- my ($util, $to) = @_;
- eval "require $util; 1;" or croak $@;
- $util->Exporter::export($to);
-}
-
sub setup_subclass {
my ($class, $root, $type) = @_;
@@ -185,7 +216,7 @@ sub setup_subclass {
}
my $parent = "$root\::$type";
- eval "require $parent; 1" or croak $@;
+ load_module $parent;
at_runtime {
reap sub {
@@ -210,11 +241,12 @@ sub setup_subclass {
push @clean, $n;
}
+ # XXX I don't think this is useful
$c->Exporter::export($class);
}
- export_utils $_, $class
- for map "DBIx::Irian::$_", qw/ Query Inflate /;
+ # This should only export variables.
+ DBIx::Irian::Query->Exporter::export($class);
on_scope_end {
uninstall_sub $class, $_ for @clean;
@@ -230,18 +262,12 @@ sub import {
$type and setup_subclass $to, $from, $type;
- my @clean;
- for my $n (@utils) {
- my $cv = $UTILS{$n} or croak
- "$n is not exported by $from";
- install_sub $to, $n, $cv;
- push @clean, $n;
- }
+ export_utils $to, @utils;
on_scope_end {
my $av = find_sym($to, '@CLEAN') || [];
tracex { "CLEAN [$to]: [@$av]" } "SYM";
- uninstall_sub $to, $_ for @clean, @$av;
+ uninstall_sub $to, $_ for @$av;
};
}
View
35 lib/DBIx/Irian/DB.pm
@@ -5,13 +5,15 @@ use strict;
use parent "DBIx::Irian::QuerySet";
-use DBIx::Irian undef, qw/install_sub tracex/;
+use DBIx::Irian undef, qw(
+ install_sub tracex expand_query lookup
+);
use DBIx::Connector;
use DBIx::Irian::Driver;
use Scalar::Util qw/reftype/;
use Carp qw/carp/;
-BEGIN { our @CLEAN = qw/reftype carp expand_query/ }
+BEGIN { our @CLEAN = qw/reftype carp/ }
for my $n (qw/dbc dsn user password driver _DB/) {
install_sub $n, sub { $_[0]{$n} };
@@ -46,19 +48,24 @@ sub new {
$self{_DB} = bless \%self, $class;
}
-sub expand_query {
- my ($query, $args) = @_;
-
- my ($sql, @bind) = ref $query
- ? $query->expand($args)
- : $query;
-
- return $sql, @bind;
+sub do_expand_query {
+ my ($self, $row, $query, $args) = @_;
+ $args =
+ ref $args ?
+ reftype $args eq "ARRAY" ? $args :
+ reftype $args eq "HASH" ? [ %$args ] :
+ croak("Bad reftype '$args'") :
+ [];
+ expand_query $query, {
+ @$args,
+ db => $self,
+ $row ? (row => lookup($row)) : (),
+ };
}
sub do_query {
my ($self, $row, $query, $args) = @_;
- my ($sql, @bind) = expand_query $query, $args;
+ my ($sql, @bind) = $self->do_expand_query($row, $query, $args);
my ($cols, $rows) = $self->dbc->run(sub {
tracex { "[$sql] [@bind]" } "SQL";
@@ -78,7 +85,7 @@ sub do_query {
sub do_cursor {
my ($self, $row, $query, $args) = @_;
- my ($sql, @bind) = expand_query $query, $args;
+ my ($sql, @bind) = $self->do_expand_query($row, $query, $args);
DBIx::Irian::Cursor->new(
DB => $self,
@@ -90,7 +97,7 @@ sub do_cursor {
sub do_detail {
my ($self, $query, $args) = @_;
- my ($sql, @bind) = expand_query $query, $args;
+ my ($sql, @bind) = $self->do_expand_query(undef, $query, $args);
my $rows = $self->dbc->run(sub {
tracex { "[$sql] [@bind]" } "SQL";
@@ -106,7 +113,7 @@ sub do_detail {
sub do_action {
my ($self, $query, $args) = @_;
- my ($sql, @bind) = expand_query $query, $args;
+ my ($sql, @bind) = $self->do_expand_query(undef, $query, $args);
$self->dbc->run(sub {
tracex { "[$sql] [@bind]" } "SQL";
View
3 lib/DBIx/Irian/Inflate.pm
@@ -5,8 +5,9 @@ use strict;
use Carp;
use Scalar::Util qw/blessed reftype/;
+use DBIx::Irian undef, "register_utils";
-our @EXPORT = "register_inflators";
+register_utils "register_inflators";
my %Inflators;
View
181 lib/DBIx/Irian/Query.pm
@@ -10,30 +10,45 @@ use Sub::Name qw/subname/;
use Carp;
use Tie::OneOff;
-use DBIx::Irian undef, qw/lookup trace tracex/;
+use DBIx::Irian undef, qw/register_utils lookup trace tracex/;
+# Only use Exporter for the variables. The functions are exported by
+# Irian directly.
our @EXPORT = qw(
- djoin
- @Arg %Arg @ArgX %ArgX %Q %P $Cols %Cols %Queries %Self %SelfX
+ %P %Q
+ @Arg %Arg @ArgX %ArgX @ArgQ %ArgQ
+ $Cols %Cols %Queries
+ %Self %SelfX %SelfQ
);
+register_utils qw( djoin expand_query );
+
use overload
q/./ => "concat",
q/""/ => "force",
bool => sub { 1 },
fallback => 1;
+my $Defer = "DBIx::Irian::Query";
+
+sub is_defer ($) { blessed $_[0] and blessed $_[0] eq $Defer }
+sub is_cv ($) {
+ ref $_[0] and not blessed $_[0] and reftype $_[0] eq "CODE" }
+
sub new {
my ($class, $str, $val) = @_;
- not ref $str or reftype $str eq "CODE" and not blessed $str
- or croak "I need a string or a coderef";
- @_ < 3 or reftype $val eq "CODE" and not blessed $val
- or croak "I need an unblessed coderef";
+ !ref $str or is_cv $str or croak "I need a string or a coderef";
+ @_ < 3 or is_cv $val or croak "I need an unblessed coderef";
bless [[$str], [@_ == 3 ? $val : ()]], $class;
}
-sub defer (&$) { __PACKAGE__->new(subname $_[1], $_[0]) }
-sub placeholder (&$) { __PACKAGE__->new("?", subname $_[1], $_[0]) }
+sub defer (&$) {
+ $Defer->new(subname $_[1], $_[0]);
+}
+sub placeholder (&$) {
+ my ($cv, $n) = @_;
+ $Defer->new("?", subname($n, $cv));
+}
sub djoin {
my ($j, @strs) = @_;
@@ -43,104 +58,137 @@ sub djoin {
sub force {
my ($self) = @_;
my ($sql, $bind) = @$self;
- my $plain = join "", map ref $_ ? "!" : $_, @$sql;
+ join "", map ref $_ ? "%" : $_, @$sql;
+
# We can't croak here, much as I'd like to, since a tied hash lookup
# stringifies the key even though it then passes the original object
# to FETCH. Grrrr.
#@$bind and croak "Query '$plain' has placeholders";
#grep ref, @$sql and croak "Query '$plain' has deferred sections";
- $plain;
+ #$plain;
}
sub concat {
my ($left, $right, $reverse) = @_;
+
+ length $right or return $left;
+
my (@str, @val);
($str[0], $val[0]) = @$left;
- ($str[1], $val[1]) = eval { $right->isa(__PACKAGE__) }
- ? @$right : (["$right"], []);
+ ($str[1], $val[1]) =
+ is_defer $right ? @$right :
+ (["$right"], []);
+
my @ord = $reverse ? (1, 0) : (0, 1);
- bless [[map @$_, @str[@ord]], [map @$_, @val[@ord]]], blessed $left;
+ bless [[map @$_, @str[@ord]], [map @$_, @val[@ord]]], $Defer;
+}
+
+sub expand_query {
+ my ($query, $args) = @_;
+
+ my ($sql, @bind) = is_defer $query
+ ? $query->expand($args)
+ : $query;
+
+ wantarray or return $sql;
+ return $sql, @bind;
}
-sub qex { ref $_[0] ? $_[0]->expand($_[1]) : $_[0] }
+# XXX this is almost but not quite the same as expand_query
+sub qex { is_defer $_[0] ? $_[0]->expand($_[1]) : $_[0] }
+
+sub undefer {
+ my ($d, $q) = @_;
+ #no overloading;
+ is_cv $d and $d = $d->($q);
+ #no warnings "uninitialized";
+ #trace EXP => "UNDEFER [$_[0]] -> [$d]";
+ $d;
+}
sub expand {
my ($self, $q) = @_;
- my $sql = $self;
- while (ref $sql) {
- trace EXP => "[$sql]";
- $self = $sql;
- $sql = djoin "",
- map ref $_ ? $_->($self, $q) : $_,
- @{$self->[0]};
+ tracex {
+ @{$self->[0]} < 2 and return;
+ "[$self]";
+ } "EXP";
+ my $sql = djoin "", map undefer($_, $q), @{ $self->[0] };
+# tracex {
+# no overloading;
+# "-> [$sql]";
+# } "EXP";
+
+ if (defined $sql and not is_defer $sql) {
+ s/^\s+//, s/\s+$// for $sql;
}
- s/^\s+//, s/\s+$// for $sql;
-
- my @bind = map $self->$_($q),
- @{ $self->[1] };
+ wantarray or return $sql;
+ my @bind = map $_->($q), @{ $self->[1] };
return $sql, @bind;
}
# XXX This all needs tidying up. There is a huge amount of duplication,
# not to mention the whole thing being pretty unreadable.
-tie our @Arg, "Tie::OneOff",
- FETCH => sub {
- my ($k) = @_;
- placeholder { $_[1]{args}[$k] } '@Arg';
- },
- FETCHSIZE => sub { undef };
-tie our %Arg, "Tie::OneOff", sub {
+our %Q;
+tie %Q, "Tie::OneOff", sub {
my ($k) = @_;
- placeholder {
- my $hv = $_[1]{arghv} ||= { @{$_[1]{args}} };
- $hv->{$k};
- } '%Arg';
+ defer {
+ my ($q) = @_;
+ my $id = qex $k, $q;
+
+ # If we haven't got a DB yet, croak
+ $q->{db} or croak "can't use %Q without a db";
+
+ $q->{dbh} ||= $q->{db}->dbh;
+ $q->{dbh}->quote_identifier($id)
+ } '%Q';
+};
+tie our %P, "Tie::OneOff", sub {
+ my ($k) = @_;
+ placeholder { qex $k, $_[0] } '%P';
};
-# Unquoted versions
tie our @ArgX, "Tie::OneOff",
FETCH => sub {
my ($k) = @_;
- defer { $_[1]{args}[$k] } '@ArgX';
+ defer { qex $_[0]{args}[$k], $_[0] } '@ArgX';
},
FETCHSIZE => sub { undef };
tie our %ArgX, "Tie::OneOff", sub {
my ($k) = @_;
defer {
- my $hv = $_[1]{arghv} ||= { @{$_[1]{args}} };
- $hv->{$k};
+ my $hv = $_[0]{arghv} ||= { @{$_[0]{args}} };
+ qex $hv->{$k}, $_[0];
} '%ArgX';
};
-tie our %Q, "Tie::OneOff", sub {
- my ($k) = @_;
- defer {
- my ($s, $q) = @_;
- $q->{dbh} ||= $q->{self}->_DB->dbh;
- $q->{dbh}->quote_identifier(qex $k, $q)
- } '%Q';
-};
-tie our %P, "Tie::OneOff", sub {
- my ($k) = @_;
- placeholder { $k } '%P';
-};
+tie our @Arg, "Tie::OneOff",
+ FETCH => subname('@Arg', sub { $P{ $ArgX[$_[0]] } }),
+ FETCHSIZE => sub { undef };
+tie our %Arg, "Tie::OneOff",
+ subname '%Arg', sub { $P{ $ArgX[$_[0]] } };
+
+tie our @ArgQ, "Tie::OneOff",
+ FETCH => subname('@ArgQ', sub { $Q{ $ArgX[$_[0]] } }),
+ FETCHSIZE => sub { undef };
+tie our %ArgQ, "Tie::OneOff",
+ subname '%ArgQ', sub { $Q{ $ArgX{$_[0]} } };
our $Cols = defer {
- $_[1]{dbh} ||= $_[1]{self}->_DB->dbh;
+ $_[0]{dbh} ||= $_[0]{self}->_DB->dbh;
join ", ",
- map $_[1]{dbh}->quote_identifier($_),
- @{$_[1]{row}{cols}};
+ map $_[0]{dbh}->quote_identifier($_),
+ @{$_[0]{row}{cols}};
} '$Cols';
tie our %Cols, "Tie::OneOff", sub {
my ($k) = @_;
defer {
- $_[1]{dbh} ||= $_[1]{self}->_DB->dbh;
+ $_[0]{dbh} ||= $_[0]{self}->_DB->dbh;
join ", ",
- map $_[1]{dbh}->quote_identifier($k, $_),
- @{$_[1]{row}{cols}};
+ map $_[0]{dbh}->quote_identifier($k, $_),
+ @{$_[0]{row}{cols}};
} '%Cols';
};
@@ -153,17 +201,14 @@ tie our %Queries, "Tie::OneOff", sub {
$reg->{qs}{$k} or croak "$class has no query '$k'";
};
-tie our %Self, "Tie::OneOff", sub {
- my ($k) = @_;
- trace QRY => "SELF: [" . overload::StrVal($k) . "]";
- placeholder { $_[1]{self}->$k } '%Self';
-};
-
-# Unquoted
tie our %SelfX, "Tie::OneOff", sub {
my ($k) = @_;
- trace QRY => "SELFX: [" . overload::StrVal($k) . "]";
- defer { $_[1]{self}->$k } '%SelfX';
+ trace QRY => "SELF: [" . overload::StrVal($k) . "]";
+ defer { qex $_[0]{self}->$k, $_[0] } '%SelfX';
};
+tie our %Self, "Tie::OneOff",
+ subname '%Self', sub { $P{ $SelfX{$_[0]} } };
+tie our %SelfQ, "Tie::OneOff",
+ subname '%SelfQ', sub { $Q{ $SelfX{$_[0]} } };
1;
View
20 lib/DBIx/Irian/QuerySet.pm
@@ -6,14 +6,15 @@ use strict;
# properly speaking this ought to be a role
use DBIx::Irian undef, qw(
- install_sub lookup load_class trace tracex
+ install_sub lookup load_class trace tracex expand_query
);
use DBIx::Irian::Cursor;
use Carp;
+use Scalar::Util qw/reftype blessed/;
BEGIN { our @CLEAN = qw(
- carp croak
+ carp croak reftype blessed
register_query install_db_method build_query build_row_query
) }
@@ -44,7 +45,8 @@ sub install_db_method {
trace QRY => "CALL [$method] [$pkg][$name]";
- $self->_DB->$method(@$margs, {
+ my $DB = $self->_DB;
+ $DB->$method(@$margs, {
@$xargs,
self => $self,
args => \@args,
@@ -124,10 +126,22 @@ MOD
load_class $pkg, $row, "Row";
},
+ method => sub {
+ my ($name, $meth) = @_;
+ my $pkg = caller;
+
+ trace QRY => "METHOD [$pkg][$name]: [$meth]";
+ install_sub $pkg, $name,
+ ref $meth && !blessed $meth && reftype $meth eq "CODE"
+ ? $meth
+ : sub { $meth };
+ },
+
queryset => sub {
my ($name, $qs) = @_;
my $pkg = caller;
my $class = load_class $pkg, $qs, "QuerySet";
+ trace QRY => "QUERYSET [$pkg][$name]: [$class]";
install_sub $pkg, $name, sub {
$class->_new($_[0]->_DB)
};

No commit comments for this range

Something went wrong with that request. Please try again.