"Fossies" - the Fresh Open Source Software Archive

Member "sendpage-1.001001/lib/Sendpage/Db.pm" (3 Jan 2008, 7145 Bytes) of package /linux/privat/old/sendpage-1.001001.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "Db.pm" see the Fossies "Dox" file reference documentation.

    1 package Sendpage::Db;
    2 
    3 # this package will access databases for looking up recipients
    4 #
    5 # $Id: Db.pm 215 2006-07-30 16:34:52Z keescook $
    6 #
    7 # Copyright (C) 2004 Todd Fries
    8 # todd@fries.net, http://FreeDaemonConsulting.com/
    9 #
   10 # This program is free software; you can redistribute it and/or
   11 # modify it under the terms of the GNU General Public License
   12 # as published by the Free Software Foundation; either version 2
   13 # of the License, or (at your option) any later version.
   14 #
   15 # This program is distributed in the hope that it will be useful,
   16 # but WITHOUT ANY WARRANTY; without even the implied warranty of
   17 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   18 # GNU General Public License for more details.
   19 #
   20 # You should have received a copy of the GNU General Public License
   21 # along with this program; if not, write to the Free Software
   22 # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
   23 # <URL:http://www.gnu.org/copyleft/gpl.html>
   24 
   25 use 5.6.1;          # To be safe; using lvaluable subs
   26 use strict;         # Avoid MetaGoof #1
   27 use warnings;           # Avoid MetaGoof #2
   28 
   29 use DBI;
   30 use Carp;           # A great way to misdirect blame ;)
   31 
   32 =head1 NAME
   33 
   34 Sendpage::Db - encapsulates the data of a single recipient
   35 
   36 =head1 SYNOPSIS
   37 
   38  $db = Sendpage::Db->new($dsn);
   39  $db->setdb($dsn, $user, $pass, $table);
   40  $db->check("$name:$type");
   41  $db->update("$name:$type", "$value");
   42  $db->delete("$name:$type");
   43 
   44 =head1 DESCRIPTION
   45 
   46 This is a module is used internally by L<sendpage> for encapsulating
   47 data for a single recipient in an object-oriented interface.
   48 
   49 The available methods are:
   50 
   51 =cut
   52 
   53 =over 4
   54 
   55 =item new LIST
   56 
   57 Instantiates a new Sendpage::Db object.
   58 
   59 =cut
   60 
   61 sub new
   62 {
   63     my ($class, $dsn, $user, $pass, $table) = @_;
   64     my $self = { };     # to be taken of care by setdb()
   65     bless $self => $class;
   66 
   67     return undef unless setdb($self, $dsn, $user, $pass, $table);
   68     return $self;
   69 }
   70 
   71 # automagically create accessor methods; we set them with the
   72 # `lvalue' attribute (available in Perl 5.6) so we can do attribute
   73 # manipulations like in C++, e.g. `$db->table = "sendpage"'
   74 foreach my $field (qw(dbh dsn user pass table)) {
   75     no strict "refs";       # access symbol table
   76     *$field = sub : lvalue
   77     {
   78     my $self = shift;
   79     $self->{uc $field} = shift if (@_);
   80     $self->{uc $field}; # no need for `return'
   81     };
   82 }
   83 
   84 =item setdb LIST
   85 
   86 Prepares the core attributes for a Sendpage::Db object.
   87 
   88 Normally called within a C<new> invocation, C<setdb> accepts the
   89 dsn, username, password, and table to be used in the database.
   90 
   91 Emits the return value of C<connect> (0 if successful, 1 otherwise.)
   92 
   93 =cut
   94 
   95 sub setdb
   96 {
   97     my ($self, $dsn, $user, $pass, $table) = @_;
   98 
   99     $self->table = $table || "sendpage";
  100     $self->dsn = $dsn;
  101     if ($user) {
  102     $self->user = $user;
  103     if ($pass) {
  104         $self->pass = $pass;
  105     } else {
  106         if ($self->pass) {
  107         $self->pass = undef;
  108         }
  109     }
  110     } else {
  111     if ($self->user) {
  112         $self->user = undef;
  113     }
  114     }
  115 
  116     return $self->connect;
  117 }
  118 
  119 =item connect()
  120 
  121 Make a connection from the Sendpage::Db object to the underlying
  122 database using DBI.
  123 
  124 Accepts a Sendpage::Db object.
  125 
  126 Emits 0 if successful, 1 otherwise.
  127 
  128 =cut
  129 
  130 sub connect
  131 {
  132     my $self = shift;
  133 
  134     my ($dsn, $user, $pass, $table, $rv);
  135 
  136     $dsn = $self->dsn;
  137     $user = $self->user if $self->user;
  138     $pass = $self->pass if $self->pass;
  139     $table = $self->table;
  140     $rv = 0;
  141 
  142     if ($self->dbh) {
  143     my $dbh = $self->dbh;
  144     $dbh->disconnect;
  145     }
  146 
  147     # Then again, DBI has its own `connect' method, so...
  148     if ($self->dbh = DBI->connect($dsn, $user, $pass)) {
  149     return 0;
  150     } else {
  151     printf STDERR carp("DB connection to $dsn failed!\n");
  152     return 1;
  153     }
  154 }
  155 
  156 =item check KEY
  157 
  158 Check if a given key is defined in the table.
  159 
  160 =cut
  161 
  162 sub check
  163 {
  164     my ($self, $key) = @_;
  165     my $result;
  166 
  167     my ($sth, $table, $query, @result);
  168 
  169     $key = $self->quote($key);
  170 
  171     $table = $self->table;
  172     $query = "select v from $table where k = $key";
  173 
  174     $sth = $self->query($query);
  175 
  176     return @result unless ($sth || $sth->rows > 0);
  177     $result = $sth->fetchrow_array;
  178     if ($result =~ m/[\s,]/) {
  179     my @parts = split /[\s,]+/ => $result;
  180     foreach my $item (@parts) {
  181         # drop white space
  182         $item =~ s/^\s*//;
  183         $item =~ s/\s*$//;
  184         push @result, $item;
  185     }
  186     } else {
  187     @result = ($result);
  188     }
  189 
  190     return @result;
  191 }
  192 
  193 =item show()
  194 
  195 Show keys and their corresponding values from the table.
  196 
  197 =cut
  198 
  199 sub show
  200 {
  201     my $self = shift;
  202     my ($sth, $key, $table, $query);
  203 
  204     $table = $self->table;
  205     $query = "select k,v from $table";
  206 
  207     $sth = $self->query($query);
  208     return undef unless $sth;
  209 
  210     while (my ($key, $val) = $sth->fetchrow_array) {
  211         print "$key\t=\t$val\n"
  212     }
  213     $sth->finish;
  214     return 0;
  215 }
  216 
  217 =item update KEY, VALUE
  218 
  219 Updates a table's key with the given value.
  220 
  221 =cut
  222 
  223 sub update
  224 {
  225     my ($self, $key, $val) = @_;
  226     my ($sth, $table, $query, $rv);
  227 
  228     $table = $self->table;
  229 
  230     $key = $self->quote($key);
  231     $val = $self->quote($val);
  232 
  233     $query = "select k,v from $table where k = $key";
  234     $sth = $self->query($query);
  235     return undef unless $sth;
  236 
  237     $sth->finish;
  238     if ($sth->rows > 0) {
  239     $query = "update $table set v = $val where k = $key";
  240     $sth = $self->query($query);
  241     } else {
  242     $query = "insert into $table values ($key, $val)";
  243     $sth = $self->query($query);
  244     }
  245     return undef unless $sth;
  246     $sth->finish;
  247     return 0;
  248 }
  249 
  250 =item delete KEY
  251 
  252 Deletes a key (and its value) in the table.
  253 
  254 =cut
  255 
  256 sub delete
  257 {
  258     my ($self, $key) = @_;
  259 
  260     my ($sth, $table, $query);
  261     $table = $self->table;
  262 
  263     $key = $self->quote($key);
  264     $query = "delete from $table where k = $key";
  265     $sth = $self->query($query);
  266     return undef unless $sth;
  267     $sth->finish;
  268     return 0;
  269 }
  270 
  271 =back
  272 
  273 =for developers
  274 Add other core functions here; the next set describes helper
  275 functions...
  276 
  277 =cut
  278 
  279 # Now for some db helper functions, not called by external
  280 # modules...  We could probably enforce some caller() check here, to
  281 # be really sure these subroutines aren't called from the outside...
  282 
  283 sub prepare
  284 {
  285     my ($self, $query) = @_;
  286 
  287     return $self->dbh->prepare($query);
  288 }
  289 
  290 sub quote
  291 {
  292     my ($self, $string) = @_;
  293 
  294     return $self->dbh->quote($string);
  295 }
  296 
  297 sub query
  298 {
  299     my ($self, $query) = @_;
  300 
  301     my ($sth, $rv);
  302 
  303     #warn "preparing [$query]\n";
  304     $sth = $self->prepare($query);
  305 
  306     unless ($rv = $sth->execute) {
  307     printf STDERR carp("[$query] failed, returned $rv\n");
  308     return undef;
  309     }
  310 
  311     $rv = $sth->rows;
  312 
  313     if ($rv < 0) {
  314     $sth->finish;
  315     printf STDERR carp("[$query] returned $rv rows\n");
  316     return undef;
  317     }
  318 
  319     return $sth;
  320 }
  321 
  322 1;              # This is a module
  323 
  324 __END__
  325 
  326 =head1 AUTHOR
  327 
  328 Todd T. Fries <todd@fries.net>
  329 
  330 =head1 BUGS
  331 
  332 Need to write more docs; now in progress.
  333 
  334 =head1 SEE ALSO
  335 
  336 Man pages: L<perl>, L<sendpage>.
  337 
  338 Module documentation: L<Sendpage::KeesConf>, L<Sendpage::KeesLog>,
  339 L<Sendpage::Modem>, L<Sendpage::PagingCentral>, L<Sendpage::PageQueue>,
  340 L<Sendpage::Page>, L<Sendpage::Queue>
  341 
  342 =head1 COPYRIGHT
  343 
  344 Copyright 2004 Todd T. Fries.
  345 
  346 This library is free software; you can redistribute it and/or
  347 modify it under the same terms as Perl itself.
  348 
  349 =cut