How to handle error thrown by module in perl - oracle

I am using the module DBD::Oracle in perl to insert xml contents into oracle 11 g instance. While inserting some of the documents in my sample set the script fails as the module returns Unsupported named object type for bind parameter. I would like to handle this error and make the loop iteration to go on.
following is my code,
use strict;
use warnings;
use DBI;
use DBD::Oracle qw(:ora_session_modes);
use DBD::Oracle qw(:ora_types);
die("USAGE: $0 <input_directory>") unless ($#ARGV == 0);
my $directory=$ARGV[0];
my $dbh = DBI->connect('dbi:Oraclle:dbname',"username", "pass");
my $SQL;
opendir(IMD, $directory) || die ("Cannot open directory");
my #listOfFiles= readdir(IMD);
closedir(IMD);
my $xmltype_string;
my $xml;
my $i = 1;
foreach my $file(#listOfFiles)
{
unless($file eq '.' or $file eq '..')
{
print "inserting File no. $i \t $file .... \n";
{
local $/=undef;
open (FILE , "<" , "$directory/$file" );
$xml=<FILE>;
close (FILE);
}
$SQL="insert into sampleTable values ( :ind, :xml)";
my $sth =$dbh-> prepare($SQL);
$sth->bind_param(":xml" , $xml , { ora_type => ORA_XMLTYPE});
$sth->bind_param(":ind" , $i);
$sth-> execute();
$i++;
}
}
Am getting the error in bind param.

Error handling is usually done via the Try::Tiny module:
use Try::Tiny;
try {
something_that_could_die();
}
catch {
handle_error($_);
}
finally {
do_something_either_way();
}; # ← trailing semicolon not optional.
Both catch and finally are optional.

Related

Perl - Uncompressing zip files on windows is too slow

I've created a uncompress function, put together from a few code snippets and a few alterations from my side, automatically handling the file type.
My current usecase is to extract a ~550mb zip file from a SMB share on windows with a lot of files in it (qt 5.5 source code)
On Linux, this is a tgz file on a nfs share and it takes 67 seconds for the function to extract it. (other uncompression method than for zip files)
On Windows it takes >15minutes.
I'm thinking about using a system(7z $source) call as alternative.
Do you have any suggestions what's the fastest method to extract a zip file on windows?
Plz be honest, if my uncompress function is crap, i'm no perl expert... :)
Here's my code:
#uncompress full archive file $archFile to $destPath
sub uncompress
{
my $fileToExtract = shift;
my $targetPath = shift;
my $silent = shift;
my $status;
my $buff;
unless (-f $fileToExtract)
{
&error ("$fileToExtract is not a file!");
}
unless (-d $targetPath)
{
&makeDir($targetPath, 1);
}
# just look for .tar since all .tar archives with all compressions can be extracted.
if ($fileToExtract =~ m/.tar/)
{
my $pwd = getcwd();
changeDirectory($targetPath, 1);
my $tar = Archive::Tar->new();
$tar->read($fileToExtract);
$tar->extract();
changeDirectory($pwd, 1);
return;
}
elsif ($fileToExtract =~ m/.zip$/)
{
my $u = new IO::Uncompress::Unzip $fileToExtract or die "Cannot open $fileToExtract: $UnzipError";
for ($status = 1; $status > 0; $status = $u->nextStream())
{
my $header = $u->getHeaderInfo();
my (undef, $path, $name) = splitpath($header->{Name});
my (undef, $path, $name) = splitpath($header->{Name});
my $destdir = "$targetPath$path";
unless (-d $destdir)
{
&makeDir( $destdir, 1);
}
if ($name =~ m!/$!) {
last if $status < 0;
next;
}
my $destfile = "$destdir/$name";
if ($destfile =~ m/\/\/$/) # skip if no filename is given
{
next;
}
$destfile =~ s|\/\/|\/|g; # remove unnecessary doubleslashes
my $fh = openFileHandle ( $destfile , '>', 1 );
binmode($fh);
while (($status = $u->read($buff)) > 0) {
$fh->write($buff);
}
$fh->close();
unless (defined $silent)
{
&syslog ("Uncompress $destfile -> $targetPath");
}
#set timestamps of file to the ones in the zip
my $stored_time = $header->{'Time'};
utime ($stored_time, $stored_time, $destfile);
}
if ($status < 0)
{
die "Error processing $fileToExtract: $!\n"
}
}
else
{
my $ae = Archive::Extract->new( archive => $fileToExtract );
$ae->extract( to => $targetPath ) or &error("Failed to extract $fileToExtract with error $ae->error");
unless (defined $silent)
{
foreach my $file (#{$ae->files})
{
#only print if not a directory
if( $file!~m|/$| )
{
&syslog("Uncompress $fileToExtract -> $targetPath");
}
}
}
}
return;
}
You could simply do it in below manner using Archive::Extract, it provides generic archive extracting mechanism, therefore you don't have to install separate modules for tar and zip.
use Archive::Extract;
my $ae = Archive::Extract->new( archive => $fileToExtract );
my $ok = $ae->extract( to => $targetPath );
If you specifically want to check whether a file is tar or zip then you can use below:
$ae->is_tar
$ae->is_zip
Note that Archive::Extract is a core module therefore you'll not have to install it separetely.

Couldn't read config file: No such file or directory at ./try.pl line 8

I am not being able to read the contents of the file tutc.txt. I want to write a subroutine to read the contents of a file which will be called from the perl script.
My module is named Module.pm
package Module;
use warnings;
use strict;
use Carp;
use feature "switch";
no warnings 'experimental::smartmatch';
# Constructor and initialisation
sub new { #class method
my $class = shift; #shift without arguments is shift #_ , takes 1st element of argument array
my $self = {#_}; #created a Hash reference with #_ helping to store values in a hash
bless ($self, $class); #turning self into an object by telling which class it belongs to without hardcode name in
$self->{_created} = 1; #syntax for accessing the contemts of a hash: refrence $object_name->{property_name}.
return $self;
}
#reading from config file
sub read {
my ($self, $file) = shift;
my $self = #_;
open my $config_fh, $file or return 0;
$self->{_filename} = $file; # Store a special property containing the name of the file
my $section;
my $config_name;
my $config_val;
while (my $line = <$config_fh>)
{
chomp $line;
given ($line) {
when (/^\[(.*)\]/)
{
$section = $1;
}
when (/^(?<key>[^=]+)=(?<value>.*)/)
{
$section //= '';
$self->{"$section.$config_name"} = $config_val;
}
}
}
close $config_fh;
return $self;
}
sub fetch {
my ($self, $key) = shift;
return $self->{$key};
}
My perl file looks like the following:
#!/usr/bin/perl
use Module;
use strict;
use warnings;
my $value = Module->new();
$value->read('/Users/hhansraj/git/edgegrid-curl/tutc.txt') or die "Couldn't read config file: $!";
print "The author's first name is ",$value->fetch('author.firstname'),"\n";
My text file looks like the following:
[author]
firstname=Doug
lastname=Sheppard
[site]
name=Perl.com
url=http://www.perl.com/
In your "read" subroutine, it looks like the first two lines of code (listed below) may be the source of your problem.
my ($self, $file) = shift;
my $self = #_;
In the first line, you're removing the first element of the #_ array (arguments to the subroutine) and putting that into the $self variable. And nothing is being entered into the $file variable. In the second line, you are redeclaring the $self variable and are assigning to it the size of what's left of the #_ array. I suspect that you're code is assigning the value/data to the $self variable that you are wanting.
Since the $file variable is not getting assigned any value, that is probably creating an issue with the open function. Also, you did not specify the file mode in your attempt to open the file. To just fix the missing mode specification to specify read only mode, you can change the following line:
open my $config_fh, $file or return 0;
to be
open (my $config_fh, "<", $file) or return 0;

Extract lines between A and (B or C), containing D

I need to extract text between A and (B or C) patterns, that contains D pattern inside.
For example I have a file and need to extract all between "proc sql" and ("quit" or "run"), containing "index" inside.
proc sql
bla-bla-bla
index=10;
quit
proc sql
bla-bla-bla
quit;
proc sql
index=10;
run
Needed output:
proc sql
bla-bla-bla
index=10;
quit
proc sql
index=10;
run
By now I have such solution:
perl -0777 -lne 'print for grep /\bindex\b/i, /^proc sql.*?quit.*?\n/mgs' file
But it only extracts between "proc sql" and "quit" (NOT "quit" or "run"), containing "index". I don't know how to add OR operation.
If you can propose alternative awk/sed/grep solution - would be nice.
This will do as you ask. It accumulates into $block all the lines between the start and end patterns. When the end pattern is reached it prints the block if it contains index
use strict;
use warnings;
my $block;
while ( <DATA> ) {
my $state = /^proc sql\b/ .. /^(?:quit|run)\b/;
$block .= $_ if $state;
if ( $state =~ /E/ ) {
print $block, "\n" if $block =~ /^index=/m;
$block = '';
}
}
__DATA__
proc sql
bla-bla-bla
index=10;
quit
proc sql
bla-bla-bla
quit;
proc sql
index=10;
run
output
proc sql
bla-bla-bla
index=10;
quit
proc sql
index=10;
run
Given that your input file is named input.txt, this will solve it in awk:
awk 'BEGIN {
procDetected = 0;
indexDetected = 0;
}
/proc/ {
buffer = "";
indexDetected = 0;
procDetected = 1;
}
/index/ {
indexDetected = 1;
}
{
if (procDetected) {
# Add the line to the buffer.
buffer = buffer $0 "\n";
}
}
/run/ || /quit/ {
if (procDetected && indexDetected) {
print buffer;
}
procDetected = 0;
indexDetected = 0;
}' input.txt

Perl select returning undef on sysread when using Windows, IPC::Open3, and IO::Socket->socketpair()

I found this example (posted by #ikegami) of a way to use IPC::Open3 on windows using sockets. The problem is that, when I run it, I get an error An existing connection was forcibly closed by the remote host on the sysread. The command runs, the select works correctly, but the sysread is getting an undef instead of the expected 0 for end of file. This behavior is not the same for all commands. If I change the command to echo Hello World! it does not cause the error. Any idea what is going on here?
Here is the code from the example:
use strict;
use warnings;
use IO::Select qw( );
use IPC::Open3 qw( open3 );
use Socket qw( AF_UNIX SOCK_STREAM PF_UNSPEC );
print( "REMOVE ME: getting started\n" );
sub _pipe {
socketpair($_[0], $_[1], AF_UNIX, SOCK_STREAM, PF_UNSPEC)
or return undef;
shutdown($_[0], 1); # No more writing for reader
shutdown($_[1], 0); # No more reading for writer
return 1;
}
sub _open3 {
local (*TO_CHLD_R, *TO_CHLD_W);
local (*FR_CHLD_R, *FR_CHLD_W);
local (*FR_CHLD_ERR_R, *FR_CHLD_ERR_W);
if ($^O =~ /Win32/) {
_pipe(*TO_CHLD_R, *TO_CHLD_W ) or die $^E;
_pipe(*FR_CHLD_R, *FR_CHLD_W ) or die $^E;
_pipe(*FR_CHLD_ERR_R, *FR_CHLD_ERR_W) or die $^E;
} else {
pipe(*TO_CHLD_R, *TO_CHLD_W ) or die $!;
pipe(*FR_CHLD_R, *FR_CHLD_W ) or die $!;
pipe(*FR_CHLD_ERR_R, *FR_CHLD_ERR_W) or die $!;
}
my $pid = open3('>&TO_CHLD_R', '<&FR_CHLD_W', '<&FR_CHLD_ERR_W', #_);
return ( $pid, *TO_CHLD_W, *FR_CHLD_R, *FR_CHLD_ERR_R );
}
# when i change the command to 'echo Hello World' it works...
my ($pid, $to_chld, $fr_chld, $fr_chld_err) =
_open3('cmd /c "dir /s/b"');
my %objs;
my $in_sel = IO::Select->new();
my $out_sel = IO::Select->new();
for my $fh ($fr_chld, $fr_chld_err) {
my $obj = {
buf => '',
};
$objs{ fileno($fh) } = $obj;
$in_sel->add($fh);
}
close($to_chld);
while ($in_sel->count() + $out_sel->count()) {
my ($ins, $outs) = IO::Select::select($in_sel, $out_sel, undef);
for my $fh (#$ins) {
my $obj = $objs{ fileno($fh) };
our $buf; local *buf = \( $obj->{buf} );
my $bytes_read = sysread($fh, $buf, 64*1024, length($buf));
if (!$bytes_read) {
warn("Error reading from child: $!\n")
if !defined($bytes_read);
$in_sel->remove($fh);
}
}
for my $fh (#$outs) {
}
}
waitpid($pid, 0);
print("STDOUT:\n$objs{ fileno( $fr_chld ) }{buf}");
print("\n" );
print("STDERR:\n$objs{ fileno( $fr_chld_err ) }{buf}");
I think it's because something like shutdown was used instead of something like close. Sounds safe to ignore.
grep $!{$_}, keys %! shows ECONNRESET, so just change
warn("Error reading from child: $!\n")
if !defined($bytes_read);
to
warn("Error reading from child: $!\n")
if !defined($bytes_read) && !$!{ECONNRESET};

How do I set an Win32 system environment variable in Perl?

I want to be able to set a system environment variable in Perl and I wrote the following script (inspired from this idea) to accomplish this:
use Win32;
use Win32::API;
use Win32::OLE qw( in );
my $machine = ".";
my $WMIServices = Win32::OLE->GetObject ( "winmgmts:{impersonationLevel=impersonate,(security)}//$machine/root/cimv2" ) || die;
my $objVariable = $WMIServices->Get("Win32_Environment")->SpawnInstance_;
$objVariable->{Name}="NewOSType";
$objVariable->{UserName} = "<System>";
$objVariable->{VariableValue} = "LAMBDA";
$objVariable->Put_;
However, I am not an expert in Perl and I would like to know what the experts think about this code. Is this the best way to accomplish this?
Another possible approach:
use strict;
use warnings;
use Win32::TieRegistry qw[:KEY_];
use Win32::API;
use constant HWND_BROADCAST => -1;
use constant WM_SETTINGCHANGE => 0x1a;
my $hklm_env = Win32::TieRegistry->new(
'HKEY_LOCAL_MACHINE/SYSTEM/CurrentControlSet/Control/Session Manager/Environment',
{ Access => KEY_READ() | KEY_WRITE(), Delimiter => '/' }
); # returns undef if SYSTEM ENV not writable
my $hkcu_env = Win32::TieRegistry->new(
'HKEY_CURRENT_USER/Environment',
{ Access => KEY_READ() | KEY_WRITE(), Delimiter => '/' }
);
# if SYSTEM ENV not writable try USER ENV
my $e = defined($hklm_env) ? $hklm_env : $hkcu_env;
if(defined $e) {
$e->SetValue('Variable', 'Value');
}
else {
warn "Cannot open neither SYSTEM ENV nor USER ENV registry for Read+Write";
}
my $SendMessage = new Win32::API("user32", "SendMessage", 'NNNP', 'N') or die "Couldn't create SendMessage: $!\n";
my $RetVal = $SendMessage->Call(HWND_BROADCAST,WM_SETTINGCHANGE,0,'Environment');

Resources