package DADA::MailingList::Archives::baseSQL; use strict; use DADA::Config qw(!:DEFAULT); use DADA::MailingList::Settings; use DADA::App::Guts; use Carp qw(carp croak); my $database = $DADA::Config::SQL_PARAMS{database}; my $dbserver = $DADA::Config::SQL_PARAMS{dbserver}; my $port = $DADA::Config::SQL_PARAMS{port}; my $user = $DADA::Config::SQL_PARAMS{user}; my $pass = $DADA::Config::SQL_PARAMS{pass}; my $dbtype = $DADA::Config::SQL_PARAMS{dbtype}; if(!$dbtype){ $dbtype = 'mysql' if $DADA::Config::SUBSCRIBER_DB_TYPE eq 'MySQL'; $dbtype = 'Pg' if $DADA::Config::SUBSCRIBER_DB_TYPE eq 'PostgreSQL'; } use lib qw(./ ../ ../../ ../../../ ./../../DADA ../../perllib); use DBI; use Fcntl qw(O_WRONLY O_TRUNC O_CREAT O_CREAT O_RDWR O_RDONLY LOCK_EX LOCK_SH LOCK_NB ); my $dbi_obj = undef; my %fields; sub new { my $class = shift; my %args = (-List => undef, @_); my $self = {}; #in this case, $args{-List} contains a hashref with the list information. Yeah, duh. bless $self, $class; $self->_init(%args); $self->{list_info} = $args{-List}; $self->{name} = $self->{list_info}->{list}; return $self; } sub _init { my $self = shift; my %args = @_; %fields = %args; $self->{list} = $args{-List}->{list}; $self->{ignore_open_db_error} = $args{ignore_open_db_error} if $args{ignore_open_db_error} && $args{ignore_open_db_error} == 1; my $ls = DADA::MailingList::Settings->new(-List => $self->{list}); #we probably don't need this... $ls->{ignore_open_db_error} = 1 if $self->{ignore_open_db_error} && $self->{ignore_open_db_error} == 1; $self->{list_info} = $ls->get; $self->{sql_params} = {%DADA::Config::SQL_PARAMS}; $self->{msg_cache} = {}; if(!$dbi_obj){ require DADA::App::DBIHandle; $dbi_obj = DADA::App::DBIHandle->new; $self->{dbh} = $dbi_obj->dbh_obj; }else{ $self->{dbh} = $dbi_obj->dbh_obj; } if($args{-parser}){ $self->{parser} = $args{-parser}; } } sub can_display_attachments { my $self = shift; return 1; } sub can_display_message_source { my $self = shift; return 1; } sub print_message_source { my $self = shift; my $fh = shift; my $id = shift; croak "no id!" if ! $id; croak "no fh!" if ! $fh; croak "archive backend does not support viewing message source!" unless can_display_message_source; my ($subject, $message, $format, $raw_msg) = $self->get_archive_info($id); print $fh $raw_msg; } sub get_available_archives{ my $self = shift; my @list; my $query = 'SELECT DISTINCT list FROM '. $self->{sql_params}->{archives_table}; my $sth = $self->{dbh}->prepare($query); $sth->execute() or croak "cannot do statment! $DBI::errstr\n"; while((my $list) = $sth->fetchrow_array){ push(@list, $list); } $sth->finish; return \@list; } =pod =head2 get_archive_entries my $entries = $archive -> get_archive_entries(); this will give you a refernce to an array that has the keys to your entries there. =cut sub get_archive_entries { my $self = shift; my $order = shift || 'normal'; my @keys; my $in_reverse = $self->{list_info}->{sort_archives_in_reverse} || 0; #yeah, like what? my $query = 'SELECT archive_id FROM '. $self->{sql_params}->{archives_table} . ' WHERE list = ? ORDER BY archive_id ASC'; #warn 'query: ' . $query; my $sth = $self->{dbh}->prepare($query); $sth->execute($self->{name}); while((my $archives_id) = $sth->fetchrow_array){ push(@keys, $archives_id); } $sth->finish; if($order eq 'reverse' || $in_reverse == 1){ @keys = reverse @keys; } return \@keys; } sub get_archive_info{ my $self = shift; my $key = shift; $key = $self->_massaged_key($key); my $cache = shift || 0; if($self->{msg_cache}->{$key}){ # warn "i'm cached!"; return ($self->{msg_cache}->{$key}->[0], $self->{msg_cache}->{$key}->[1], $self->{msg_cache}->{$key}->[2], $self->{msg_cache}->{$key}->[3]); }else{ my $query = 'SELECT * FROM ' . $self->{sql_params}->{archives_table} . ' WHERE archive_id = ? AND list = ?'; my $sth = $self->{dbh}->prepare($query); $sth->execute($key, $self->{name}); my $a_entry = $sth->fetchrow_hashref(); $sth->finish; if($cache){ # warn "I'm caching!"; $self->{msg_cache}->{$key} = [$a_entry->{subject}, $a_entry->{message},$a_entry->{format}, $a_entry->{raw_msg}]; } $a_entry->{subject} = $self->strip_subjects_appended_list_name($a_entry->{subject}) if $self->{list_info}->{no_append_list_name_to_subject_in_archives} == 1; if(! strip($a_entry->{subject})){ $a_entry->{subject} = $DADA::Config::EMAIL_HEADERS{Subject}; } return ($a_entry->{subject}, $a_entry->{message},$a_entry->{format}, $a_entry->{raw_msg}); } } =pod =head2 set_archive_info $archive -> set_archive_info($subject, $message, $format, $raw_msg); changes the archive's info (yo) =cut sub set_archive_info { my $self = shift; my $key = shift; $key = $self->_massaged_key($key); if($key){ my $ping = 1; if($self->check_if_entry_exists($key)){ $self->delete_archive($key); $ping = 0; } my $new_subject = shift; my $new_message = shift; my $new_format = shift; my $raw_msg = shift; if((!$new_message) && ($raw_msg)){ ($new_message, $new_format) = $self->_faked_oldstyle_message($raw_msg); } if($self->{list_info}->{enable_open_msg_logging} == 1){ if($new_format !~ /plain/){ $new_message = $self->_remove_opener_image($new_message); $raw_msg = $self->_remove_opener_image($raw_msg); } } my $query = 'INSERT INTO '. $self->{sql_params}->{archives_table} .' VALUES (?,?,?,?,?,?)'; my $sth = $self->{dbh}->prepare($query); $sth->execute($self->{name}, $key, $new_subject, $new_message, $new_format, $raw_msg); #shouldn't key and list be reversed in the table? require DADA::App::ScreenCache; my $c = DADA::App::ScreenCache->new; $c->flush; $self->send_pings() if $ping == 1; return 1; }else{ carp "no key passed!"; return undef; } } =pod =head2 search_entries my $search_results = $archive->search_entries($keyword); Given a $keyword, will return a array ref of archive key/ids that contain the keyword. =cut sub search_entries { my $self = shift; my $keyword = shift; my @results; my $query = 'SELECT archive_id FROM '. $self->{sql_params}->{archives_table} . ' WHERE list = ? AND (raw_msg LIKE ? OR subject LIKE ?) ORDER BY archive_id DESC'; my $sth = $self->{dbh}->prepare($query); $sth->execute($self->{name}, '%'.$keyword.'%', '%'.$keyword.'%'); while((my $archives_id) = $sth->fetchrow_array){ push(@results, $archives_id); } return \@results; } =pod =head2 delete_archive delete_archive($key); deletes the archive entry. =cut sub delete_archive { my $self = shift; my @deep_six = @_; my @good_list = (); carp "no key passed to remove entries!" if !$deep_six[0]; foreach(@deep_six){ $_ = $self->_massaged_key($_); if($self->check_if_entry_exists($_)){ push(@good_list, $_); }else{ carp "error removing entry, '$_' doesn't exist?"; } } foreach(@good_list){ my $key = $_; my $query = 'DELETE FROM ' . $self->{sql_params}->{archives_table} . ' WHERE archive_id = ? AND list = ?'; my $sth = $self->{dbh}->prepare($query); $sth->execute($key, $self->{name}); $sth->finish; } require DADA::App::ScreenCache; my $c = DADA::App::ScreenCache->new; $c->flush; } sub delete_all_archive_entries { my $self = shift; my $query = 'DELETE FROM ' . $self->{sql_params}->{archives_table} . ' WHERE list = ?'; my $sth = $self->{dbh}->prepare($query); $sth->execute($self->{name}); $sth->finish; return 1; } sub removeAllBackups { # no backups are created, # so no backups to remove - all right! } sub make_table { my $self = shift; my $query = 'CREATE TABLE dada_archives (list varchar(32), archive_id varchar(32), subject text, message text, format text, raw_msg text);'; my $sth = $self->{dbh}->prepare($query); $sth->execute() or croak "cannot do statment! $DBI::errstr\n"; } sub uses_backupDirs { my $self = shift; return 0; } sub DESTROY { my $self = shift; $self->{parser}->filer->purge if $self->{parser}; } # Probably only need to convert this if I want to do a backup thingy. #sub get { # my $self = shift; # return $self->{DB_HASH}; #} # Probably only need to convert this if I want to do a backup thingy. #sub save { # my $self = shift; # my $new_vals = shift; # # $self->_close_db; # # # hack. fix later. # my %tmp; # chmod($DADA::Config::FILE_CHMOD , $self->_db_filename) # if -e $self->_db_filename; # tie %tmp, "AnyDBM_File", $self->_db_filename, O_RDWR|O_CREAT, $DADA::Config::FILE_CHMOD # or croak 'couldn\'t tie '. $self->_db_filename . ' for reading: ' . $! . '; If your server recently upgraded software or moved your lists to a different server, you may need to restore your list ' . $self->{function} . '. Visit ' . # $DADA::Config::PROGRAM_URL . '?f=restore_lists '; # %tmp = %$new_vals; # untie %tmp; # $self->_open_db; #} 1;