File Coverage

blib/lib/CPAN/SQLite/DBI/Search.pm

Criterion	Covered	Total	%
statement	180	197	91.3
branch	69	92	75.0
condition	10	17	58.8
subroutine	21	21	100.0
pod	2	4	50.0
total	282	331	85.2

# $Id: Search.pm 82 2020-05-30 06:14:27Z stro $

package CPAN::SQLite::DBI::Search;

use strict;
use warnings;

BEGIN {
  our $VERSION = '0.218';
  $CPAN::SQLite::DBI::Search::info::VERSION  = $VERSION;
  $CPAN::SQLite::DBI::Search::mods::VERSION  = $VERSION;
  $CPAN::SQLite::DBI::Search::dists::VERSION = $VERSION;
  $CPAN::SQLite::DBI::Search::auths::VERSION = $VERSION;
}

use parent 'CPAN::SQLite::DBI';
use CPAN::SQLite::DBI qw($tables $dbh);
use CPAN::SQLite::Util qw($full_id);

package CPAN::SQLite::DBI::Search::info;
use parent 'CPAN::SQLite::DBI::Search';
use CPAN::SQLite::DBI qw($dbh);

package CPAN::SQLite::DBI::Search::mods;
use parent 'CPAN::SQLite::DBI::Search';
use CPAN::SQLite::DBI qw($dbh);

package CPAN::SQLite::DBI::Search::dists;
use parent 'CPAN::SQLite::DBI::Search';
use CPAN::SQLite::DBI qw($dbh);

package CPAN::SQLite::DBI::Search::auths;
use parent 'CPAN::SQLite::DBI::Search';
use CPAN::SQLite::DBI qw($dbh);

package CPAN::SQLite::DBI::Search;
use parent 'CPAN::SQLite::DBI';
use CPAN::SQLite::DBI qw($tables $dbh);
use CPAN::SQLite::Util qw($full_id download);

sub fetch {
  my ($self, %args) = @_;
  my $fields = $args{fields};
  my $search = $args{search};
  my @fields = ref($fields) eq 'ARRAY' ? @{$fields} : ($fields);
  my $sql    = $self->sql_statement(%args) or do {
    $self->{error} = 'Error constructing sql statement: ' . $self->{error};
    return;
  };
  my $sth = $dbh->prepare($sql) or do {
    $self->db_error();
    return;
  };
  $sth->execute() or do {
    $self->db_error($sth);
    return;
  };

  if (not $search->{wantarray}) {
    my (%results, $results);
    @results{@fields} = $sth->fetchrow_array;
    $results = ($sth->rows == 0) ? undef : \%results;
    $sth->finish;
    undef $sth;
    $self->extra_info($results) if $results;
    return $results;
  } else {
    my (%hash, $results);
    while (@hash{@fields} = $sth->fetchrow_array) {
      my %tmp = %hash;
      $self->extra_info(\%tmp);
      push @{$results}, \%tmp;
    }
    $results = undef if ($sth->rows == 0);
    $sth->finish;
    undef $sth;
    return $results;
  }
}

sub fetch_and_set {
  my ($self, %args) = @_;
  my $fields   = $args{fields};
  my $search   = $args{search};
  my $meta_obj = $args{meta_obj};
  die "Please supply a CPAN::SQLite::Meta::* object"
    unless ($meta_obj and ref($meta_obj) =~ /^CPAN::SQLite::META/);
  my @fields = ref($fields) eq 'ARRAY' ? @{$fields} : ($fields);
  my $sql = $self->sql_statement(%args) or do {
    $self->{error} = 'Error constructing sql statement: ' . $self->{error};
    return;
  };
  my $sth = $dbh->prepare($sql) or do {
    $self->db_error();
    return;
  };
  $sth->execute() or do {
    $self->db_error($sth);
    return;
  };

  my $want_ids = $args{want_ids};
  my $set_list = $args{set_list};
  my $download = $args{download};
  if (not $search->{wantarray}) {
    my (%results, %meta_results, $results);
    @results{@fields} = $sth->fetchrow_array;
    $results = ($sth->rows == 0) ? undef : \%results;
    $sth->finish;
    undef $sth;
    return unless $results;
    $self->extra_info($results);
    $meta_obj->set_data($results);

    if ($want_ids) {
      $meta_results{dist_id} = $results{dist_id};
      $meta_results{download} = download($results{cpanid}, $results{dist_file});
      return \%meta_results;
    } else {
      return 1;
    }
  } else {
    my (%hash, $meta_results);
    while (@hash{@fields} = $sth->fetchrow_array) {
      my %tmp = %hash;
      if ($set_list) {
        push @{$meta_results}, \%tmp;
      } else {
        $self->extra_info(\%tmp);
        $meta_obj->set_data(\%tmp);
        if ($want_ids) {
          my $download = download($tmp{cpanid}, $tmp{dist_file});
          push @{$meta_results},
            {
            dist_id  => $tmp{dist_id},
            download => $download
            };

        }
      }
    }
    $meta_results = undef if ($sth->rows == 0);
    $sth->finish;
    undef $sth;
    return unless $meta_results;
    $meta_obj->set_list_data($meta_results, $download) if $set_list;
    return $want_ids ? $meta_results : 1;
  }
}

sub extra_info {
  my ($self, $results) = @_;
  if ($results->{cpanid} and $results->{dist_file}) {
    $results->{download} = download($results->{cpanid}, $results->{dist_file});
  }
  return;
}

sub sql_statement {
  my ($self, %args) = @_;

  my $search   = $args{search};
  my $distinct = $search->{distinct} ? 'DISTINCT' : '';
  my $table    = $args{table};

  my $fields = $args{fields};
  my @fields = ref($fields) eq 'ARRAY' ? @{$fields} : ($fields);
  for (@fields) {
    $_ = $full_id->{$_} if $full_id->{$_};
  }

  my $sql   = qq{SELECT $distinct } . join(',', @fields);
  my $where = '';
  my $type  = $search->{type};
QUERY: {
    ($type eq 'query') and do {
      my $value = $search->{value};
      last QUERY if ($value eq '^');
      my $name     = $search->{name};
      my $text     = $search->{text};
      my $use_like = ($value =~ /^\^?[A-Za-z0-9_\\\:\-]+$/) ? 1 : 0;
      my $prepend  = '%';
      if ($use_like and $value =~ /^\^/) {
        $prepend = '';
        $value =~ s/^\^//;
        $value =~ s{\\}{}g;
      }
      $where =
        $use_like
        ? qq{$name LIKE '$prepend$value%'}
        : qq{$name REGEXP '(?i:$value)'};

      if ($name eq 'cpanid') {
        $where .=
          $use_like
          ? qq{ OR $text LIKE '$prepend$value%'}
          : qq{ OR $text REGEXP '(?i:$value)'};
      }
      last QUERY;
    };
    ($type eq 'id') and do {
      $where = qq{ $search->{id} = $search->{value} };
      last QUERY;
    };
    ($type eq 'name') and do {
      $where = qq{ $search->{name} = '$search->{value}' };
      last QUERY;
    };
    warn qq{Unknown query type};
    return;
  }
  my $join;

  $sql .= ' FROM ' . $table;
  my $left_join = $args{join} || $args{left_join};
  if ($left_join) {
    if (ref($left_join) eq 'HASH') {
      foreach my $key (keys %$left_join) {
        my $id = $left_join->{$key};
        $sql .= " LEFT JOIN $key ON $table.$id=$key.$id ";
      }
    }
  }

  if ($where) {
    $sql .= ' WHERE ( ' . $where . ' )';
    $sql .= ' AND (' . $join . ')' if $join;
  } else {
    $sql .= ' WHERE (' . $join . ')' if $join;
  }

  my $order_by = '';
  if (my $user_order_by = $args{order_by}) {
    $order_by = $order_by ? "$order_by,$user_order_by" : $user_order_by;
  }
  if ($order_by and $where) {
    $sql .= qq{ ORDER BY $order_by };
  }

  if (my $limit = $args{limit}) {
    my ($min, $max) =
      ref($limit) eq 'HASH'
      ? ($limit->{min} || 0, $limit->{max})
      : (0, $limit);
    $sql .= qq{ LIMIT $min,$max };
  }
  return $sql;
}

1;

=head1 NAME

CPAN::SQLite::DBI::Search - DBI information for searching the CPAN::SQLite database

=head1 VERSION

version 0.218

=head1 DESCRIPTION

This module provides methods for L for searching
the C database. There are two main methods.

=over

=item C

This takes information from C and sets up
a query on the database, returning the results found.

=item C

This is used by the C method to construct the appropriate
SQL statement.

=back

=head1 SEE ALSO

L

=cut