File Coverage

blib/lib/Rubric/Entry/Query.pm

Criterion	Covered	Total	%
statement	83	83	100.0
branch	35	40	87.5
condition	8	13	61.5
subroutine	23	23	100.0
pod	13	13	100.0
total	162	172	94.1

use strict;
use warnings;
# ABSTRACT: construct and execute a complex query

#pod =head1 DESCRIPTION
#pod
#pod Rubric::Entry::Query builds a query based on a simple hash of parameters,
#pod performs that query, and returns the rendered report on the results.
#pod
#pod =cut

use Date::Span;
use Digest::MD5 qw(md5_hex);

use Rubric::Config;

#pod =head1 METHODS
#pod
#pod =head2 query(\%arg, \%context)
#pod
#pod This is the only interface to this module.  Given a hashref of named arguments,
#pod it returns the entries that match constraints built from the arguments.  It
#pod generates these constraints with C<get_constraint> and its helpers.  If any
#pod constraint is invalid, an empty set of results is returned.
#pod
#pod The second hashref passed to the method provides context for generating
#pod implicit query parameters; for example, if the querying user is indicated in
#pod the context, private entries for that user will be returned.
#pod
#pod =cut

	my ($self, $user) = @_;
	my $priv_tag = Rubric::Config->private_tag;
	   $priv_tag = Rubric::Entry->db_Main->quote($priv_tag);

	return "id NOT IN (SELECT entry FROM entrytags WHERE tag=$priv_tag)"
		unless $user;

	$user = Rubric::Entry->db_Main->quote($user);
	return
		"((username = $user) OR " .
		"id NOT IN (SELECT entry FROM entrytags WHERE tag=$priv_tag))";
}

	return q{id NOT IN (SELECT entry FROM entrytags WHERE tag='@nolist')};
}

	my ($self, $arg, $context) = @_;
	$context ||= {};

	my @constraints = map { $self->get_constraint($_, $arg->{$_}) } keys %$arg;
	@constraints = ("1 = 0") if grep { not defined } @constraints;

  push @constraints, $self->_nolist_constraint;
	push @constraints, $self->_private_constraint($context->{user})
		if exists $context->{user};

  ## no critic (ConditionalDeclarations)
	my $order_by = "$context->{order_by} DESC"
		if $context->{order_by}||'' =~ /\A(?:created|modified)\Z/;

	$self->get_entries(\@constraints, $order_by);
}

#pod =head2 get_constraint($param => $value)
#pod
#pod Given a name/value pair describing a constraint, this method will attempt to
#pod generate part of an SQL WHERE clause enforcing the constraint.  To do this, it
#pod looks for and calls a method called "constraint_for_NAME" where NAME is the
#pod passed value of C<$param>.  If no clause can be generated, it returns undef.
#pod
#pod =cut

	my ($self, $param, $value) = @_;

  ## no critic (ReturnUndef)
	return undef unless my $code = $self->can("constraint_for_$param");
	$code->($self, $value);
}

#pod =head2 get_entries(\@constraints)
#pod
#pod Given a set of SQL constraints, this method builds the WHERE and ORDER BY
#pod clauses and performs a query with Class::DBI's C<retrieve_from_sql>.
#pod
#pod =cut

	my ($self, $constraints, $order_by) = @_;
	$order_by ||= 'created DESC';
	return Rubric::Entry->retrieve_all unless @$constraints;
	Rubric::Entry->retrieve_from_sql(
		join(" AND ", @$constraints)
		. " ORDER BY $order_by"
	);
}

#pod =head2 constraint_for_NAME
#pod
#pod These methods are called to produce SQL for the named parameter, and are passed
#pod a scalar argument.  If the argument is not valid, they return undef, which will
#pod cause C<query> to produce an empty set of records.
#pod
#pod =head3 constraint_for_user($user)
#pod
#pod Given a Rubric::User object, this returns SQL to limit results to entries by
#pod the user.
#pod
#pod =cut

	my ($self, $user) = @_;
  ## no critic (ReturnUndef)
	return undef unless $user;
	return "username = " . Rubric::Entry->db_Main->quote($user);
}

#pod =head3 constraint_for_tags($tags)
#pod
#pod =head3 constraint_for_exact_tags($tags)
#pod
#pod Given a set of tags, this returns SQL to limit results to entries marked
#pod with the given tags.
#pod
#pod The C<exact> version of this constraint returns SQL for entries with only the
#pod given tags.
#pod
#pod =cut

	my ($self, $tags) = @_;

  ## no critic (ReturnUndef)
	return undef unless $tags and ref $tags eq 'HASH';
  ## use critic
	return unless %$tags;

  my @snippets;
  while (my ($tag, $tag_value) = each %$tags) {
    my $tn = Rubric::Entry->db_Main->quote($tag);
    my $tv = Rubric::Entry->db_Main->quote($tag_value);
    push @snippets, defined $tag_value
      ? "id IN (SELECT entry FROM entrytags WHERE tag=$tn AND tag_value=$tv)"
      : "id IN (SELECT entry FROM entrytags WHERE tag=$tn)"
  }

	return join ' AND ', @snippets;
}

	my ($self, $tags) = @_;

  ## no critic (ReturnUndef)
	return undef unless $tags and ref $tags eq 'HASH';
  ## use critic

  my $count = keys %$tags;

	# XXX determine which one is faster
	return
		"(SELECT COUNT(tag) FROM entrytags WHERE entry = entries.id) = $count",
#		"id IN (SELECT entry FROM entrytags GROUP BY entry HAVING COUNT(tag) = $count)",
		$self->constraint_for_tags($tags);
}

#pod =head3 constraint_for_desc_like($value)
#pod
#pod =cut

	my ($self, $value) = @_;
	my $like = substr Rubric::Entry->db_Main->quote($value), 1, -1;
	"(description LIKE '\%$like\%' OR title LIKE '\%$like\%')"
}

#pod =head3 constraint_for_body_like($value)
#pod
#pod =cut

	my ($self, $value) = @_;
	my $like = substr Rubric::Entry->db_Main->quote($value), 1, -1;
	"(body LIKE '\%$like\%')"
}

#pod =head3 constraint_for_like($value)
#pod
#pod =cut

	my ($self, $value) = @_;
	"("  . $self->constraint_for_desc_like($value) .
	"OR" . $self->constraint_for_body_like($value) . ")"
}

#pod =head3 constraint_for_has_body($bool)
#pod
#pod This returns SQL to limit the results to entries with bodies.
#pod
#pod =cut

	my ($self, $bool) = @_;
	return $bool ? "body IS NOT NULL" : "body IS NULL";
}

#pod =head3 constraint_for_has_link($bool)
#pod
#pod This returns SQL to limit the results to entries with links.
#pod
#pod =cut

	my ($self, $bool) = @_;
	return $bool ? "link IS NOT NULL" : "link IS NULL";
}

#pod =head3 constraint_for_first_only($bool)
#pod
#pod This returns SQL to limit the results to the first entry posted for any given
#pod link.
#pod
#pod =cut

	my ($self, $bool) = @_;
	return $bool
		? "(link is NULL OR id IN (SELECT MIN(id) FROM entries GROUP BY link))"
		: ();
}

#pod =head3 constraint_for_urimd5($md5)
#pod
#pod This returns SQL to limit the results to entries whose link has the given
#pod md5sum.
#pod
#pod =cut

	my ($self, $md5) = @_;
  ## no critic (ReturnUndef)
	return undef unless my ($link) = Rubric::Link->search({ md5 => $md5 });
  ## use critic

	return "link = " . $link->id;
}

#pod =head3 constraint_for_{timefield}_{preposition}($datetime)
#pod
#pod This set of six methods return SQL to limit the results based on its
#pod timestamps.
#pod
#pod The passed value is a complete or partial datetime in the form:
#pod
#pod  YYYY[-MM[-DD[ HH[:MM]]]]  # space may be replaced with 'T'
#pod
#pod The timefield may be "created" or "modified".
#pod
#pod The prepositions are as follows:
#pod
#pod  after  - after the latest part of the given unit of time
#pod  before - before the earliest part of the given unit of time
#pod  on     - after (or at) the earliest part and before (or at) the latest part
#pod
#pod =cut

## here there be small lizards
## date parameter handling below...

	my ($datetime) = @_;
	return unless my @unit = $datetime =~
		qr/^(\d{4})(?:-(\d{2})(?:-(\d{2})(?:(?:T|)(\d{2})(?::(\d{2}))?)?)?)?$/o;
	$unit[1]-- if $unit[1];
	return @unit;
}

{
  ## no critic (NoStrict)
	no strict 'refs';
	for my $field (qw(created modified)) {
		for my $prep (qw(after before on)) {
			*{"constraint_for_${field}_${prep}"} = sub {
				my ($self, $datetime) = @_;
        ## no critic (ReturnUndef)
				return undef unless my @time = _unit_from_string($datetime);
        ## use critic

				my ($start,$end) = range_from_unit(@time);
				return
					( $prep eq 'after'  ? "$field > $end"
					: $prep eq 'before' ? "$field < $start"
					:                     "$field >= $start AND $field <= $end")
#					: $prep eq 'on'     ? "$field >= $start AND $field <= $end"
#					: die "illegal preposition in temporal comparison" )
			}
		}
	}
}

1;


=pod

=encoding UTF-8

=head1 NAME

Rubric::Entry::Query - construct and execute a complex query

=head1 VERSION

version 0.157

=head1 DESCRIPTION

Rubric::Entry::Query builds a query based on a simple hash of parameters,
performs that query, and returns the rendered report on the results.

=head1 PERL VERSION

This code is effectively abandonware.  Although releases will sometimes be made
to update contact info or to fix packaging flaws, bug reports will mostly be
ignored.  Feature requests are even more likely to be ignored.  (If someone
takes up maintenance of this code, they will presumably remove this notice.)
This means that whatever version of perl is currently required is unlikely to
change -- but also that it might change at any new maintainer's whim.

=head1 METHODS

=head2 query(\%arg, \%context)

This is the only interface to this module.  Given a hashref of named arguments,
it returns the entries that match constraints built from the arguments.  It
generates these constraints with C<get_constraint> and its helpers.  If any
constraint is invalid, an empty set of results is returned.

The second hashref passed to the method provides context for generating
implicit query parameters; for example, if the querying user is indicated in
the context, private entries for that user will be returned.

=head2 get_constraint($param => $value)

Given a name/value pair describing a constraint, this method will attempt to
generate part of an SQL WHERE clause enforcing the constraint.  To do this, it
looks for and calls a method called "constraint_for_NAME" where NAME is the
passed value of C<$param>.  If no clause can be generated, it returns undef.

=head2 get_entries(\@constraints)

Given a set of SQL constraints, this method builds the WHERE and ORDER BY
clauses and performs a query with Class::DBI's C<retrieve_from_sql>.

=head2 constraint_for_NAME

These methods are called to produce SQL for the named parameter, and are passed
a scalar argument.  If the argument is not valid, they return undef, which will
cause C<query> to produce an empty set of records.

=head3 constraint_for_user($user)

Given a Rubric::User object, this returns SQL to limit results to entries by
the user.

=head3 constraint_for_tags($tags)

=head3 constraint_for_exact_tags($tags)

Given a set of tags, this returns SQL to limit results to entries marked
with the given tags.

The C<exact> version of this constraint returns SQL for entries with only the
given tags.

=head3 constraint_for_desc_like($value)

=head3 constraint_for_body_like($value)

=head3 constraint_for_like($value)

=head3 constraint_for_has_body($bool)

This returns SQL to limit the results to entries with bodies.

=head3 constraint_for_has_link($bool)

This returns SQL to limit the results to entries with links.

=head3 constraint_for_first_only($bool)

This returns SQL to limit the results to the first entry posted for any given
link.

=head3 constraint_for_urimd5($md5)

This returns SQL to limit the results to entries whose link has the given
md5sum.

=head3 constraint_for_{timefield}_{preposition}($datetime)

This set of six methods return SQL to limit the results based on its
timestamps.

The passed value is a complete or partial datetime in the form:

 YYYY[-MM[-DD[ HH[:MM]]]]  # space may be replaced with 'T'

The timefield may be "created" or "modified".

The prepositions are as follows:

 after  - after the latest part of the given unit of time
 before - before the earliest part of the given unit of time
 on     - after (or at) the earliest part and before (or at) the latest part

=head1 AUTHOR

Ricardo SIGNES <[e-mail]>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2004 by Ricardo SIGNES.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut