Initial Commit
This commit is contained in:
Riley Schneider
238
database/perl/vendor/lib/CPAN/SQLite/DBI/Index.pm
vendored
Normal file
238
database/perl/vendor/lib/CPAN/SQLite/DBI/Index.pm
vendored
Normal file
@@ -0,0 +1,238 @@
|
||||
# $Id: Index.pm 84 2020-05-31 06:29:34Z stro $
|
||||
|
||||
package CPAN::SQLite::DBI::Index;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
BEGIN {
|
||||
our $VERSION = '0.219';
|
||||
$CPAN::SQLite::DBI::Index::info::VERSION = $VERSION;
|
||||
$CPAN::SQLite::DBI::Index::mods::VERSION = $VERSION;
|
||||
$CPAN::SQLite::DBI::Index::dists::VERSION = $VERSION;
|
||||
$CPAN::SQLite::DBI::Index::auths::VERSION = $VERSION;
|
||||
}
|
||||
|
||||
use CPAN::SQLite::DBI qw($dbh);
|
||||
use parent 'CPAN::SQLite::DBI';
|
||||
|
||||
package CPAN::SQLite::DBI::Index::info;
|
||||
use parent 'CPAN::SQLite::DBI::Index';
|
||||
use CPAN::SQLite::DBI qw($dbh);
|
||||
|
||||
package CPAN::SQLite::DBI::Index::mods;
|
||||
use parent 'CPAN::SQLite::DBI::Index';
|
||||
use CPAN::SQLite::DBI qw($dbh);
|
||||
|
||||
package CPAN::SQLite::DBI::Index::dists;
|
||||
use parent 'CPAN::SQLite::DBI::Index';
|
||||
use CPAN::SQLite::DBI qw($dbh);
|
||||
|
||||
sub fetch_ids {
|
||||
my $self = shift;
|
||||
my $sql = sprintf(qq{SELECT %s,%s,%s FROM %s}, $self->{id}, $self->{name}, 'dist_vers', $self->{table});
|
||||
my $sth = $dbh->prepare($sql) or do {
|
||||
$self->db_error();
|
||||
return;
|
||||
};
|
||||
$sth->execute() or do {
|
||||
$self->db_error($sth);
|
||||
return;
|
||||
};
|
||||
my ($ids, $versions);
|
||||
while (my ($id, $key, $vers) = $sth->fetchrow_array()) {
|
||||
$ids->{$key} = $id;
|
||||
$versions->{$key} = $vers;
|
||||
}
|
||||
$sth->finish;
|
||||
undef $sth;
|
||||
return ($ids, $versions);
|
||||
}
|
||||
|
||||
package CPAN::SQLite::DBI::Index::auths;
|
||||
use parent 'CPAN::SQLite::DBI::Index';
|
||||
use CPAN::SQLite::DBI qw($dbh);
|
||||
|
||||
package CPAN::SQLite::DBI::Index;
|
||||
use CPAN::SQLite::DBI qw($tables);
|
||||
use CPAN::SQLite::DBI qw($dbh);
|
||||
|
||||
sub fetch_ids {
|
||||
my $self = shift;
|
||||
my $sql = sprintf(qq{SELECT %s,%s from %s}, $self->{id}, $self->{name}, $self->{table});
|
||||
my $sth = $dbh->prepare($sql) or do {
|
||||
$self->db_error();
|
||||
return;
|
||||
};
|
||||
$sth->execute() or do {
|
||||
$self->db_error($sth);
|
||||
return;
|
||||
};
|
||||
my $ids;
|
||||
while (my ($id, $key) = $sth->fetchrow_array()) {
|
||||
$ids->{$key} = $id;
|
||||
}
|
||||
$sth->finish;
|
||||
undef $sth;
|
||||
return $ids;
|
||||
}
|
||||
|
||||
sub schema {
|
||||
my ($self, $data) = @_;
|
||||
my $schema = '';
|
||||
foreach my $type (qw(primary other)) {
|
||||
foreach my $column (keys %{ $data->{$type} }) {
|
||||
$schema .= $column . ' ' . $data->{$type}->{$column} . ", ";
|
||||
}
|
||||
}
|
||||
$schema =~ s{, $}{};
|
||||
return $schema;
|
||||
}
|
||||
|
||||
sub create_index {
|
||||
my ($self, $data) = @_;
|
||||
my $key = $data->{key};
|
||||
my $table = $self->{table};
|
||||
return 1 unless (defined $key and ref($key) eq 'ARRAY');
|
||||
foreach my $index (@$key) {
|
||||
my $id_name = 'ix_' . $table . '_' . $index;
|
||||
$id_name =~ s/\(\s*\d+\s*\)//;
|
||||
my $sql = 'CREATE INDEX ' . $id_name . ' ON ' . $table . '( ' . $index . ' )';
|
||||
my $sth = $dbh->prepare($sql);
|
||||
$sth->execute() or do {
|
||||
$self->db_error($sth);
|
||||
return;
|
||||
};
|
||||
$sth->finish;
|
||||
undef $sth;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub drop_table {
|
||||
my $self = shift;
|
||||
my $table = $self->{table};
|
||||
my $sql = qq{SELECT name FROM sqlite_master } . qq{ WHERE type='table' AND name=?};
|
||||
my $sth = $dbh->prepare($sql);
|
||||
$sth->execute($table);
|
||||
if (defined $sth->fetchrow_array) {
|
||||
$dbh->do(qq{drop table $table}) or do {
|
||||
$self->db_error($sth);
|
||||
return;
|
||||
};
|
||||
}
|
||||
$sth->finish;
|
||||
undef $sth;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub create_table {
|
||||
my ($self, $schema) = @_;
|
||||
return unless $schema;
|
||||
my $sql = sprintf(qq{CREATE TABLE %s (%s)}, $self->{table}, $schema);
|
||||
my $sth = $dbh->prepare($sql);
|
||||
$sth->execute() or do {
|
||||
$self->db_error($sth);
|
||||
return;
|
||||
};
|
||||
$sth->finish;
|
||||
undef $sth;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub create_tables {
|
||||
my ($self, %args) = @_;
|
||||
return unless $args{setup};
|
||||
my $objs = $self->{objs};
|
||||
foreach my $table (keys %$objs) {
|
||||
next unless my $schema = $self->schema($tables->{$table});
|
||||
my $obj = $objs->{$table};
|
||||
$obj->drop_table or return;
|
||||
$obj->create_table($schema) or return;
|
||||
$obj->create_index($tables->{$table}) or return;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub sth_insert {
|
||||
my ($self, $fields) = @_;
|
||||
my $flds = join ',', @{$fields};
|
||||
my $vals = join ',', map { '?' } @{$fields};
|
||||
my $sql = sprintf(qq{INSERT INTO %s (%s) VALUES (%s)}, $self->{table}, $flds, $vals);
|
||||
|
||||
my $sth = $dbh->prepare($sql) or do {
|
||||
$self->db_error();
|
||||
return;
|
||||
};
|
||||
return $sth;
|
||||
}
|
||||
|
||||
sub sth_update {
|
||||
my ($self, $fields, $id, $rep_id) = @_;
|
||||
my $set = join ',', map { "$_=?" } @{$fields};
|
||||
my $sql = sprintf(qq{UPDATE %s SET %s WHERE %s = %s}, $self->{table}, $set, $self->{id}, $id);
|
||||
$sql .= qq { AND rep_id = $rep_id } if ($rep_id);
|
||||
my $sth = $dbh->prepare($sql) or do {
|
||||
$self->db_error();
|
||||
return;
|
||||
};
|
||||
return $sth;
|
||||
}
|
||||
|
||||
sub sth_delete {
|
||||
my ($self, $table_id, $rep_id) = @_;
|
||||
my $sql = sprintf(qq{DELETE FROM %s where %s = ?}, $self->{table}, $table_id);
|
||||
$sql .= qq { AND rep_id = $rep_id } if ($rep_id);
|
||||
my $sth = $dbh->prepare($sql) or do {
|
||||
$self->db_error();
|
||||
return;
|
||||
};
|
||||
return $sth;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
CPAN::SQLite::DBI::Index - DBI information for indexing the CPAN::SQLite database
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.219
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides various methods for L<CPAN::SQLite::Index> in
|
||||
indexing and populating the database from the index files.
|
||||
|
||||
=over
|
||||
|
||||
=item C<create_tables>
|
||||
|
||||
This creates the database tables.
|
||||
|
||||
=item C<drop_table>
|
||||
|
||||
This drops a table.
|
||||
|
||||
=item C<sth_insert>
|
||||
|
||||
This returns an C<$sth> statement handle for inserting
|
||||
values into a table.
|
||||
|
||||
=item C<sth_update>
|
||||
|
||||
This returns an C<$sth> statement handle for updating
|
||||
values into a table.
|
||||
|
||||
=item C<sth_delete>
|
||||
|
||||
This returns an C<$sth> statement handle for deleting
|
||||
values from a table.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<CPAN::SQLite::Index>
|
||||
|
||||
=cut
|
||||
283
database/perl/vendor/lib/CPAN/SQLite/DBI/Search.pm
vendored
Normal file
283
database/perl/vendor/lib/CPAN/SQLite/DBI/Search.pm
vendored
Normal file
@@ -0,0 +1,283 @@
|
||||
# $Id: Search.pm 84 2020-05-31 06:29:34Z stro $
|
||||
|
||||
package CPAN::SQLite::DBI::Search;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
BEGIN {
|
||||
our $VERSION = '0.219';
|
||||
$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.219
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides methods for L<CPAN::SQLite::Search> for searching
|
||||
the C<CPAN::SQLite> database. There are two main methods.
|
||||
|
||||
=over
|
||||
|
||||
=item C<fetch>
|
||||
|
||||
This takes information from C<CPAN::SQLite::Search> and sets up
|
||||
a query on the database, returning the results found.
|
||||
|
||||
=item C<sql_statement>
|
||||
|
||||
This is used by the C<fetch> method to construct the appropriate
|
||||
SQL statement.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<CPAN::SQLite::Search>
|
||||
|
||||
=cut
|
||||
Reference in New Issue
Block a user