[Openinteract-commits] CVS: SPOPS/eg/My/DBI DatasourceConfigure.pm,NONE,2.0 FindDefaults.pm,NONE,2.0

SourceForge Headquarters 225 Broadway Suite 1600 San Diego, CA 92101 +1 (858) 454-5900

Update of /cvsroot/openinteract/SPOPS/eg/My/DBI
In directory usw-pr-cvs1:/tmp/cvs-serv12455/eg/My/DBI

Modified Files:
      Tag: 2.0
	DatasourceConfigure.pm FindDefaults.pm 
Log Message:
update everything to version 2.0 to get rid of lingering CPAN version
conflicts (thanks to merlyn for pointing them out); also use a
consistent VERSION formatting scheme and 'use base' where appropriate

--- NEW FILE: DatasourceConfigure.pm ---
package My::DBI::DatasourceConfigure;

# $Id: DatasourceConfigure.pm,v 2.0 2002/03/19 04:00:07 lachoy Exp $

use strict;
use SPOPS               qw( DEBUG _w );
use SPOPS::ClassFactory qw( ERROR OK NOTIFY );

sub behavior_factory {
    my ( $class ) = @_;
    DEBUG() && _w( 1, "Installing datasource configuration for ($class)" );
    return { manipulate_configuration => \&datasource_access };
}

my $generic_ds_sub = <<'DS';

sub %%CLASS%%::global_datasource_handle {
    my ( $class ) = @_;
    unless ( $%%CLASS%%::DBH ) {
        require DBI;
        $%%CLASS%%::DBH = DBI->connect( '%%DSN%%', '%%USER%%', '%%PASS%%' )
                               || SPOPS::Exception->throw(
                                      "Cannot connect to database for [%%CLASS%%]: $DBI::errstr" );
        $%%CLASS%%::DBH->{RaiseError} = 1;
        $%%CLASS%%::DBH->{PrintError} = 0;
        $%%CLASS%%::DBH->{ChopBlanks} = 1;
        $%%CLASS%%::DBH->{AutoCommit}  = 1;
    }
    return $%%CLASS%%::DBH;
}
DS

sub datasource_access {
    my ( $class ) = @_;
    my $dbi_config = $class->CONFIG->{dbi_config};
    unless ( ref $dbi_config eq 'HASH' and
             $dbi_config->{dsn} and
             $dbi_config->{username} and
             $dbi_config->{password} ) {
      return ( NOTIFY, "Cannot create datasource access subroutine for ($class) " .
                       "because you do not have 'dbi_config->dsn', " .
                       "'dbi_config->username' and 'dbi_config->username' defined" );
    }

    my $ds_code = $generic_ds_sub;
    $ds_code =~ s/%%CLASS%%/$class/g;
    $ds_code =~ s/%%DSN%%/$dbi_config->{dsn}/g;
    $ds_code =~ s/%%USER%%/$dbi_config->{username}/g;
    $ds_code =~ s/%%PASS%%/$dbi_config->{password}/g;
    {
        local $SIG{__WARN__} = sub { return undef };
        eval $ds_code;
    }
    if ( $@ ) {
        warn "Code: $ds_code\n";
        return ( ERROR, "Cannot create 'global_datasource_handle() for ($class): $@" );
    }
    return ( OK, undef );
}

1;

=pod

=head1 NAME

My::DBI::DatasourceConfigure -- Embed the parameters for a DBI handle in object configuration

=head1 SYNOPSIS

 my $spops = {
   myobject => {
     class      => 'My::Object',
     rules_from => [ 'My::DBI::DatasourceConfigure' ],
     dbi_config => { dsn => 'DBI:mysql:test',
                     username => 'kool',
                     password => 'andthegang' },
     ...
   },
 };
 SPOPS::Initialize->process({ config => $spops });
 my $object = My::Object->fetch( 'celebrate' );

=head1 DESCRIPTION

This rule allows you to embed the DBI connection information in your
object rather than using the strategies described elsewhere. This is
very handy for creating simple, one-off scripts, but you should still
use the subclassing strategy from
L<SPOPS::Manual::Cookbook|SPOPS::Manual::Cookbook> if you will have
multiple objects using the same datasource.

=head1 METHODS

B<behavior_factory( $class )>

Generates a behavior to generate the datasource retrieval code during
the 'manipulate_configuration' phase.

B<datasource_access( $class )>

Generates the 'global_datasource_handle()' method that retrieves an
opened database handle if it exists or creates one otherwise.

=head1 BUGS

None known.

=head1 TO DO

Nothing known.

=head1 SEE ALSO

L<SPOPS::Manual::CodeGeneration|SPOPS::Manual::CodeGeneration>

L<SPOPS::DBI|SPOPS::DBI>

=head1 COPYRIGHT

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=head1 AUTHORS

Chris Winters <ch...@cw...>

Thanks to jeffa on PerlMonks
(http://www.perlmonks.org/index.pl?node_id=18800) for suggesting this!

=cut

--- NEW FILE: FindDefaults.pm ---
package My::DBI::FindDefaults;

# $Id: FindDefaults.pm,v 2.0 2002/03/19 04:00:07 lachoy Exp $

use strict;
use SPOPS               qw( DEBUG _w );
use SPOPS::ClassFactory qw( ERROR OK NOTIFY );

sub behavior_factory {
    my ( $class ) = @_;
    DEBUG() && _w( 1, "Installing default discovery for ($class)" );
    return { manipulate_configuration => \&find_defaults };
}

sub find_defaults {
    my ( $class ) = @_;
    my $CONFIG = $class->CONFIG;
    return ( OK, undef ) unless ( $CONFIG->{find_default_id} and
                                  ref $CONFIG->{find_default_field} eq 'ARRAY' and
                                  scalar @{ $CONFIG->{find_default_field} } );
    my $dbh = $class->global_datasource_handle( $CONFIG->{datasource} );
    unless ( $dbh ) {
      return ( NOTIFY, "Cannot find defaults because no DBI database " .
                       "handle available to class ($class)" );
    }

    my $default_fields = join( ', ', @{ $CONFIG->{find_default_field} } );
    my $id_clause = $class->id_clause( $CONFIG->{find_default_id},
                                       '', { db => $dbh } );
    my $sql = qq/
         SELECT $default_fields
           FROM $CONFIG->{base_table}
          WHERE $id_clause /;
    my ( $sth );
    eval {
        $sth = $dbh->prepare( $sql );
        $sth->execute;
    };
    if ( $@ ) {
      return ( NOTIFY, "Cannot find defaults because SELECT failed to execute.\n" .
                       "SQL: $sql\nError: $@\nClass: $class" );
    }
    my $row = $sth->fetchrow_arrayref;

    unless ( ref $row eq 'ARRAY' and scalar @{ $row } ) {
        return ( NOTIFY, "No record found for ID $CONFIG->{find_default_id} in " .
                         "class ($class)" );
    }

    my $count = 0;
    foreach my $field ( @{ $CONFIG->{find_default_field} } ) {
        $CONFIG->{default_values}{ $field } = $row->[ $count ];
        $count++;
    }
    return ( OK, undef );
}

1;

__END__

=pod

=head1 NAME

My::DBI::FindDefaults - Load default values from a particular record

=head1 SYNOPSIS

 # Load information from record 4 for fields 'language' and 'country'

 my $spops = {
    class               => 'This::Class',
    isa                 => [ 'SPOPS::DBI' ],
    field               => [ 'email', 'language', 'country' ],
    id_field            => 'email',
    base_table          => 'test_table',
    rules_from          => [ 'My::DBI::FindDefaults' ],
    find_default_id     => 4,
    find_default_fields => [ 'language', 'country' ],
 };

=head1 DESCRIPTION

This class allows you to specify default values based on the
information in a particular record in the database. Just specify the
ID of the record and the fields which you want to copy as defaults.

=head1 METHODS

B<behavior_factory()>

Loads the behavior during the
L<SPOPS::ClassFactory|SPOPS::ClassFactory> process.

B<find_defaults()>

Retrieve the defaults from the database.

=head1 BUGS

None known.

=head1 TO DO

Nothing known.

=head1 SEE ALSO

L<SPOPS::ClassFactory|SPOPS::ClassFactory>

POOP Group mailing list thread:

  http://www.geocrawler.com/lists/3/SourceForge/3024/0/6867367/

=head1 COPYRIGHT

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=head1 AUTHORS

Chris Winters <ch...@cw...>

=cut