File Coverage

blib/lib/DBIx/BlackBox.pm

Criterion	Covered	Total	%
statement	1	3	33.3
branch			n/a
condition			n/a
subroutine	1	1	100.0
pod			n/a
total	2	4	50.0

package DBIx::BlackBox;

use MooseX::Role::Parameterized;

use DBIx::Connector;
use DBI;
use Module::Find qw( findallmod );

=encoding utf8

=head1 NAME

DBIx::BlackBox - access database with stored procedures only

=cut

our $VERSION = '0.02';

=head1 SYNOPSIS

L<DBIx::BlackBox> provides access to database using stored procedures only
(the only SQL command available is I<exec>). That allows to treat your
database as a black box into which only the database administrator provides
access by stored procedures.

Setup base class:

    package MyDBBB;
    use Moose;

    with 'DBIx::BlackBox' => {
        connect_info => [
            'dbi:Sybase:server=sqlserver',
            'username',
            'password',
            {
                RaiseError = 1,
                PrintError = 0,
            }
        ]
    };

Create procedures classes. Attributes define stored procedure parameters.

    package MyDBBB::Procedures::ListCatalogs;
    use Moose;

    with 'DBIx::BlackBox::Procedure' => {
        name => 'DB_Live..list_catalogs',
        resultsets => [qw(
            MyDBBB::ResultSet::Catalogs
            MyDBBB::ResultSet::CatalogData
        )],
    };

    has 'root_id' => (
        is => 'rw',
        isa => 'Int',
        required => 1,
    );
    has 'org_id' => (
        is => 'rw',
        isa => 'Maybe[Int]',
    );

    package MyDBBB::Procedures::UpdateCatalog;
    use Moose;

    with 'DBIx::BlackBox::Procedure' => {
        name => 'DB_Live..update_catalog',
    };

    has 'id' => (
        is => 'rw',
        isa => 'Int',
        required => 1,
    );
    has 'name' => (
        is => 'rw',
        isa => 'Str',
        required => 1,
    );

Describe result sets for procedures. They could (and should) be shared between
procedures.

    package MyDBBB::ResultSet::Catalogs;
    use Moose;

    has 'id' => (
        is => 'rw',
        isa => 'Int',
    );
    has 'name' => (
        is => 'rw',
        isa => 'Str',
    );

    package MyDBBB::ResultSet::CatalogData;
    use Moose;

    has 'id' => (
        is => 'rw',
        isa => 'Int',
    );
    has 'hierarchy' => (
        is => 'rw',
        isa => 'Int',
    );
    has 'description' => (
        is => 'rw',
        isa => 'Str',
    );

and then

    use MyDBBB;

    my $dbbb = MyDBBB->new();

execute stored procedure and get result object to iterate over

    my $rs = eval {
        $dbbb->exec('ListCatalogs',
            root_id => $root_id,
            org_id => $org_id,
        );
    } or do {
        die $@;
    }

    my @columns = (
        [qw( id name )],
        [qw( id hierarchy description )],
    );
    do {
        my @c = @{ $columns[ $rs->idx ] };
        while ( my $row = $rs->next_row ) {
            print "$_: ", $row->$_, "\n"
                for @c;
        }
    } while ( $rs->next_resultset );

    print "procedure_result: ", $rs->procedure_result, "\n";

or get all rows at once

    my ( $catalogs, $data, $rv ) = $dbbb->exec('ListCatalogs',
        root_id => $root_id,
        org_id => $org_id,
    )->all;

    for my $catalog ( @$catalogs ) {
        print $catalog->id, ": ", $catalog->name, "\n";
    }

    for my $row ( @$data ) {
        print $row->id, "[", $row->hierarchy, "]: ", $row->description, "\n";
    }

    print "procedure result: $rv";

=head1 ROLE PARAMETERS

=head2 connect_info

Database connection arguments passed to L<DBI/"connect">.

Required.

Note: currently only DBD::Sybase (MS SQL Server) is supported.

=cut

parameter connect_info => (
    isa => 'ArrayRef',
    required => 1,
);

=head2 procedures_namespace

All classes in provided namespace them will be automatically loaded.

Defaults to name of the consumer of DBIx::BlackBox role with C<::Procedures>
appended.

Note: those classes need to consume DBIx::BlackBox::Procedure role.

=cut

parameter procedures_namespace => (
    isa => 'Str',
);

=head1 ATTRIBUTES

=head2 connect_info

Returns the value of role parameter L<"connect_info">.

=head2 procedures_namespace

Returns the value of role parameter L<"procedures_namespace">.

=head1 METHODS

=head2 exec

    my $rs = $dbbb->exec($procedure_class, %args);

Instantiates an object of the C<$procedure_class> (which is appended to
L<"procedures_namespaces">) with arguments provided by C<%args> and executes
procedure defined by class.

Procedures should used named paremeters only.

=cut

=head1 INSTALLATION

Following installation steps were tested with both
Microsoft SQL Server 2000 and Microsoft SQL Server 2008.

=head2 unixODBC

Install unixODBC from your system packages or download sources from
L<http://www.unixodbc.org/>.

=head2 FreeTDS

Download dev release of FreeTDS from L<http://www.freetds.org> (tested with
freetds-0.83.dev.20100122).

    ./configure --with-unixodbc=/usr/local/ \
        --with-tdsver=8.0 --prefix=/usr/local/freetds
    make
    sudo make install

Edit F</usr/local/freetds/etc/freetds.conf> and specify access to your
database.

    ...
    [sqlserver]
        host = 1.2.3.4
        port = 1433
        tds version = 8.0

=head2 DBD::Sybase

Install L<DBD::Sybase>.

    SYBASE=/usr/local/freetds perl Makefile.PL
    make
    sudo make install

If you want to test DBD::Sybase most likely you would need to modify tests
that come with the module (some queries in test files will not work with
MS SQL Server).

=cut

role {
    my $p = shift;
    my %args = @_;
    my $consumer = $args{consumer};

    my $_proc_class_ns = $p->procedures_namespace ?
        $p->procedures_namespace
        :
        join('::', $consumer->name, 'Procedures' );

    {
        my @mods = findallmod( $_proc_class_ns );
        do {
            my $proc_class = $_;

            Class::MOP::load_class( $proc_class );
            my $proc_meta = $proc_class->meta;

            my $proc_role = 'DBIx::BlackBox::Procedure';
            unless ( $proc_meta->does_role($proc_role) ) {
                die "Class $proc_class does not consume $proc_role role\n";
            }
        } for @mods;
    }

    has 'connect_info' => (
        traits => [qw( Array )],
        is => 'ro',
        isa => 'ArrayRef',
        default => sub {
            $p->connect_info,
        },
        handles => {
            _db_connection_params => 'elements',
        }
    );

    has '_conn' => (
        is => 'rw',
        isa => 'DBIx::BlackBox::Driver',
        lazy_build => 1,
    );

    has 'procedures_namespace' => (
        is => 'ro',
        isa => 'Str',
        default => $_proc_class_ns,
    );

    method '_build__conn' => sub {
        my $self = shift;

        my @coninfo = $self->_db_connection_params;

        my $dsn = $coninfo[0];
        my (undef, $driver) = DBI->parse_dsn( $dsn );

        my $db_class = "DBIx::BlackBox::Driver::$driver";
        Class::MOP::load_class( $db_class );

        return $db_class->new(
            connector => DBIx::Connector->new( @coninfo )
        );
    };

    method 'exec' => sub {
        my ($self, $name, %args) = @_;

        my $proc_class = join('::', $self->procedures_namespace, $name );

        my $proc = $proc_class->new( %args );

        return $proc->exec( $self->_conn );
    }
};

no MooseX::Role::Parameterized;

=head1 CAVEATS

Neither the stored procedures nor result sets classes can have
attributes/columns/parameters that would clash with Moose internals,
e.g. I<new>.

=head1 AUTHOR

Alex J. G. Burzyński, E<lt>ajgb at cpan.orgE<gt>

=head1 BUGS

Please report any bugs or feature requests to C<bug-dbix-blackbox at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=DBIx-BlackBox>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.

=head1 LICENSE AND COPYRIGHT

Copyright 2010 Alex J. G. Burzyński.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.

=cut

1; # End of DBIx::BlackBox