Win32::SqlServer::DTS::Package - a Perl class to access Microsoft SQL Server 2000 DTS Packages

  use Win32::SqlServer::DTS::Package;

	# $OLE_package is an already instantied class using Win32::OLE
	my $package = Win32::SqlServer::DTS::Package->new( $OLE_package );

	# prints the custom task name
	print $custom_task->get_name, "\n";

package Win32::SqlServer::DTS::Package;

use 5.008008;
use strict;
use warnings;
use Carp qw(confess);
use base qw(Class::Accessor Win32::SqlServer::DTS);
use Win32::SqlServer::DTS::TaskFactory;
use Win32::SqlServer::DTS::Connection;
use Win32::OLE qw(in);
use Win32::SqlServer::DTS::DateTime;
use Win32::SqlServer::DTS::Package::Step;
use Hash::Util qw(lock_keys);
use File::Spec;
use Win32::SqlServer::DTS::TaskTypes;

our $VERSION = '0.04';

__PACKAGE__->follow_best_practice;
__PACKAGE__->mk_ro_accessors(
    qw(creation_date creator_computer description log_file max_steps name id priority version_id )
);

sub execute {

    my $self = shift;

    $self->get_sibling()->Execute();

    my $iterator = $self->get_steps();

    my @results;

    while ( my $step = $iterator->() ) {

        push( @results, $step->get_exec_error_info() );

    }

    return \@results;

}

sub get_steps {

    my $self = shift;

    my $steps   = $self->get_sibling()->Steps;
    my $total   = scalar( in($steps) );
    my $counter = 0;

    return sub {

        return unless ( $counter < $total );

        my $step = ( in($steps) )[$counter];

        $counter++;

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

      }

}

sub log_to_server {

    my $self = shift;
    return $self->{log_to_server};

}

sub auto_commit {

    my $self = shift;
    return $self->{auto_commit};

}

sub new {

    my $class = shift;
    my $self = { _sibling => shift };

    bless $self, $class;

    $self->{auto_commit}      = $self->get_sibling()->AutoCommitTransaction;
    $self->{creator_computer} = $self->get_sibling()->CreatorComputerName;
    $self->{description}      = $self->get_sibling()->Description;
    $self->{fail_on_error}    = $self->get_sibling()->FailOnError;
    $self->{log_file}         = $self->get_sibling()->LogFileName;
    $self->{max_steps}        = $self->get_sibling()->MaxConcurrentSteps;
    $self->{name}             = $self->get_sibling()->Name;
    $self->{id}               = $self->get_sibling()->PackageID;
    $self->{version_id}       = $self->get_sibling()->VersionID;
    $self->{nt_event_log} =
      $self->{_sibling}->WriteCompletionStatusToNTEventLog;

    $self->{log_to_server} = $self->get_sibling()->LogToSQLServer;
    $self->{explicit_global_vars} =
      $self->get_sibling()->ExplicitGlobalVariables;

    $self->_set_lineage_opts();
    $self->_set_priority();

    $self->{creation_date} =
      Win32::SqlServer::DTS::DateTime->new( $self->get_sibling()->CreationDate );

    $self->{_known_tasks} = undef;

    lock_keys( %{$self} );

    return $self;

}

sub use_explicit_global_vars {

    my $self = shift;
    return $self->{explicit_global_vars};

}

sub use_event_log {

    my $self = shift;
    return $self->{nt_event_log};

}

sub fail_on_error {

    my $self = shift;
    return $self->{fail_on_error};

}

sub _set_priority {

    my $self         = shift;
    my $numeric_code = $self->get_sibling()->PackagePriorityClass;

  CASE: {

        if ( $numeric_code == 3 ) {

            $self->{priority} = 'High';
            last CASE;

        }

        if ( $numeric_code == 1 ) {

            $self->{priority} = 'Low';
            last CASE;

        }

        if ( $numeric_code == 2 ) {

            $self->{priority} = 'Normal';
            last CASE;

        }

    }

}

sub _set_lineage_opts {

    my $self = shift;

    my $numeric_code = $self->get_sibling()->LineageOptions;

    $self->{add_lineage_vars}       = 0;
    $self->{is_lineage_none}        = 0;
    $self->{is_repository}          = 0;
    $self->{is_repository_required} = 0;

# those values come from DTSLineageOptions in the DTS Programming MS SQL Server documentation
    $self->{add_lineage_vars}       = $numeric_code & 1;
    $self->{is_lineage_none}        = 1 if ( $numeric_code == 0 );
    $self->{is_repository}          = $numeric_code & 2;
    $self->{is_repository_required} = $numeric_code & 3;

}

sub add_lineage_vars {

    my $self = shift;
    return $self->{add_lineage_vars};

}

sub is_lineage_none {

    my $self = shift;
    return $self->{is_lineage_none};

}

sub is_repository {

    my $self = shift;
    return $self->{is_repository};

}

sub is_repository_required {

    my $self = shift;
    return $self->{is_repository_required};

}

sub to_string {

    my $self = shift;

    return "\tName: "
      . $self->get_name
      . "\n\tID: "
      . $self->get_id
      . "\n\tVersion ID: "
      . $self->get_version_id
      . "\n\tComputer where the package was created: "
      . $self->get_creator_computer
      . "\n\tDescription: "
      . $self->get_description
      . "\n\tExecution priority: "
      . $self->get_priority
      . "\n\tAuto commit enable? "
      . ( ( $self->auto_commit ) ? 'true' : 'false' )
      . "\n\tCreation date: "
      . $self->get_creation_date->datetime
      . "\n\tFail on error? "
      . ( ( $self->fail_on_error ) ? 'true' : 'false' )
      . "\n\tLog file: "
      . $self->get_log_file
      . "\n\tMaximum number of steps: "
      . $self->get_max_steps
      . "\n\tAdd lineage variables? "
      . ( ( $self->add_lineage_vars ) ? 'true' : 'false' )
      . "\n\tIs lineage none? "
      . ( ( $self->is_lineage_none ) ? 'true' : 'false' )
      . "\n\tWrite to repository if available? "
      . ( ( $self->is_repository ) ? 'true' : 'false' )
      . "\n\tWrite to repository is required? "
      . ( ( $self->is_repository_required ) ? 'true' : 'false' )
      . "\n\tLog to SQL Server? "
      . ( ( $self->log_to_server ) ? 'true' : 'false' )
      . "\n\tUse explicit global variables? "
      . ( ( $self->use_explicit_global_vars ) ? 'true' : 'false' )
      . "\n\tUse event log for logging? "
      . ( ( $self->use_event_log ) ? 'true' : 'false' );

}

sub get_connections {

    my $self    = shift;
    my $total   = scalar( in( $self->get_sibling()->Connections ) );
    my $counter = 0;

    return sub {

        return unless ( $counter < $total );

        my $conn = ( in( $self->get_sibling()->Connections ) )[$counter];

        $counter++;

        return Win32::SqlServer::DTS::Connection->new($conn);

      }

}

sub count_connections {

    my $self    = shift;
    my $counter = 0;

    foreach my $connection ( in( $self->get_sibling->Connections ) ) {

        $counter++;

    }

    return $counter;

}

sub get_tasks {

    my $self    = shift;
    my $tasks   = $self->get_sibling()->Tasks;
    my $total   = scalar( in($tasks) );
    my $counter = 0;

    return sub {

        return unless ( $counter < $total );

        my $task = ( in($tasks) )[$counter];

        $counter++;

        return Win32::SqlServer::DTS::TaskFactory::create($task);

      }

}

sub count_tasks {

    my $self    = shift;
    my $counter = 0;

    map { $counter++; } ( in( $self->get_sibling->Tasks ) );

    return $counter;

}

sub _get_tasks_by_type {

    my $self             = shift;
    my $type             = shift;
    my $iterator_counter = 0;

    unless ( keys( %{ $self->{_known_tasks} } ) ) {

        my $list = Win32::SqlServer::DTS::TaskTypes::get_types();

        foreach my $item ( @{$list} ) {

            $self->{_known_tasks}->{$item} = [];

        }

        #avoid caching invalid types
        lock_keys( %{ $self->{_known_tasks} } );

        my $counter = 0;

        foreach my $task ( in( $self->get_sibling()->Tasks ) ) {

# :TRICKY:3/11/2008:arfreitas: must avoid completely caching an unimplemeted DTS class in Perldts
            if ( grep { $task->CustomTaskID eq $_ } @{$list} ) {

                push(
                    @{ $self->{_known_tasks}->{ $task->CustomTaskID } },
                    $counter
                );

            }

# counter must be incremented anyway to get the proper indexes returned by in() function
            $counter++;

        }

    }

    return sub {

        my $total = scalar( @{ $self->{_known_tasks}->{$type} } );

        return unless ( $iterator_counter < $total );

#array slash of all tasks using as a index the number provided by known tasks cache
        my $task =
          ( in( $self->get_sibling()->Tasks ) )
          [ $self->{_known_tasks}->{$type}->[$iterator_counter] ];

        $iterator_counter++;

        return Win32::SqlServer::DTS::TaskFactory::create($task);

      }

}

sub _count_tasks_by_type {

    my $self    = shift;
    my $type    = shift;
    my $counter = 0;

    foreach my $task ( in( $self->get_sibling()->Tasks ) ) {

        next unless ( $task->CustomTaskID eq $type );
        $counter++;

    }

    return $counter;

}

sub count_datapumps {

    my $self = shift;
    return $self->_count_tasks_by_type('DTSDataPumpTask');

}

sub get_datapumps {

    my $self = shift;
    return $self->_get_tasks_by_type('DTSDataPumpTask');

}

sub count_dynamic_props {

    my $self = shift;
    return $self->_count_tasks_by_type('DTSDynamicPropertiesTask');

}

sub get_dynamic_props {

    my $self = shift;
    return $self->_get_tasks_by_type('DTSDynamicPropertiesTask');

}

sub get_execute_pkgs {

    my $self = shift;
    return $self->_get_tasks_by_type('DTSExecutePackageTask');

}

sub count_execute_pkgs {

    my $self = shift;
    return $self->_count_tasks_by_type('DTSExecutePackageTask');

}

sub get_send_emails {

    my $self = shift;

    return $self->_get_tasks_by_type('DTSSendMailTask');

}

sub count_send_emails {

    my $self = shift;
    return $self->_count_tasks_by_type('DTSSendMailTask');

}

sub save_to_server {

    my $self       = shift;
    my $credential = shift;

    confess "invalid credential parameter"
      unless ( $credential->isa('Win32::SqlServer::DTS::Credential') );

    $self->get_sibling()->SaveToSQLServer( $credential->to_list() );

    confess 'could not save the packate to a SQL Server: '
      . Win32::OLE->LastError()
      if ( Win32::OLE->LastError() );

}

sub save_to_file {

    my $self = shift;
    my $path = shift;
    my $file = shift;

    confess "invalid complete pathname parameter" unless ( defined($path) );

    $file = $self->get_name() . '.dts' unless ( defined($file) );

    $path = File::Spec->catfile( $path, $file );
    $self->get_sibling()->SaveToStorageFile($path);

    confess "could not save '$path': " . Win32::OLE->LastError()
      if ( Win32::OLE->LastError() );

}

1;
__END__