File Coverage

blib/lib/Win32/SqlServer/DTS/Application.pm

Criterion	Covered	Total	%
statement	12	12	100.0
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	16	16	100.0

package Win32::SqlServer::DTS::Application;

=head1 NAME

Win32::SqlServer::DTS::Application - a Perl class to emulate Microsoft SQL Server 2000 DTS Application object

=head1 SYNOPSIS

    use Win32::SqlServer::DTS::Application;

    my $app = Win32::SqlServer::DTS::Application->new(
               {
                   server                 => $server,
                   user                   => $user,
                   password               => $password,
                   use_trusted_connection => 0
               }
    );

    # fetchs a list of packages
    my @list = qw( LoadData ChangeData ExportData);

    foreach my $name ( @list ) {

        my $package = $self->get_db_package( { name => $name } ) );
        print $package->to_string;

    }


=head1 DESCRIPTION

This Perl class represents the Application object from the MS SQL Server 2000 API.
Before fetching any package from a server one must instantiate a C object that will provide
methods to fetch packages without having to provide autentication each time.

=head2 EXPORT

None by default.

=cut

use strict;
use warnings;
use Carp qw(confess cluck);
use base qw(Class::Accessor Win32::SqlServer::DTS);
use Win32::OLE qw(in);
use Win32::SqlServer::DTS::Package;
use Win32::SqlServer::DTS::Credential;
use Hash::Util qw(lock_keys);

__PACKAGE__->follow_best_practice;
__PACKAGE__->mk_ro_accessors(qw(credential));

=head2 METHODS

=head3 new

Instantiate a new object from C class. The expected parameter is a hash reference with the
following keys:

=over

=item *
server: the name of a database server already configured in the Enterprise Manager.

=item *
user: a string of the user used to authenticate against the database server. Not necessary to specify
if C is true.

=item *
password: a string of the password used to authenticate against the database server. Not necessary to specify
if C is true.

=item *
use_trusted_connection: a true/false value (1 or 0, respectivally) to specify if a Trusted Connection will be the
authentication method to be used.

=back

See L for an example.

=cut

sub new {

    my $class      = shift;
    my $properties = shift;

    confess "expects an hash reference as a parameter"
      unless ( ref($properties) eq 'HASH' );

    my $self;

    $self->{credential} = Win32::SqlServer::DTS::Credential->new($properties);

    $self->{_sibling} = Win32::OLE->new('DTS.Application');

    bless $self, $class;
    lock_keys( %{$self} );
    return $self;

}

=head3 get_db_package

Fetchs a single package from a MS SQL server and returns a respective C object. Expects a hash
reference as a parameter, having the following keys defined:

=over

=item *
id: the uniq package ID. Obligatory if a package C is not provided.

=item *
version_id: the version ID of the package. If not provided, the last version of the package will be fetched.

=item *
name: the name of the package. Obligatory if a package C is not provided.

=item *
package_password: the password used to restrict access to the package. Not obligatory if no password is used.

=back

=cut

sub get_db_package {

    my $self        = shift;
    my $options_ref = shift;

    # validates if the parameters are valid
    confess "Package name or ID must be informed\n"
      unless (
        (
                ( exists( $options_ref->{id} ) )
            and ( defined( $options_ref->{id} ) )
        )
        or (    ( exists( $options_ref->{name} ) )
            and ( defined( $options_ref->{name} ) ) )
      );

    $options_ref->{id}   = '' unless ( defined( $options_ref->{id} ) );
    $options_ref->{name} = '' unless ( defined( $options_ref->{name} ) );

    foreach my $attribute (qw(package_password version_id)) {

        $options_ref->{$attribute} = ''
          unless (
            (
                exists( $options_ref->{$attribute} )
                and ( defined( $options_ref->{$attribute} ) )
            )
          );

    }

    my $sql_package = Win32::OLE->new('DTS.Package2');

    my ( $server, $user, $password, $auth_code ) =
      $self->get_credential->to_list;

  #the last parameter is not even available for use, but the DTS API demands it:
    $sql_package->LoadFromSQLServer(
        $server,                          $user,
        $password,                        $auth_code,
        $options_ref->{package_password}, $options_ref->{id},
        $options_ref->{version_id},       $options_ref->{name},
        ''
    );

    confess "Could not fetch package information: "
      . Win32::OLE->LastError() . "\n"
      if ( Win32::OLE->LastError() );

    return Win32::SqlServer::DTS::Package->new($sql_package);

}

=head3 get_db_package_regex

Expect an regular expression as a parameter. The regular expression is case sensitive.

Returns a L object which name matches the regular expression passed as
an argument. Only one object is returned (the first one in a sorted list) even if there are more packages
names that matches.

=cut

sub get_db_package_regex {

    my $self  = shift;
    my $regex = shift;

    my $package_name = @{ $self->regex_pkgs_names($regex) }[0];

    unless ( defined($package_name) ) {

        cluck "Could not find any package with regex like $regex";
        return undef;

    }
    else {

        return $self->get_db_package( { name => $package_name } );

    }

}

=head3 regex_pkgs_names

Expect an string, as regular expression, as a parameter. The parameter is case insensitive and the string is compiled
internally in the method, so there is not need to use L or something like that to increase performance.

Returns an array reference with all the packages names that matched the regular expression passed as an argument.

=cut

sub regex_pkgs_names {

    my $self  = shift;
    my $regex = shift;

    my $list_ref = $self->list_pkgs_names();
    my @new_list;

    my $compiled_regex = qr/$regex/i;

    foreach my $name ( @{$list_ref} ) {

        push( @new_list, $name ) if ( $name =~ $compiled_regex );

    }

    return \@new_list;

}

=head3 list_pkgs_names

Returns an array reference with all the packages names available in the database of the MS SQL Server. The
items in the array are sorted for convenience.

=cut

sub list_pkgs_names {

    my $self = shift;

    my $sql_pkg =
      $self->get_sibling()
      ->GetPackageSQLServer( $self->get_credential->to_list() );

    confess "Could not connect to server: ", Win32::OLE->LastError(), "\n"
      if ( Win32::OLE->LastError() );

    my @list;

    foreach my $pkg_info ( in( $sql_pkg->EnumPackageInfos( '', 1, '' ) ) ) {

        push( @list, $pkg_info->Name );

    }

    @list = sort(@list);

    return \@list;

}

1;

__END__