Test::mysqld won't close mysqld as expected - perl

I have this script:
#!/var/home/cherry/opt/perl
use Test::More;
use DBI;
use Test::mysqld;
use Data::Dumper;
my $mysqld = Test::mysqld->new(
base_dir => '/tmp/test_mysqls',
my_cnf => {
'skip-networking' => '', # no TCP socket
}
) or plan skip_all => $Test::mysqld::errstr;
my $dbh = DBI->connect(
$mysqld->dsn(dbname => 'test'),
);
warn Dumper($mysqld);
done_testing();
When I run this, here's the output I get:
prove -lv t/test.t
t/test.t .. $VAR1 = bless( {
'_owner_pid' => 21854,
'base_dir' => '/tmp/test_mysqls',
'pid' => 21918,
'mysql_install_db' => '/usr/bin/mysql_install_db',
'auto_start' => 2,
'my_cnf' => {
'tmpdir' => '/tmp/test_mysqls/tmp',
'pid-file' => '/tmp/test_mysqls/tmp/mysqld.pid',
'skip-networking' => '',
'datadir' => '/tmp/test_mysqls/var',
'socket' => '/tmp/test_mysqls/tmp/mysql.sock'
},
'mysqld' => '/usr/sbin/mysqld'
}, 'Test::mysqld' );
1..0
The test never completes. The script waits on a newline for ever and never exits -- when I do ps aux, I can see the instance of mysqld running even after I do ctrl + c. I don't even know where to begin to troubleshoot this issue. Any hints?

Try adding a do {} and invoking $mysqld->stop inside an eval {} to shut down the mysqld.
my $mysqld = Test::mysqld->new(
base_dir => '/tmp/test_mysqls',
my_cnf => {
'skip-networking' => '', # no TCP socket
}
) or do {
eval { $mysqld->stop };
plan skip_all => $Test::mysqld::errstr;
};

Related

Getting "000004DC: LdapErr: DSID-0C090752." when performing bind in perl using Net::LDAP

Objective is to get the "dn" attribute of all the computers in my Active Directory server.
When the code executes I get: "000004DC: LdapErr: DSID-0C090752, comment: In order to perform this operation a successful bind must be completed on the connection."
Here is my code:
#!/usr/bin/perl
use strict;
use Net::LDAP;
use Data::Dumper;
my $ldap = Net::LDAP->new( 'my.domain.com' ) or die $#;
my $user = 'CN=username,OU=orgname,DC=my,DC=domain,DC=com';
my $pass = 'my_password';
$ldap->bind($user, password => $pass);
#$ldap->bind;
my $mesg = $ldap->search(
base => "DC=my,DC=domain,DC=com",
filter => "ObjectClass=Computers",
attrs => "dn"
);
I've tested the user / password to log into the domain directly with success.
Additional information if I add this to the end of the script: print Dumper($mesg);
$VAR1 = bless( {
'parent' => bless( {
'net_ldap_version' => 3,
'net_ldap_scheme' => 'ldap',
'net_ldap_debug' => 0,
'net_ldap_socket' => bless( \*Symbol::GEN0, 'IO::Socket::INET' ),
'net_ldap_host' => 'my.domain.com',
'net_ldap_uri' => 'my.domain.com',
'net_ldap_resp' => {},
'net_ldap_mesg' => {},
'net_ldap_async' => 0,
'net_ldap_port' => 389,
'net_ldap_refcnt' => 1
}, 'Net::LDAP' ),
'errorMessage' => '000004DC: LdapErr: DSID-0C090752, comment: In order to perform this operation a successful bind must be completed on the connection., data 0, v2580',
'ctrl_hash' => undef,
'resultCode' => 1,
'callback' => undef,
'mesgid' => 2,
'matchedDN' => '',
'controls' => undef,
'raw' => undef
}, 'Net::LDAP::Search' );
Any suggestions on how to get this script working is what I'm looking for.
Thanks!
With regard to the error message you posted I would say the bind attempt failed.
It might help you to improve bind result:
$mesg = $_ldap->bind("***", password => "***");
$mesg->is_error && die join ';' $mesg->code, $mesg->error
See Net::LDAP:
The return value from these methods is an object derived from the
Net::LDAP::Message class. The methods of this class allow you to
examine the status of the request.

Data::Dumper::Freezer proper usage

I'm trying to log data structures in an old and big Perl project. In order to do so, I use Data::Dumper, however, some structures are a bit too large and spam the log. So I'm looking for a way to log them in a less verbose manner.
Now Dumper's doc mentions $Data::Dumper::Freezer = <method_name> variable that can be used to fix that. I've tried using that.
Adding a serializer method that returns "shortened" value results in nothing, though the method gets called. Making the serializer method act on $_[0] causes the needed effect, but spoils the original data structure.
I'm confused. What am I doing wrong? How can I fix it?
Here's a refined sample code:
#!/usr/bin/env perl
use strict;
use warnings;
use Data::Dumper;
$Data::Dumper::Indent = 0;
$\="\n";
my $x = Foo->new ( answer => 42, use => "force" );
my $y = { foo => $x };
print "initial plain:\n\t", Dumper( $x );
print "initial compound:\n\t", Dumper( $y );
{
local $Data::Dumper::Freezer = 'freeze_pure';
print "still not abbreviated data:\n\t", Dumper( $y );
};
{
local $Data::Dumper::Freezer = 'freeze_replace';
print "abbreviated data:\n\t", Dumper( $y );
};
print "initial data is still intact:\n\t", Dumper( $x );
print "compound data is corrupted:\n\t", Dumper( $y );
package Foo;
sub new {
my $class = shift;
return bless { #_ }, $class;
};
sub freeze_pure {
my $self = $_[0];
warn "# In freeze_pure";
return bless {
values => join ",", values %$self
}, (ref $self) . "::short";
};
sub freeze_replace {
my $self = $_[0];
warn "# In freeze_replace";
$_[0] = bless {
values => join ",", values %$self
}, (ref $self) . "::short";
return;
};
And output:
initial plain:
$VAR1 = bless( {'use' => 'force','answer' => 42}, 'Foo' );
initial compound:
$VAR1 = {'foo' => bless( {'use' => 'force','answer' => 42}, 'Foo' )};
# In freeze_pure at dumper-freezer.pl line 36.
still not abbreviated data:
$VAR1 = {'foo' => bless( {'use' => 'force','answer' => 42}, 'Foo' )};
# In freeze_replace at dumper-freezer.pl line 42.
abbreviated data:
$VAR1 = {'foo' => bless( {'values' => 'force,42'}, 'Foo::short' )};
initial data is still intact:
$VAR1 = bless( {'use' => 'force','answer' => 42}, 'Foo' );
compound data is corrupted:
$VAR1 = {'foo' => bless( {'values' => 'force,42'}, 'Foo::short' )};
Although the documentation is a bit sparse, the intended use of freezer/toaster is data serialization/de-serialization, not prettification of debugging output.
So, Data::Dumper calls the freezer method, but doesn't use the return value. The idea is probably that if you're going to serialize an object, you won't be messing with it again until you de-serialize it, so there's no problem with changing the object itself.
Here's the relevant section of code from the Data::Dumper source:
# Call the freezer method if it's specified and the object has the
# method. Trap errors and warn() instead of die()ing, like the XS
# implementation.
my $freezer = $s->{freezer};
if ($freezer and UNIVERSAL::can($val, $freezer)) {
eval { $val->$freezer() };
warn "WARNING(Freezer method call failed): $#" if $#;
}
If you just want to reduce the size of the output in your logs, you can remove newlines and indentation by setting $Data::Dumper::Indent to zero:
use Data::Dumper;
use WWW::Mechanize;
$Data::Dumper::Indent = 0;
my $mech = WWW::Mechanize->new;
print Dumper $mech;
Output:
$VAR1 = bless( {'headers' => {},'ssl_opts' => {'verify_hostname' => 1},'forms' => undef,'page_stack' => [],'text' => undef,'requests_redirectable' => ['GET','HEAD','POST'],'timeout' => 180,'onerror' => sub { "DUMMY" },'current_form' => undef,'links' => undef,'max_redirect' => 7,'quiet' => 0,'images' => undef,'noproxy' => 0,'stack_depth' => 8675309,'show_progress' => undef,'protocols_forbidden' => undef,'no_proxy' => [],'handlers' => {'request_prepare' => bless( [{'owner' => 'LWP::UserAgent::cookie_jar','callback' => sub { "DUMMY" },'line' => '/home/foo/perl5/perlbrew/perls/perl-5.16.3/lib/site_perl/5.16.3/LWP/UserAgent.pm:705'}], 'HTTP::Config' ),'response_header' => bless( [{'owner' => 'LWP::UserAgent::parse_head','callback' => sub { "DUMMY" },'m_media_type' => 'html','line' => '/home/foo/perl5/perlbrew/perls/perl-5.16.3/lib/site_perl/5.16.3/LWP/UserAgent.pm:684'}], 'HTTP::Config' ),'response_done' => bless( [{'owner' => 'LWP::UserAgent::cookie_jar','callback' => sub { "DUMMY" },'line' => '/home/foo/perl5/perlbrew/perls/perl-5.16.3/lib/site_perl/5.16.3/LWP/UserAgent.pm:708'}], 'HTTP::Config' )},'onwarn' => sub { "DUMMY" },'protocols_allowed' => undef,'use_eval' => 1,'local_address' => undef,'autocheck' => 1,'title' => undef,'def_headers' => bless( {'user-agent' => 'WWW-Mechanize/1.75'}, 'HTTP::Headers' ),'cookie_jar' => bless( {'COOKIES' => {}}, 'HTTP::Cookies' ),'proxy' => {},'max_size' => undef}, 'WWW::Mechanize' );
This is still a lot of output, but it's certainly more compact than:
$VAR1 = bless( {
'headers' => {},
'ssl_opts' => {
'verify_hostname' => 1
},
'forms' => undef,
'page_stack' => [],
'text' => undef,
'requests_redirectable' => [
'GET',
'HEAD',
'POST'
],
'timeout' => 180,
'onerror' => sub { "DUMMY" },
'current_form' => undef,
'links' => undef,
'max_redirect' => 7,
'quiet' => 0,
'images' => undef,
'noproxy' => 0,
'stack_depth' => 8675309,
'show_progress' => undef,
'protocols_forbidden' => undef,
'no_proxy' => [],
'handlers' => {
'request_prepare' => bless( [
{
'owner' => 'LWP::UserAgent::cookie_jar',
'callback' => sub { "DUMMY" },
'line' => '/home/foo/perl5/perlbrew/perls/perl-5.16.3/lib/site_perl/5.16.3/LWP/UserAgent.pm:705'
}
], 'HTTP::Config' ),
'response_header' => bless( [
{
'owner' => 'LWP::UserAgent::parse_head',
'callback' => sub { "DUMMY" },
'm_media_type' => 'html',
'line' => '/home/foo/perl5/perlbrew/perls/perl-5.16.3/lib/site_perl/5.16.3/LWP/UserAgent.pm:684'
}
], 'HTTP::Config' ),
'response_done' => bless( [
{
'owner' => 'LWP::UserAgent::cookie_jar',
'callback' => sub { "DUMMY" },
'line' => '/home/foo/perl5/perlbrew/perls/perl-5.16.3/lib/site_perl/5.16.3/LWP/UserAgent.pm:708'
}
], 'HTTP::Config' )
},
'onwarn' => sub { "DUMMY" },
'protocols_allowed' => undef,
'use_eval' => 1,
'local_address' => undef,
'autocheck' => 1,
'title' => undef,
'def_headers' => bless( {
'user-agent' => 'WWW-Mechanize/1.75'
}, 'HTTP::Headers' ),
'cookie_jar' => bless( {
'COOKIES' => {}
}, 'HTTP::Cookies' ),
'proxy' => {},
'max_size' => undef
}, 'WWW::Mechanize' );
Alternatively, you could try Data::Dump, which allows you to filter the output using Data::Dump::Filtered. I prefer Data::Dump to Data::Dumper anyway because I think it has more sensible defaults (e.g. outputting escape sequences for whitespace other than spaces).
I haven't used the filtering feature yet, but brian d foy wrote a nice article about it with several examples.

Perl : parse a file and grab blocks

impossible to parse the file below and grab the blocks in an hash table or simple tab.
I would like to have an hash table with for example
[serv-test] => parent=PRODUCTION.Windows,host=1.1.1.1
Problem is I can delimit the start of a block (with /\[.*\]/) but impossible to delimit the end. The end of my blocks is the start of another.
My file:
authreq=false
default.secured=false
port=3181
protocol=TCP
seclevel=2
secured=false
[serv-test]
parent=PRODUCTION.Windows
host=1.1.1.1
[citrix]
parent=PRODUCTION.Windows
host=1.1.1.2
[cluster-serv]
parent=PRODUCTION.Unix._INFRA
host=1.1.1.3
port=3182
Instead of worrying about getting a hash, be satisfied with getting the data. If you give the top a section name, you have an INI File:
[Default]
authreq=false
default.secured=false
port=3181
protocol=TCP
seclevel=2
secured=false
[serv-test]
parent=PRODUCTION.Windows
host=1.1.1.1
[citrix]
parent=PRODUCTION.Windows
host=1.1.1.2
[cluster-serv]
parent=PRODUCTION.Unix._INFRA
host=1.1.1.3
port=3182
Now you can use Config::IniFiles:
use v5.10;
use Config::IniFiles;
my $cfg = Config::IniFiles->new(
-file => "test.ini"
) or die "#Config::IniFiles::errors";
say "Port is ", $cfg->val( 'Default', 'port' );
say "Cluster host is ", $cfg->val( 'cluster-serv', 'host' );
If you really want the hash, that's not so hard:
use Config::IniFiles;
use Data::Dumper;
my $cfg = Config::IniFiles->new(
-file => "test.ini"
) or die "#Config::IniFiles::errors";
my %hash;
foreach my $section ( $cfg->Sections ) {
foreach my $parameter ( $cfg->Parameters( $section ) ) {
$hash{$section}{$parameter} = $cfg->val( $section, $parameter );
}
}
say Dumper \%hash;
Now you have:
$VAR1 = {
'citrix' => {
'parent' => 'PRODUCTION.Windows',
'host' => '1.1.1.2'
},
'Default' => {
'secured' => 'false',
'port' => '3181',
'protocol' => 'TCP',
'default.secured' => 'false',
'authreq' => 'false',
'seclevel' => '2'
},
'serv-test' => {
'host' => '1.1.1.1',
'parent' => 'PRODUCTION.Windows'
},
'cluster-serv' => {
'port' => '3182',
'parent' => 'PRODUCTION.Unix._INFRA',
'host' => '1.1.1.3'
}
};
Don't reinvent the wheel. There are plenty of existing modules for working with INI-style files, including Config::Tiny, Config::INI, and Config::IniFiles, just to name a few.

perl Email::MIME not working intermittent

the following code sometimes work, and sometimes do not. It is runnign on linux, where postfix is installed, i disabled it and stopped the service. does this need postfix to run?
when i run this test code in terminal i get no error and no email.
#!/usr/bin/perl
use warnings;
use strict;
use Data::Dumper;
use Email::MIME;
use Email::Sender::Simple qw(sendmail);
my $sub='test';
my $exitCode=0;
my $emailTo='raxxxx#xxxx.com';
my $bcc='';
if ($exitCode == 0){$exitCode = '';}
my #mesgBody = ("test\n","email\n");
my $message = Email::MIME->create(
header_str => [
From => '"Rajeev" <'.$emailTo.'>',
To => $emailTo,
Subject => $sub,
],
attributes => {
'X-Priority' => 1,
'X-MSMail-Priority' => 'High',
encoding => 'quoted-printable',
charset => 'ISO-8859-1',
},
body_str => "#mesgBody"."\n".$exitCode, #old body_str => $sub."\n".$mesg."\n".$exitCode,
);
#sendmail($message);
if ($bcc eq ''){
my $result=sendmail(
$message,
{
from => '"Rajeev" <'.$emailTo.'>',
to => [$emailTo],
}
);
print "result=".Dumper($result)."\n";
} else {
sendmail(
$message,
{
from => '"Rajeev" <'.$emailTo.'>',
to => [$emailTo, $bcc],
}
);
}
output:->
result=$VAR1 = bless( {}, 'Email::Sender::Success' );
so if this is success, why am i not getting any email?
I also see nothing in system logs.
thank you.
# service postfix start
solved the problem.

Grab the fsynclock status of a mongo db in perl

I'm trying to build a nagios check to check for how long a mongoDB has been locked using fsyncLock() for backup purposes (if the iSCSI snapshotting script blows up and the mongo is not being unlocked for example)
I was thinking about using a simple
$currentLock->run_command({currentOp => 1})
$isLocked = $currentLock->{fsyncLock}
But it seems like run_command() doesn't support currentOp yet. (As seen in there: https://github.com/MLstate/opalang/blob/master/lib/stdlib/apis/mongo/commands.opa)
Woudl anybody have an advice on how to check if a mongo is locked with a perl script? If not, I guess I'll go for some bash. I was thinking about using a db.eval('db.currentOp()') but I'm getting a bit lost.
Thanks!
You are right that run_command does not support doing a currentOp directly. However, if we look at the implementation of db.currentOp in the mongo shell, we can see how it works under the hood:
> db.currentOp
function (arg) {
var q = {};
if (arg) {
if (typeof arg == "object") {
Object.extend(q, arg);
} else if (arg) {
q.$all = true;
}
}
return this.$cmd.sys.inprog.findOne(q);
}
So we can query the special collection $cmd.sys.inprog on the Perl side to get the same inprog array that would be returned in the shell.
use strict;
use warnings;
use MongoDB;
my $db = MongoDB::MongoClient->new->get_database( 'test' );
my $current_op = $db->get_collection( '$cmd.sys.inprog' )->find_one;
When the server is not locked, it will return a structure in $current_op that looks something like this:
{
'inprog' => [
{
'connectionId' => 53,
'insert' => {},
'active' => bless( do{\(my $o = 0)}, 'boolean' ),
'lockStats' => {
'timeAcquiringMicros' => {
'w' => 1,
'r' => 0
},
'timeLockedMicros' => {
'w' => 9,
'r' => 0
}
},
'numYields' => 0,
'locks' => {
'^' => 'w',
'^test' => 'W'
},
'waitingForLock' => $VAR1->{'inprog'}[0]{'active'},
'ns' => 'test.fnoof',
'client' => '127.0.0.1:50186',
'threadId' => '0x105a81000',
'desc' => 'conn53',
'opid' => 7152352,
'op' => 'insert'
}
]
};
During an fsyncLock(), you'll get an empty inprog array but you will have a helpful info field and the expected fsyncLock boolean:
{
'info' => 'use db.fsyncUnlock() to terminate the fsync write/snapshot lock',
'fsyncLock' => bless( do{\(my $o = 1)}, 'boolean' ), # <--- that's true
'inprog' => []
};
So, putting it all together, we get:
use strict;
use warnings;
use MongoDB;
my $db = MongoDB::MongoClient->new->get_database( 'fnarf' );
my $current_op = $db->get_collection( '$cmd.sys.inprog' )->find_one;
if ( $current_op->{fsyncLock} ) {
print "fsync lock is currently ON\n";
} else {
print "fsync lock is currently OFF\n";
}
I actually decided to switch for a solution in bash (easier for what I want to do with the data later):
currentOp=`mongo --port $port --host $host --eval "printjson(db.currentOp())"`
Then some sort of grep -Po '"fsyncLock" : \d'
Thanks for the Perl insight though, it worked perfectly