ACME-QuoteDB
view release on metacpan or search on metacpan
#TODO give user choices about installing the quotes database
#i.e. location/permissions/owner, others?
use strict;
use warnings;
use Module::Build;
my $class = Module::Build->subclass(code => <<'EOF');
use File::Spec;
use File::Copy;
use File::Basename qw/dirname/;
sub process_db_files {
my $self = shift;
my $qdb = File::Spec->catfile(qw(lib ACME QuoteDB DB quotedb), 'quotes.db');
my $_t = File::Spec->catfile(qw(blib lib ACME QuoteDB DB quotedb), 'quotes.db');
mkdir dirname($_t);
chmod(0777, dirname($_t));
copy($qdb, $_t);
chmod(0666, $_t);
}
sub ACTION_install {
my $self = shift;
$self->SUPER::ACTION_install(@_);
my $ddir = $self->install_destination('lib');
#TODO give user choices about installing the quotes database
#my $ques = 'Where do you want to install the quotes database?';
#my $quote_dest = $self->prompt($ques, $ddir);
my $db = q{};
my $perms = 0666;
my $d_perms = 0777;
#if ($quote_dest != $ddir) {
lib/ACME/QuoteDB.pm view on Meta::CPAN
use Data::Dumper qw/Dumper/;
use ACME::QuoteDB::LoadDB;
use aliased 'ACME::QuoteDB::DB::Attribution' => 'Attr';
use aliased 'ACME::QuoteDB::DB::QuoteCatg' => 'QuoteCatg';
use aliased 'ACME::QuoteDB::DB::Category' => 'Catg';
use aliased 'ACME::QuoteDB::DB::Quote' => 'Quote';
binmode STDOUT, ':encoding(utf8)';
binmode STDERR, ':encoding(utf8)';
sub new {
my $class = shift;
my $self = bless {}, $class;
return $self;
}
# provide 1 non OO method for one liners
sub quote {
my ($arg_ref) = @_;
return get_quote(q{}, $arg_ref);
}
# list of quote attributions (names) (makes searching easier)
sub list_attr_names {
return _get_field_all_from('name', Attr->retrieve_all);
}
# list of quote categories
sub list_categories {
return _get_field_all_from('catg', Catg->retrieve_all);
}
## list of quote sources
sub list_attr_sources {
return _get_field_all_from('source', Quote->retrieve_all);
}
sub _get_field_all_from {
my ($field, @all_stored) = @_;
my $arr_ref = [];
RECORDS:
foreach my $f_obj (@all_stored){
my $s = $f_obj->$field;
# if doesn't exist and not a dup
if (! $f_obj->$field || scalar grep {/$s/sm} @{$arr_ref}){
next RECORDS;
}
push @{ $arr_ref }, $f_obj->$field;
}
return join "\n", sort @{$arr_ref};
}
sub _get_attribution_ids_from_name {
my ($attr_name) = @_;
my $c_ids = [];
# a bug: what if string starts with what we specify
#i.e. => %Griffin% doesn' match 'Griffin' (no quotes)
RESULTS:
foreach my $c_obj (Attr->search_like(name => "%$attr_name%")){
next RESULTS unless $c_obj->attr_id;
push @{ $c_ids }, $c_obj->attr_id;
}
if (not scalar @{$c_ids}) {
croak 'attribution not found';
}
return $c_ids;
}
sub _get_quote_id_from_quote {
my ($quote) = @_;
my $q_ids = [];
# a bug: what if string starts with what we specify
#i.e. => %Griffin% doesn' match 'Griffin' (no quotes)
RESULTS:
foreach my $c_obj (Quote->search(quote => $quote)){
next RESULTS unless $c_obj->quot_id;
push @{ $q_ids }, $c_obj->quot_id;
}
if (not scalar @{$q_ids}) {
croak 'quote not found';
}
return $q_ids;
}
# can handle scalar or array ref
sub _rm_beg_end_space {
my ($v) = @_;
return unless $v;
if (ref $v eq 'ARRAY'){
my $arr_ref = ();
foreach my $vl (@{$v}){
push @{$arr_ref}, _rm_beg_end_space($vl);
}
return $arr_ref;
}
else {
$v =~ s/\A\s+//xmsg;
$v =~ s/\s+\z//xmsg;
return $v;
}
return;
}
sub _get_one_rand_quote_from_all {
#my $quotes_ref = [];
#foreach my $q_obj (Quote->retrieve_all){
# next unless $q_obj->quote;
# my $record = Attr->retrieve($q_obj->attr_id);
# my $attr_name = $record->name || q{};
# push @{ $quotes_ref }, $q_obj->quote . "\n-- $attr_name";
#}
my $quotes_ref = _get_quote_ref_from_all(Quote->retrieve_all);
return $quotes_ref->[rand scalar @{$quotes_ref}];
}
sub _get_rating_params {
my ($rating) = @_;
return unless $rating;
my ($lower, $upper) = (q{}, q{});
($lower, $upper) = split /-/sm, $rating;
if ($upper && !$lower) { croak 'negative range not permitted'};
return (_rm_beg_end_space($lower), _rm_beg_end_space($upper));
}
sub _get_if_rating {
my ($lower, $upper) = @_;
if ($lower and $upper) { # a range, find within
$lower = qq/ AND rating >= '$lower' /;
$upper = qq/ AND rating <= '$upper' /;
}
elsif ($lower and not $upper) { # not a range, find exact rating
$lower = qq/ AND rating = '$lower' /
#$upper = q{};
}
elsif ($upper and not $lower) {
$upper = qq/ AND rating = '$upper' /
#$lower = q{};
}
return ($lower, $upper);
}
sub _get_ids_if_catgs_exist {
my ($catgs) = @_;
my $catg_ids = ();
# get category id
RECS:
foreach my $c_obj (Catg->retrieve_all){
next RECS if not $c_obj->catg;
if (ref $catgs eq 'ARRAY'){
foreach my $c (@{$catgs}){
lib/ACME/QuoteDB.pm view on Meta::CPAN
else {
if ($c_obj->catg eq $catgs){
# use cat_id if already exists
push @{$catg_ids}, $c_obj->catg_id;
}
}
}
return $catg_ids;
}
sub _get_quote_id_from_catg_id {
my ($catg_ids) = @_;
my $quote_ids = ();
RECS:
foreach my $qc_obj (QuoteCatg->retrieve_all){
next RECS if not $qc_obj->quot_id;
if (ref $catg_ids eq 'ARRAY'){
foreach my $c (@{$catg_ids}){
if ($qc_obj->catg_id eq $c){
lib/ACME/QuoteDB.pm view on Meta::CPAN
else {
if ($qc_obj->catg_id eq $catg_ids){
# use cat_id if already exists
push @{$quote_ids}, $qc_obj->quot_id;
}
}
}
return $quote_ids;
}
sub _untaint_data {
my ($arr_ref) = @_;
my $ut_ref = ();
foreach my $q (@{$arr_ref}){
if ($q =~ m{\A([0-9]+)\z}sm){
push @{$ut_ref}, $1;
}
}
return $ut_ref;
}
# TODO fixme: arg list too long
sub _get_rand_quote_for_attribution {
my ($attr_name, $lower, $upper, $limit, $contain, $source, $catgs) = @_;
$attr_name ||= q{};
$lower ||= q{};
$upper ||= q{};
$limit ||= q{};
$contain ||= q{};
$source ||= q{};
$catgs ||= q{};
lib/ACME/QuoteDB.pm view on Meta::CPAN
# my $attr_name = $record->name || q{};
# push @{ $quotes_ref }, $q_obj->quote . "\n-- $attr_name";
#}
#return _get_quote_ref_from_all(\@q);
# XXX array_ref does not work here!
return _get_quote_ref_from_all(@q);
#return $quotes_ref;
}
sub _get_quote_ref_from_all {
my (@results) = @_;
#my ($results) = @_;
my $quotes_ref = [];
#foreach my $q_obj ( @{$results} ){
foreach my $q_obj ( @results ){
next unless $q_obj->quote;
my $rec = Attr->retrieve($q_obj->attr_id);
my $attr_name = $rec->name || q{};
push @{ $quotes_ref }, $q_obj->quote . "\n-- $attr_name";
}
return $quotes_ref;
}
sub _args_are_valid {
my ( $arg_ref, $accepted ) = @_;
my $arg_ok = 0;
foreach my $arg ( %{$arg_ref} ) {
if ( scalar grep { $arg =~ $_ } @{$accepted} ) {
$arg_ok = 1;
}
}
if (!$arg_ok) {croak 'unsupported argument option passed'}
}
sub add_quote {
my ( $self, $arg_ref ) = @_;
_args_are_valid($arg_ref, [qw/Quote AttrName Source Rating Category/]);
my $load_db = ACME::QuoteDB::LoadDB->new({
#verbose => 1,
});
$load_db->set_record(quote => $arg_ref->{Quote});
$load_db->set_record(name => $arg_ref->{AttrName});
lib/ACME/QuoteDB.pm view on Meta::CPAN
return $load_db->write_record;
}
else {
croak 'quote and attribution name are mandatory parameters';
}
return;
}
# XXX lame, can only get an id from exact quote
sub get_quote_id {
my ( $self, $arg_ref ) = @_;
if (not $arg_ref) {croak 'Quote required'}
_args_are_valid($arg_ref, [qw/Quote/]);
my $ids = _get_quote_id_from_quote($arg_ref->{'Quote'});
return join "\n", sort @{$ids};
}
sub update_quote {
my ( $self, $arg_ref ) = @_;
if (not $arg_ref) {croak 'QuoteId and Quote required'}
_args_are_valid($arg_ref, [qw/Quote QuoteId Source
Category Rating AttrName/]);
my $q = Quote->retrieve($arg_ref->{'QuoteId'});
my $atr = Attr->retrieve($q->attr_id);
lib/ACME/QuoteDB.pm view on Meta::CPAN
if ($arg_ref->{'AttrName'}){$atr->name($arg_ref->{'AttrName'})};
# XXX need to support multi categories
if ($arg_ref->{'Category'}){
$ctg->catg($arg_ref->{'Category'})
}
return ($q->update && $atr->update && $ctg->update);
}
sub delete_quote {
my ( $self, $arg_ref ) = @_;
if (not $arg_ref) {croak 'QuoteId required'}
_args_are_valid($arg_ref, [qw/QuoteId/]);
my $q = Quote->retrieve($arg_ref->{'QuoteId'});
#$q->quote($arg_ref->{'QuoteId'});
return $q->delete;
}
sub get_quote {
my ( $self, $arg_ref ) = @_;
# default use case, return random quote from all
if (not $arg_ref) {
return _get_one_rand_quote_from_all;
}
_args_are_valid($arg_ref, [qw/Rating AttrName Source Category/]);
my ($lower, $upper) = (q{}, q{});
lib/ACME/QuoteDB.pm view on Meta::CPAN
_get_rand_quote_for_attribution($attr_name, $lower,
$upper, q{}, q{}, $source, $catg);
# one random from specified pool
return $quotes_ref->[rand scalar @{$quotes_ref}];
}
# XXX isn't there a method in DBI for this, bind something,...
# TODO follow up
sub _make_correct_num_of_sql_placeholders {
my ($ids) = @_;
# XXX a hack to make a list of '?' placeholders
my @qms = ();
for (1..scalar @{$ids}) {
push @qms, '?';
}
return join ',', @qms;
}
sub get_quotes {
my ( $self, $arg_ref ) = @_;
# default use case, return random quote from all
if (not $arg_ref) {
return _get_one_rand_quote_from_all;
}
_args_are_valid($arg_ref, [qw/Rating AttrName Limit Category Source/]);
my ($lower, $upper) = (q{}, q{});
lib/ACME/QuoteDB.pm view on Meta::CPAN
if ( $arg_ref->{'Category'} ) {
$catg = _rm_beg_end_space($arg_ref->{'Category'});
}
# use case for attribution, return random quote
return _get_rand_quote_for_attribution($attribution, $lower,
$upper, $limit, q{}, $source, $catg);
}
sub get_quotes_contain {
my ( $self, $arg_ref ) = @_;
my $contain = q{};
if ($arg_ref->{'Contain'}) {
$contain = _rm_beg_end_space($arg_ref->{'Contain'});
}
else {
croak 'Contain is a mandatory parameter';
}
lib/ACME/QuoteDB.pm view on Meta::CPAN
available keys: AttrName, Rating
my $args_ref = {
AttrName => 'chief wiggum'
Rating => 7,
};
print $sq->get_quote($args_ref);
Note: The 'Rating' option is very subjective.
It's a 0-10 scale of 'quality' (or whatever you decide it is)
To get a list of the available AttrNames use the list_attr_names method
listed below.
Any unique part of name will work
Example, for attribution 'comic book guy'
# these will all return the same results
lib/ACME/QuoteDB.pm view on Meta::CPAN
print $sq->get_quotes({AttrName => 'book guy'});
print $sq->get_quotes({AttrName => 'guy'});
# However, keep in mind the less specific the request is the more results
# are returned, for example the last one would match, 'Comic Book Guy',
# 'Buddy Guy' and 'Guy Smiley',...
=begin comment
# XXX this is a bug with sub _get_attribution_ids_from_name
#print $sq->get_quotes({AttrName => 'guy'}); would not match 'Guy Smiley'
=end comment
=head2 add_quote
Adds the supplied record to the database
possible Key arguments consist of:
Quote, AttrName, Source, Rating, Category
lib/ACME/QuoteDB.pm view on Meta::CPAN
=item 1 (Batch Load) load quotes from a csv file. (tested with comma and tab delimiters)
format of file must be as follows: (headers)
"Quote", "Attribution Name", "Attribution Source", "Category", "Rating"
for example:
"Quote", "Attribution Name", "Attribution Source", "Category", "Rating"
"I hope this has taught you kids a lesson: kids never learn.","Chief Wiggum","The Simpsons","Humor",9
"Sideshow Bob has no decency. He called me Chief Piggum. (laughs) Oh wait, I get it, he's all right.","Chief Wiggum","The Simpsons","Humor",8
=item 1 if these dont suit your needs, ACME::QuoteDB::LoadDB is sub-classable,
so one can extract data anyway they like and populate the db themselves.
(there is a test that illustrates overriding the stub method, 'dbload')
you need to populate a record data structure:
$self->set_record(quote => q{}); # mandatory
$self->set_record(name => q{}); # mandatory
$self->set_record(source => q{}); # optional but useful
$self->set_record(catg => q{}); # optional but useful
lib/ACME/QuoteDB.pm view on Meta::CPAN
=back
For more see L<ACME::QuoteDB::LoadDB>
=begin comment
keep pod coverage happy.
# Coverage for ACME::QuoteDB is 71.4%, with 3 naked subroutines:
# Attr
# Quote
# Catg
# QuoteCatg
pod tests incorrectly state, Attr, Quote and Catg are subroutines, well they
are,... (as aliases) but act on a different object.
TODO: explore the above (is this a bug, if so, who's?, version effected,
create use case, etc)
=head2 Attr
=head2 Quote
=head2 Catg
lib/ACME/QuoteDB/DB/DBI.pm view on Meta::CPAN
#busy_timeout => 3600000
}
)
|| croak "$QUOTES_DATABASE does not exist, or cant be created $!";
# how to enable this function?
#ACME::QuoteDB::DB::DBI->set_sql(func( 3600000, 'busy_timeout' );
}
sub get_current_db_path {
return $QUOTES_DATABASE;
}
sub _untaint_db_path {
my $sane_path = abs_path(dirname(__FILE__));
# appease taint mode, what a dir path looks like,... (probably not)
$sane_path =~ m{([a-zA-Z0-9-_\.:\/\\\s]+)}; #add '.', ':' for win32
return $1 || croak 'cannot untaint db path';
}
1;
__END__
lib/ACME/QuoteDB/LoadDB.pm view on Meta::CPAN
use Text::CSV;
use Readonly;
use DBI;
# if not in utf8 latin1 is assumed
my $FILE_ENCODING = 'iso-8859-1';
Readonly my @QUOTE_FIELDS => qw/quote name source catg rating/;
# XXX refactor
sub new {
my ($class, $args) = @_;
# TODO encapsulation
my $self = bless {}, $class;
# store each record we extract - keys map to database fields
# TODO proper encapsulation
$self->{record} = {};
$self->{record}->{quote} = q{};
$self->{record}->{rating} = q{};
lib/ACME/QuoteDB/LoadDB.pm view on Meta::CPAN
$self->{pass} = $ENV{ACME_QUOTEDB_PASS};
}
if (!$args->{dry_run}){$self->{write_db} = 1};
#if ($args->{create_db}) {$self->create_db};
if ($args->{create_db}) {$self->create_db_tables};
return $self;
}
sub set_record {
my ($self, $field, $value) = @_;
# TODO support mult-field simultanous loading
if ($value) {
$self->{record}->{$field} = $value;
}
return $self;
}
sub debug_record {
my ($self) = @_;
print Dumper $self->{record};
return;
}
sub get_record {
my ($self, $field) = @_;
if (not $field){return $self}
return $self->{record}->{$field};
}
sub data_to_db {
my ($self) = @_;
if ($self->{file} and $self->{data} and $self->{dir}){
croak 'only file, data or dir as arg but not both'
}
elsif (! ($self->{file} or $self->{data} or $self->{dir})) {
croak 'file, data or dir needed as arg'
}
if ($self->{file}) {
lib/ACME/QuoteDB/LoadDB.pm view on Meta::CPAN
}
if (! $e){croak 'no files to parse in: ', Dumper $dir;};
}
else {
croak 'no file source in args!', Dumper $self;
}
return;
}
sub _parse_file {
my ($self, $file) = @_;
if (!-f $file) { croak "file not found: $file" }
if ($self->{verbose}){warn "processing file: $file\n"};
if (($self->{file_format} eq 'csv') || ($self->{file_format} eq 'tsv')){
$self->dbload_from_csv($file);
}
elsif (($self->{file_format} eq 'html') || ($self->{file_format} eq 'custom')){
lib/ACME/QuoteDB/LoadDB.pm view on Meta::CPAN
# supply your own
$self->dbload($file);
}
else {
croak 'unsupported file format requested, format must be csv or tsv';
}
return;
}
sub _parse_data {
my ($self, $data) = @_;
if (!$data) {croak "data empty $data"}
if ($self->{verbose}){carp 'processing data:'};
if ($self->{file_format} =~ /(?:csv|tsv)/sm) {
croak 'TODO: not yet supported';
#$self->dbload_from_csv($data);
}
lib/ACME/QuoteDB/LoadDB.pm view on Meta::CPAN
$self->dbload($data);
}
else {
croak 'unsupported file format requested, '
.'format must be csv, tsv. html, custom also possible';
}
return $self;
}
sub _confirm_header_order {
my ($hr) = @_;
return ($hr->{quote} eq 'Quote'
and $hr->{name} eq 'Attribution Name',
and $hr->{source} eq 'Attribution Source',
and $hr->{catg} eq 'Category',
and $hr->{rating} eq 'Rating')
or croak 'incorrect headers or header order';
}
sub dbload_from_csv {
my ($self, $file) = @_;
my $delim = $self->{delim} || ',';
my $csv = Text::CSV->new({
sep_char => $delim,
binary => 1
});
$csv->column_names (@QUOTE_FIELDS);
open my $source, '<:encoding(utf8)', $file || croak $!;
lib/ACME/QuoteDB/LoadDB.pm view on Meta::CPAN
# TODO support multi categories
$self->set_record(catg => ($self->{category} || $hr->{catg}));
$self->set_record(rating => ($self->{rating} || $hr->{rating}));
$self->write_record;
}
close $source or carp $!;
return $self;
}
# sub class this - i.e. provide this method in your code (see test
# 01-load_quotes.t)
sub dbload {
croak 'Override this. Provide this method in a sub class (child) of this object';
# see tests: t/01-load_quotes.t for examples
}
sub _to_utf8 {
my ($self) = @_;
RECORD:
foreach my $r (@QUOTE_FIELDS){
my $val = $self->{record}->{$r};
if (ref $val eq 'ARRAY'){
foreach my $v (@{$val}){
if (!is_utf8($v)){
push @{$self->{record}->{$r}}, decode($FILE_ENCODING, $v);
}
lib/ACME/QuoteDB/LoadDB.pm view on Meta::CPAN
}
}
return $self;
}
# XXX refactor (the following 3 methods)
# one person can have many quotes, is this person in our attribution table
# already?
sub _get_id_if_attr_name_exist {
my ($self) = @_;
my $attr_id = q{};
RECS:
foreach my $c_obj (Attr->retrieve_all){
next RECS if not $c_obj->name;
if ($c_obj->name eq $self->get_record('name')){
# use attribution id if already exists
$attr_id = $c_obj->attr_id;
}
}
return $attr_id;
}
sub _get_id_if_catg_exist {
my ($self, $ctg) = @_;
my $catg_id = q{};
# get category id
RECS:
foreach my $c_obj (Catg->retrieve_all){
next RECS if not $c_obj->catg;
if ($c_obj->catg eq $ctg){
# use cat_id if already exists
$catg_id = $c_obj->catg_id;
}
}
return $catg_id;
}
#TODO : refactor
sub write_record {
my ($self) = @_;
$self->_to_utf8;
if ($self->{verbose} and $self->get_record('name')){
print 'Attribution Name: ',$self->get_record('name'),"\n";
};
my $attr_id = $self->_get_id_if_attr_name_exist;
# nope, ok, add them
lib/ACME/QuoteDB/LoadDB.pm view on Meta::CPAN
$self->{record} = {};
$self->_reset_orig_args;
if ($self->{write_db}) {
$self->success(1);
}
return $self->success;
}
sub _reset_orig_args {
my ($self) = @_;
$self->{record}->{rating} = $self->{orig_args}->{rating};
$self->{record}->{name} = $self->{orig_args}->{attr_source};
$self->{record}->{source} = $self->{orig_args}->{attr_source};
if (ref $self->{orig_args}->{category} eq 'ARRAY') {
foreach my $c (@{$self->{orig_args}->{category}}){
push @{$self->{record}->{catg}}, $c;
}
}
else {
$self->{record}->{catg} = $self->{orig_args}->{category};
}
}
sub success {
my ($self, $flag) = @_;
$self->{success} ||= $flag;
return $self->{success};
};
sub _display_vals_if_verbose {
my ($self) = @_;
if ($self->{verbose}){
#print 'Quote: ', $self->get_record('quote'),"\n";
#print 'Source: ', $self->get_record('source'),"\n";
#print 'Category: ',$self->get_record('catg'),"\n";
#print 'Rating: ', $self->get_record('rating'),"\n";
print Dumper $self->{record};
}
return $self;
}
#sub create_db {
# my ($self) = @_;
#
# if ($self->{db} and $self->{host}) {
# $self->create_db_mysql();
# }
#}
sub create_db_tables {
my ($self) = @_;
if ($self->{db} and $self->{host}) {
#$self->create_db_mysql();
$self->create_db_tables_mysql();
}
else {
create_db_tables_sqlite();
}
lib/ACME/QuoteDB/LoadDB.pm view on Meta::CPAN
# XXX we want the user to supply a pre created database.
# created as such 'CREATE DATABASE $dbn CHARACTER SET utf8 COLLATE utf8_general_ci'
# this get's into too many isseuwith privs and database creation
#Sat Aug 22 13:42:37 PDT 2009
# did this:
#mysql> CREATE DATABASE acme_quotedb CHARACTER SET utf8 COLLATE utf8_general_ci;
#mysql> grant usage on *.* to acme_user@localhost identified by 'acme';
#mysql> grant all privileges on acme_quotedb.* to acme_user@localhost ;
#sub create_db_mysql {
# my ($self) = @_;
#
# # hmmmm, what about priv's access, etc
# # maybe user need to supply a db, they have
# # access to, already created (just the db though)
# ## create our db
# #my $dbhc = DBI->connect('DBI:mysql:database=mysql;host='
# # .$self->{host}, $self->{user}, $self->{pass})
# # || croak "db cannot be accessed $! $DBI::errstr";
#
lib/ACME/QuoteDB/LoadDB.pm view on Meta::CPAN
# 'admin'
# );
#
# $rc = $drh->func("createdb", $self->{db},
# [$self->{host}, $self->{user}, $self->{password}],
# 'admin'
# );
#}
# XXX refactor with sqlite
sub create_db_tables_mysql {
my ($self) = @_;
# connect to our db
my $c = $self->{db}.';host='.$self->{host};
my $dbh = DBI->connect(
"DBI:mysql:database=$c", $self->{user}, $self->{pass})
|| croak "db cannot be accessed $! $DBI::errstr";
eval {
$dbh->do('DROP TABLE IF EXISTS quote;') or croak $dbh->errstr;
lib/ACME/QuoteDB/LoadDB.pm view on Meta::CPAN
$dbh->disconnect or warn $dbh->errstr;
$dbh = undef;
};
return $@ and croak 'Cannot create database tables!';
}
sub create_db_tables_sqlite {
my $db = QDBI->get_current_db_path;
#XXX is there really no way to do this with the existing
# connection?!(class dbi)
my $dbh = DBI->connect('dbi:SQLite:dbname='.$db, '', '')
|| croak "$db cannot be accessed $! $DBI::errstr";
#-- sqlite does not have a varchar datatype: VARCHAR(255)
#-- A column declared INTEGER PRIMARY KEY will autoincrement.
lib/ACME/QuoteDB/LoadDB.pm view on Meta::CPAN
file_format => 'csv',
});
$load_db->data_to_db;
if (!$load_db->success){print 'failed'}
=head3 load from any source
If those dont catch your interest, ACME::QuoteDB::LoadDB is sub-classable,
so one can extract data anyway they like and populate the db themselves.
(there is a test that illustrates overriding the stub method, 'dbload')
you need to populate a record data structure:
$self->set_record(quote => q{}); # mandatory
$self->set_record(name => q{}); # mandatory
$self->set_record(source => q{}); # optional but useful
$self->set_record(catg => q{}); # optional but useful
$self->set_record(rating => q{}); # optional but useful
lib/ACME/QuoteDB/LoadDB.pm view on Meta::CPAN
takes a csv file (in our defined format) as an argument, parses it and writes
the data to the database. (uses L<Text::CSV> with pure perl parser)
utf-8 safe. (opens file as utf8)
will croak with message if not successful
=head2 dbload
if your file format is set to 'html' or 'custom' you must
define this method to do your parsing in a sub class.
Load from html is not supported because there are too many
ways to represt the data. (same with 'custom')
(see tests for examples - there is a test for loading a 'fortune' file format)
One can subclass ACME::QuoteDB::LoadDB and override dbload,
to do our html parsing
=head2 debug_record
dump record (show what is set on the internal data structure)
e.g. Data::Dumper
=head2 set_record
only needed it one plans to sub-class this module.
otherwise, is transparent in usage.
if you are sub-classing this module, you would have to populate
this record. (L</write_record> knows about/uses this data structure)
possible fields consist of:
$self->set_record(quote => q{});
$self->set_record(rating => q{});
$self->set_record(name => q{});
$self->set_record(source => q{});
$self->set_record(catg => q{});
lib/ACME/QuoteDB/LoadDB.pm view on Meta::CPAN
);
# or this even
$self->set_record({
name => $name,
source => $source
});
=head2 get_record
only useful it one plans to sub-class this module.
otherwise, is transparent in usage.
if you are sub-classing this module, you would have to populate
this record. [see L</set_record>]
(L</write_record> knows about/uses this data structure)
possible fields consist of:
$self->get_record('quote');
$self->get_record('rating');
$self->get_record('name');
$self->get_record('source');
lib/ACME/QuoteDB/LoadDB.pm view on Meta::CPAN
=head2 write_record
takes the data structure 'record' '$self->get_record'
(which must exist). checks if attribution name ($self->get_record('name')) exists,
if so, uses existing attribution name, otherwsie creates a new one
Load from html is not supported because there are too many
ways to represt the data. (see tests for examples)
One can subclass ACME::QuoteDB::LoadDB and override dbload,
to do our html parsing
=head2 create_db_tables
create an empty quotes database (with correct tables).
(usually only performed the first time you load data)
B<NOTE: will overwrite ALL existing data>
Set 'create_db' parameter (boolean) to a true value upon instantiation
to enable.
The default action is to assume the database (and tables) exist and just
append new L<ACME::QuoteDB::LoadDB> loads to that.
=begin comment
keep pod coverage happy.
# Coverage for ACME::QuoteDB::LoadDB is 71.4%, with 3 naked subroutines:
# Catg
# Quote
# Attr
# QuoteCatg
pod tests incorrectly state, Catg, Quote and Attr are subroutines, well they
are,... (as aliases) but are imported into here, not defined within
TODO: explore the above (is this a bug, if so, who's?, version effected,
create use case, etc)
=head2 Attr
=head2 Catg
t/01-load_quotes.t view on Meta::CPAN
'Grandpa Simpson',
'Ralph Wiggum',
);
is( $sq->list_attr_names, join("\n", sort(@expected_attribution_list)));
}
{ # load from html is not supported because there are too many
# ways to represt the data.
# this is an example of extracting quotes from html:
# subclass ACME::QuoteDB::LoadDB and override dbload,
# to do our html parsing
package LoadQuoteDBFromHtml;
use base 'ACME::QuoteDB::LoadDB';
use Carp qw/croak/;
use Data::Dumper qw/Dumper/;
use HTML::TokeParser;
sub dbload {
my ($self, $file) = @_;
my $p = HTML::TokeParser->new($file) || croak $!;
while (my $token = $p->get_tag("p")) {
my $idn = $token->[1]{class} || q{};
my $id = $token->[1]{id} || q{}; # if a quotation is continued (id
#is not set)
next unless $idn and ( $idn eq 'quotation' || $idn eq 'source');
#my $data = $p->get_trimmed_text("/p");
t/01-load_quotes.t view on Meta::CPAN
'Told by Nick Leaton',
'Tom Christiansen',
'Vladimir Marangozov and Tim Peters',
);
is( $sq->list_attr_names, join "\n", sort @expected_attribution_list);
}
{ # prove load a fortune format file
# this is an example of importing a file in the 'fortune' format
# subclass ACME::QuoteDB::LoadDB and override dbload, to do our parsing
package Fortune2QuoteDB;
use base 'ACME::QuoteDB::LoadDB';
use Carp qw/croak/;
use Data::Dumper qw/Dumper/;
sub dbload {
my ($self, $file) = @_;
open my $source, '<:encoding(utf8)', $file || croak $!;
local $/ = $self->{delim};
my $q = q{};
while (my $line = <$source>){
t/02-get_quotes.t view on Meta::CPAN
use Carp qw/croak/;
use File::Spec;
BEGIN {
eval "use DBD::SQLite";
$@ and croak 'DBD::SQLite is a required dependancy';
}
#make test db writeable
sub make_test_db_rw {
use ACME::QuoteDB::DB::DBI;
# yeah, this is supposed to be covered by the build process
# but is failing sometimes,...
chmod 0666, ACME::QuoteDB::DB::DBI->get_current_db_path;
}
{
make_test_db_rw;
my $q = File::Spec->catfile((dirname(__FILE__),'data'), 'simpsons_quotes.csv');
t/boilerplate.t view on Meta::CPAN
#!perl -T
use strict;
use warnings;
use Test::More tests => 3;
use File::Basename qw/dirname/;
use File::Spec;
sub not_in_file_ok {
my ($filename, %regex) = @_;
my $file = File::Spec->catfile((dirname(__FILE__), '..'), $filename);
open( my $fh, '<', $file )
or die "couldn't open $file for reading: $!";
my %violated;
while (my $line = <$fh>) {
while (my ($desc, $regex) = each %regex) {
if ($line =~ $regex) {
t/boilerplate.t view on Meta::CPAN
}
if (%violated) {
fail("$file contains boilerplate text");
diag "$_ appears on lines @{$violated{$_}}" for keys %violated;
} else {
pass("$file contains no boilerplate text");
}
}
sub module_boilerplate_ok {
my ($module) = @_;
not_in_file_ok($module =>
'the great new $MODULENAME' => qr/ - The great new /,
'boilerplate description' => qr/Quick summary of what the module/,
'stub function definition' => qr/function[12]/,
);
}
not_in_file_ok(README =>
"The README is used..." => qr/The README is used/,
t/data/python_quotes.txt view on Meta::CPAN
like turning a hamster inside-out, I would *expect* it to be messy <wink>.
-- Tim Peters, 25 Jul 1998
This makes it possible to pass complex object hierarchies to a C coder who
thinks computer science has made no worthwhile advancements since the invention
of the pointer.
-- Gordon McMillan, 30 Jul 1998
The nice thing about list comprehensions is that their most useful forms could
be implemented directly as light sugar for ordinary Python loops, leaving
lambdas out of it entirely. You end up with a subtly different beast, but so
far it appears to be a beast that's compatible with cuddly pythons.
-- Tim Peters, 6 Aug 1998
I wonder what Guido thinks he might do in Python2 (assuming, of course, that he
doesn't hire a bus to run over him before then <wink>).
-- Tim Peters, 26 Aug 1998
After writing CGI scripts the traditional way for a few years, it is taking
awhile to reshape my thinking. No sledgehammer to the head yet, but lots of
small sculpting hammers...
t/data/python_quotes.txt view on Meta::CPAN
Suspicions are most easily dispelled/confirmed via evidence, and taking the
trouble to do this has the pleasant side-effect that you can either cease
expending effort worrying, or move directly to taking positive action to
correct the problem.
-- Neel Krishnaswami, 21 May 2000
Thanks to the overnight turnaround and the early interpreter's habit of
returning nothing at all useful if faced with a shortage of )s, one could
easily detect the LISP users: they tended to walk around with cards full of
)))))))... in their shirt pockets, to be slapped onto the end of submitted card
decks: one at least got something back if there were too many )s.
-- John W. Baxter, 21 May 2000
Python: embodies a harmony of chocolate kisses with hints of jasmine and rose.
Trussardi's wild new fragrance.
-- From _Marie Claire_, Australian edition, May 2000; noted by Fiona
Czuczman
In arts, compromises yield mediocre results. The personality and vision of the
artist has to go through. I like to see Python as a piece of art. I just hope
t/data/python_quotes.txt view on Meta::CPAN
positive side of that, I get to make the early decisions that will be cursed
for generations of Python hackers to come.
-- Barry Warsaw, 12 Jul 2000
Hey, you know, we can work this in. Sailor Moon + Giant Robots + Tentacle
Demons + Python Conference == Bizarre hilarity ensues!
-- Alexander Williams, 4 Aug 2000
The rapid establishment of social ties, even of a fleeting nature, advance not
only that goal but its standing in the uberconscious mesh of communal psychic,
subjective, and algorithmic interbeing. But I fear I'm restating the obvious.
-- Will Ware, 28 Aug 2000
The comp.lang.python newsgroup erupted last week with a flurry of posts that
accused the Python development team of creeping featurism, selling out the
language to corporate interests, moving too fast, and turning a deaf ear to the
Python community. What triggered this lava flow of accusations? The development
team accepted a proposal to change the syntax of the print statement.
-- Stephen Figgins, 30 Aug 2000
INTERVIEWER: Tell us how you came to be drawn into the world of pragmas.
t/data/python_quotes.txt view on Meta::CPAN
Regular expressions are among my most valued tools, along with goto, eval,
multiple inheritance, preemptive multithreading, floating point, run-time type
identification, a big knife, a bottle of bleach, and 120VAC electricity. All of
these things suck sometimes.
-- Kragen Sitaker, 27 Sep 2000
IIRC, he didn't much care for regexps before, but actually writing a regexp
engine drives most people who do it to intense hatred.
Just more of the magic of Python! Transmuting a few peoples' intense agony
into the subject of others' idle amusement <wink>.
-- Tim Peters, 27 Sep 2000
"I do not love thee, lambda; let me count the ways..."
-- Aahz Maruch, 27 Sep 2000
They are called "Exceptions" because to any policy for handling them, imposed
in advance upon all programmers by the computer system, some programmers will
have good reason to take exception.
-- William Kahan, quoted by Tim Peters, 13 Oct 2000
"Interim steps" have a tendency to become permanent in our industry, where
"Compatibility" is the way the sins of the fathers are inflicted upon the third
and fourth generations ...
-- William Kahan, quoted by Huaiyu Zhu, 16 Oct 2000
The most successful projects I've seen and been on *did* rewrite all the code
routinely, but one subsystem at a time. This happens when you're tempted to add
a hack, realize it wouldn't be needed if an entire area were reworked, and mgmt
is bright enough to realize that hacks compound in fatal ways over time. The
"ain't broke, don't fix" philosophy is a good guide here, provided you've got a
very low threshold for insisting "it's broke".
-- Tim Peters, 25 Oct 2000
Humour is a tricky thing. Some people can't even get the spelling right.
-- Richard Brodie, 30 Oct 2000
The same way as you get the name of that cat you found on your porch: the
t/data/python_quotes.txt view on Meta::CPAN
my-python-code-runs-5x-faster-this-month-thanks-to-dumping-$2K- on-a-
new-machine-ly y'rs
-- Tim Peters, 26 Dec 2000
Really, I should pronounce on that PEP (I don't like it very much but haven't
found the right argument to reject it :-) ) so this patch can either go in or
be rejected.
-- GvR, 04 Jan 2001, in a comment on patch #101264
The rest is history: the glory, the fame, the riches, the groupies, the
adulation of my peers. We won't mention the financial scandal and subsequent
bankruptcy lest it discourage you for no good reason <wink>.
-- Tim Peters, 14 Jan 2001
If you're using anything besides US-ASCII, I *stringly* suggest Python 2.0.
-- Uche Ogbuji (A fortuitous typo?), 29 Jan 2001
"There goes Tim, browsing the Playboy site just for the JavaScript.
Honest."
"Well, it's not like they had many floating-point numbers to ogle! I like
'em best when the high-order mantissa bits are all perky and regular, standing
t/data/python_quotes.txt view on Meta::CPAN
Python, and vice versa (feed a Python SAX stream into Xalan). Bi-SAXuality, in
a sense. :)
-- Jürgen Hermann, 11 Apr 2001
As you seem totally unwilling or unable to understand that _Weltanschauung_ to
any extent, I don't see how you could bring Python any constructive enhancement
(except perhaps by some random mechanism akin to monkeys banging away on
typewriters until 'Hamlet' comes out, I guess).
-- Alex Martelli, 17 Apr 2001
"Are we more likely to add different concrete subclasses of Consumable in
the future, or different concrete subclasses of Consumer? I suspect the former
is more likely."
"With genetic engineering being the latest growth industry, I'm not sure
that's true. Although I expect that any new models of cow, etc. will have a
backwards compatible food-consumption protocol."
-- Alex Martelli and Greg Ewing, 19 Apr 2001
This property is called confluence, and the proof is called the Church -Rosser
theorem. I'm sure you know this, of course, but somewhere out there there's a
college student who is being shocked that CS is actually turning out to be
relevant, for sufficiently small values of relevance.
t/data/www.amk.ca/quotations/python-quotes/page-3.html view on Meta::CPAN
<wink>.</p>
<p class='source'>Tim Peters, 25 Jul 1998</p>
<p class='quotation' id='q84'>This makes it possible to pass
complex object hierarchies to a C coder who thinks computer science
has made no worthwhile advancements since the invention of the
pointer.</p>
<p class='source'>Gordon McMillan, 30 Jul 1998</p>
<p class='quotation' id='q85'>The nice thing about list
comprehensions is that their most useful forms could be implemented
directly as light sugar for ordinary Python loops, leaving lambdas
out of it entirely. You end up with a subtly different beast, but
so far it appears to be a beast that's compatible with cuddly
pythons.</p>
<p class='source'>Tim Peters, 6 Aug 1998</p>
<p class='quotation' id='q86'>I wonder what Guido thinks he might
do in Python2 (assuming, of course, that he doesn't hire a bus to
run over him before then <wink>).</p>
<p class='source'>Tim Peters, 26 Aug 1998</p>
<p class='quotation' id='q87'>After writing CGI scripts the
traditional way for a few years, it is taking awhile to reshape my
thinking. No sledgehammer to the head yet, but lots of small
( run in 1.064 second using v1.01-cache-2.11-cpan-7add2cbd662 )