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


line stmt bran cond sub pod time code
1             package Win32::SqlServer::DTS::Application;
2            
3             =head1 NAME
4            
5             Win32::SqlServer::DTS::Application - a Perl class to emulate Microsoft SQL Server 2000 DTS Application object
6            
7             =head1 SYNOPSIS
8            
9             use Win32::SqlServer::DTS::Application;
10            
11             my $app = Win32::SqlServer::DTS::Application->new(
12             {
13             server => $server,
14             user => $user,
15             password => $password,
16             use_trusted_connection => 0
17             }
18             );
19            
20             # fetchs a list of packages
21             my @list = qw( LoadData ChangeData ExportData);
22            
23             foreach my $name ( @list ) {
24            
25             my $package = $self->get_db_package( { name => $name } ) );
26             print $package->to_string;
27            
28             }
29            
30            
31             =head1 DESCRIPTION
32            
33             This Perl class represents the Application object from the MS SQL Server 2000 API.
34             Before fetching any package from a server one must instantiate a C object that will provide
35             methods to fetch packages without having to provide autentication each time.
36            
37             =head2 EXPORT
38            
39             None by default.
40            
41             =cut
42            
43 1     1   42025 use strict;
  1         2  
  1         39  
44 1     1   5 use warnings;
  1         2  
  1         34  
45 1     1   5 use Carp qw(confess cluck);
  1         7  
  1         90  
46 1     1   5 use base qw(Class::Accessor Win32::SqlServer::DTS);
  1         2  
  1         962  
47             use Win32::OLE qw(in);
48             use Win32::SqlServer::DTS::Package;
49             use Win32::SqlServer::DTS::Credential;
50             use Hash::Util qw(lock_keys);
51            
52             __PACKAGE__->follow_best_practice;
53             __PACKAGE__->mk_ro_accessors(qw(credential));
54            
55             =head2 METHODS
56            
57             =head3 new
58            
59             Instantiate a new object from C class. The expected parameter is a hash reference with the
60             following keys:
61            
62             =over
63            
64             =item *
65             server: the name of a database server already configured in the Enterprise Manager.
66            
67             =item *
68             user: a string of the user used to authenticate against the database server. Not necessary to specify
69             if C is true.
70            
71             =item *
72             password: a string of the password used to authenticate against the database server. Not necessary to specify
73             if C is true.
74            
75             =item *
76             use_trusted_connection: a true/false value (1 or 0, respectivally) to specify if a Trusted Connection will be the
77             authentication method to be used.
78            
79             =back
80            
81             See L for an example.
82            
83             =cut
84            
85             sub new {
86            
87             my $class = shift;
88             my $properties = shift;
89            
90             confess "expects an hash reference as a parameter"
91             unless ( ref($properties) eq 'HASH' );
92            
93             my $self;
94            
95             $self->{credential} = Win32::SqlServer::DTS::Credential->new($properties);
96            
97             $self->{_sibling} = Win32::OLE->new('DTS.Application');
98            
99             bless $self, $class;
100             lock_keys( %{$self} );
101             return $self;
102            
103             }
104            
105             =head3 get_db_package
106            
107             Fetchs a single package from a MS SQL server and returns a respective C object. Expects a hash
108             reference as a parameter, having the following keys defined:
109            
110             =over
111            
112             =item *
113             id: the uniq package ID. Obligatory if a package C is not provided.
114            
115             =item *
116             version_id: the version ID of the package. If not provided, the last version of the package will be fetched.
117            
118             =item *
119             name: the name of the package. Obligatory if a package C is not provided.
120            
121             =item *
122             package_password: the password used to restrict access to the package. Not obligatory if no password is used.
123            
124             =back
125            
126             =cut
127            
128             sub get_db_package {
129            
130             my $self = shift;
131             my $options_ref = shift;
132            
133             # validates if the parameters are valid
134             confess "Package name or ID must be informed\n"
135             unless (
136             (
137             ( exists( $options_ref->{id} ) )
138             and ( defined( $options_ref->{id} ) )
139             )
140             or ( ( exists( $options_ref->{name} ) )
141             and ( defined( $options_ref->{name} ) ) )
142             );
143            
144             $options_ref->{id} = '' unless ( defined( $options_ref->{id} ) );
145             $options_ref->{name} = '' unless ( defined( $options_ref->{name} ) );
146            
147             foreach my $attribute (qw(package_password version_id)) {
148            
149             $options_ref->{$attribute} = ''
150             unless (
151             (
152             exists( $options_ref->{$attribute} )
153             and ( defined( $options_ref->{$attribute} ) )
154             )
155             );
156            
157             }
158            
159             my $sql_package = Win32::OLE->new('DTS.Package2');
160            
161             my ( $server, $user, $password, $auth_code ) =
162             $self->get_credential->to_list;
163            
164             #the last parameter is not even available for use, but the DTS API demands it:
165             $sql_package->LoadFromSQLServer(
166             $server, $user,
167             $password, $auth_code,
168             $options_ref->{package_password}, $options_ref->{id},
169             $options_ref->{version_id}, $options_ref->{name},
170             ''
171             );
172            
173             confess "Could not fetch package information: "
174             . Win32::OLE->LastError() . "\n"
175             if ( Win32::OLE->LastError() );
176            
177             return Win32::SqlServer::DTS::Package->new($sql_package);
178            
179             }
180            
181             =head3 get_db_package_regex
182            
183             Expect an regular expression as a parameter. The regular expression is case sensitive.
184            
185             Returns a L object which name matches the regular expression passed as
186             an argument. Only one object is returned (the first one in a sorted list) even if there are more packages
187             names that matches.
188            
189             =cut
190            
191             sub get_db_package_regex {
192            
193             my $self = shift;
194             my $regex = shift;
195            
196             my $package_name = @{ $self->regex_pkgs_names($regex) }[0];
197            
198             unless ( defined($package_name) ) {
199            
200             cluck "Could not find any package with regex like $regex";
201             return undef;
202            
203             }
204             else {
205            
206             return $self->get_db_package( { name => $package_name } );
207            
208             }
209            
210             }
211            
212             =head3 regex_pkgs_names
213            
214             Expect an string, as regular expression, as a parameter. The parameter is case insensitive and the string is compiled
215             internally in the method, so there is not need to use L or something like that to increase performance.
216            
217             Returns an array reference with all the packages names that matched the regular expression passed as an argument.
218            
219             =cut
220            
221             sub regex_pkgs_names {
222            
223             my $self = shift;
224             my $regex = shift;
225            
226             my $list_ref = $self->list_pkgs_names();
227             my @new_list;
228            
229             my $compiled_regex = qr/$regex/i;
230            
231             foreach my $name ( @{$list_ref} ) {
232            
233             push( @new_list, $name ) if ( $name =~ $compiled_regex );
234            
235             }
236            
237             return \@new_list;
238            
239             }
240            
241             =head3 list_pkgs_names
242            
243             Returns an array reference with all the packages names available in the database of the MS SQL Server. The
244             items in the array are sorted for convenience.
245            
246             =cut
247            
248             sub list_pkgs_names {
249            
250             my $self = shift;
251            
252             my $sql_pkg =
253             $self->get_sibling()
254             ->GetPackageSQLServer( $self->get_credential->to_list() );
255            
256             confess "Could not connect to server: ", Win32::OLE->LastError(), "\n"
257             if ( Win32::OLE->LastError() );
258            
259             my @list;
260            
261             foreach my $pkg_info ( in( $sql_pkg->EnumPackageInfos( '', 1, '' ) ) ) {
262            
263             push( @list, $pkg_info->Name );
264            
265             }
266            
267             @list = sort(@list);
268            
269             return \@list;
270            
271             }
272            
273             1;
274            
275             __END__