I have a function which looks like the one written below. I need to write a unit test for the below function. I am not able to mock few values.
use File::Basename;
use File::Copy;
use File::Temp qw(tempdir);
our $CONFIG="/home/chetanv/svf.xml";
copyConfigFiles();
sub copyConfigFiles {
my $temp_dir = File::Temp->newdir();
my $targetpath = dirname("$CONFIG");
`sudo touch $tempdir/myfile`;
make_path($targetpath) if ( ! -d $targetpath );
File::Copy::copy("$temp_dir/myfile", $targetpath) or print "Problem copying file";
}
I have written the below unit test for the same below. I tried mocking "makepath" which does not seem to work.
subtest _setup(testname => "test copyConfigFiles") => sub {
my $CONFIG = "/my/dir/with/file.xml";
my $mockfileobj = Test::MockModule->new("File::Temp", no_auto => 1);
$mockfileobj->mock('newdir', sub { return "/tmp/delme"; } );
my $amockfileobj = Test::MockModule->new("File::Path", no_auto => 1);
$amockfileobj->mock('makepath', sub { return 0; } );
lives_ok { copyConfigFiles () } 'test copyConfigFiles OK';
done_testing();
};
The problem is i am not able to mock the below lines.
make_path($targetpath) if ( ! -d $targetpath );
File::Copy::copy("$temp_dir/myfile", $targetpath) or print "Problem copying file";
Any help on how i can mock the makepath function which is perl specific? I also tried to create a temporary directory and mock the global CONFIG file with the mocked file. Didn't seem to work.
If I ignore the code that can't be run because the context is missing and focus only on the two functions that you want mocked, one can do this by temporarily replacing the subs in the symbol table with local.
use warnings;
use strict;
use Data::Dump;
use File::Path qw/make_path/;
use File::Copy;
sub to_be_mocked {
my $targetpath = '/tmp/foo';
make_path($targetpath) if ! -d $targetpath;
File::Copy::copy("file.xml", $targetpath) or die;
}
sub run_with_mock {
no warnings 'redefine';
local *make_path = sub { dd 'make_path', #_; return 1 };
local *File::Copy::copy = sub { dd 'copy', #_; return 1 };
to_be_mocked();
}
run_with_mock();
__END__
# Output:
("make_path", "/tmp/foo")
("copy", "file.xml", "/tmp/foo")
Note that -d apparently can't be mocked, at least not directly.
Related
I am new to Vtiger CRM. I want to write php code in log4php.properties file and also it need to be executed.
I can write the code but it is not executing at all. So kindly help me with a way which will allow to execute the file.
Also this need to be executed dynamic with separate domains.
Thanks
Open your index.php file from crm root directory and Add this code
function replace_string_in_a_file($filepath, $search, $replace) {
if (#file_exists($filepath)) {
$file = file($filepath);
foreach ($file as $index => $string) {
if (strpos($string, $search) !== FALSE)
$file[$index] = "$replace\n";
}
$content = implode($file);
return $content;
}else {
return NULL;
}
}
$filepath = $root_directory . 'log4php.properties';
$search = 'log4php.appender.A1.File=';
$replace = 'log4php.appender.A1.File=' . DOMAIN_PATH . '/logs/vtigercrm.log';
$log_properties_content = replace_string_in_a_file($filepath, $search, $replace);
if (!empty($log_properties_content)) {
file_put_contents($filepath, $log_properties_content);
}
So have a function that does something like this:
function mymod_init()
{
$ip = '123.123.123.123';
$newPath = mymod_redirect_calculate($ip);
if (!empty($newPath)) drupal_goto($newPath);
}
This completely breaks unit testing. I have tests for the "mymod_redirect_calculate", but if I add the above to my init function as shown, the tests can't run.
From what I have gathered "exit" and "drupal_goto" breaks unit testing.
How do I get around this?
Actually drupal_goto() ends up calling exit(). Using header() should work :
function mymod_init() {
$ip = '123.123.123.123';
$newPath = mymod_redirect_calculate($ip);
if (!empty($newPath)) {
$url = url($newPath, array('absolute' => TRUE));
header('Location: ' . $url, TRUE);
}
}
I'm new to threads. I written a script to check the threads module in which i have some modules which do some pattern matching job and returns to two values 1st the input and second match found instance along with its line number. But using the threads it returns nothing.
here is the code
use threads;
sub pattern_finder($){
my $filebuf = shift;
my #threads;
my $pattern_found;
my $thr1 = threads->create(\&sub_pattern1,$filebuf);
push(#threads, $thr1);
my $thr2 = threads->create(\&sub_pattern2,$filebuf);
push(#threads, $thr2);
my $thr3 = threads->create(\&sub_pattern3,$filebuf);
push(#threads, $thr3);
for my $t(#threads){
($filebuf, $tmp)= $t->join();
$pattern_found .= $tmp;
}
return $filebuf, $pattern_found;
}
sub sub_pattern1($)
{
my ($filebuf) = shift;
my $found;
while($filebuf =~ /<LINE(\d+)>Pattern1/gsi)
{
$found .= "Pattern1 found at line $1\n";
}
return $filebuf, $found;
}
sub sub_pattern2($)
{
my ($filebuf) = shift;
my $found;
while($filebuf =~ /<LINE(\d+)>Pattern2/gsi)
{
$found .= "Pattern2 found at line $1\n";
}
return $filebuf, $found;
}
sub sub_pattern3($)
{
my ($filebuf) = shift;
my $found;
while($filebuf =~ /<LINE(\d+)>Pattern3/gsi)
{
$found .= "Pattern3 found at line $1\n";
}
$found = "$pre_checks"."$found";
return $filebuf, $found;
}
Can anyone suggest me what is wrong in the code?
Ah yes, a common problem: The code reference you pass to threads->create is called in the context that the create method was called. Here, this is scalar context. Thus return $filebuf, $found is equivalent to return $found.
As you use that single element in list context when joining the thread, you do something equivalent to $filebuf = $t->join, $tmp = undef which is not what you're expecting.
This can be fixed in two ways:
create the thread in list context:
my ($thr1) = threads->create(...)
explicitly specify the context:
my $thr1 = threads->create({context => 'list'}, \&sub_pattern1, $filebuf);
See also the section on context in the threads documentation.
Note also that there is no reason to return $filebuf at all as you don't really use that value – you just return the $filebuf of the last thread which was joined.
Tip: If you're using multithreading for performance, you should benchmark your code both with and without threads – in your case the non-threaded (sequential) solution is likely to perform better.
Supposed I have a file with Perl-code: does somebody know, if there is a module which could find the closing "}" of a certain subroutine in that file.
For example:
#!/usr/bin/env perl
use warnings;
use 5.012;
routine_one( '{°^°}' );
routine_two();
sub routine_one {
my $arg = shift;
if ( $arg =~ /}\z/ ) {
say "Hello my }";
}
}
sub routine_two {
say '...' for 0 .. 10
}
The module should be able to remove the whole routine_one or it should can tell me the line-number of the closing "}" from that routine.
You want to use PPI if you are going to be parsing Perl code.
#!/usr/bin/env perl
use warnings;
use 5.012;
use PPI;
my $file = 'Example.pm';
my $doc = PPI::Document->new( $file );
$doc->prune( 'PPI::Token::Pod' );
$doc->prune( 'PPI::Token::Comment' );
my $subs = $doc->find( sub { $_[1]->isa('PPI::Statement::Sub') and $_[1]->name eq 'layout' } );
die if #$subs != 1;
my $new = PPI::Document->new( \qq(sub layout {\n say "my new layout_code";\n}) );
my $subs_new = $new->find( sub { $_[1]->isa('PPI::Statement::Sub') and $_[1]->name eq 'layout' } );
$subs->[0]->block->insert_before( $subs_new->[0]->block ) or die $!;
$subs->[0]->block->remove or die $!;
# $subs->[0]->replace( $subs_new->[0] );
# The ->replace method has not yet been implemented at /usr/local/lib/perl5/site_perl/5.12.2/PPI/Element.pm line 743.
$doc->save( $file ) or die $!;
The following will work in case your subroutines don't contain any blank lines, like the one in your example:
#!/usr/bin/perl -w
use strict;
$^I = ".bkp"; # to create a backup file
{
local $/ = ""; # one paragraph constitutes one record
while (<>) {
unless (/^sub routine_one \{.+\}\s+$/s) { # 's' => '.' will also match "\n"
print;
}
}
}
Advance New Year Wishes to All.
I have an error log file with the contents in a pattern parameter, result and stderr (stderr can be in multiple lines).
$cat error_log
<parameter>:test_tot_count
<result>:1
<stderr>:Expected "test_tot_count=2" and the actual value is 3
test_tot_count = 3
<parameter>:test_one_count
<result>:0
<stderr>:Expected "test_one_count=2" and the actual value is 0
test_one_count = 0
<parameter>:test_two_count
<result>:4
<stderr>:Expected "test_two_count=2" and the actual value is 4
test_two_count = 4
...
I need to write a function in Perl to store each parameters, result and stderr in an array or hash table.
This is our own internally defined structure. I wrote the Perl function like this. Is there a better way of doing this using regular expression itself?
my $err_msg = "";
while (<ERR_LOG>)
{
if (/<parameter>:/)
{
s/<parameter>://;
push #parameter, $_;
}
elsif (/<result>:/)
{
s/<result>://;
push #result, $_;
}
elsif (/<stderr>:/)
{
if (length($err_msg) > 0)
{
push #stderr, $err_msg;
}
s/<stderr>://;
$err_msg = $_;
}
else
{
$err_msg .= $_;
}
}
if (length($err_msg) > 0)
{
push #stderr, $err_msg;
}
If you're using Perl 5.10, you can do something very similar to what you have now but with a much nicer layout by using the given/when structure:
use 5.010;
while (<ERR_LOG>) {
chomp;
given ($_) {
when ( m{^<parameter>: (.*)}x ) { push #parameter, $1 }
when ( m{^<result>: (.*)}x ) { push #result, $1 }
when ( m{^<stderr>: (.*)}x ) { push #stderr, $1 }
default { $stderr[-1] .= "\n$_" }
}
}
It's worth noting that for the default case here, rather than keeping a separate $err_msg variable, I'm simply pushing onto #stderr when I see a stderr tag, and appending to the last item of the #stderr array if I see a continuation line. I'm adding a newline when I see continuation lines, since I assume you want them preserved.
Despite the above code looking quite elegant, I'm not really all that fond of keeping three separate arrays, since it will presumably cause you headaches if things get out of sync, and because if you want to add more fields in the future you'll end up with lots and lots of variables floating around that you'll need to keep track of. I'd suggest storing each record inside a hash, and then keeping an array of records:
use 5.010;
my #records;
my $prev_key;
while (<ERR_LOG>) {
chomp;
given ($_) {
when ( m{^<parameter> }x ) { push(#records, {}); continue; }
when ( m{^<(\w+)>: (.*)}x ) { $records[-1]{$1} = $2; $prev_key = $1; }
default { $records[-1]{$prev_key} .= "\n$_"; }
}
}
Here we're pushing a new record onto the array when we see a field, adding an entry to our hash whenever we see a key/value pair, and appending to the last field we added to if we see a continuation line. The end result of #records looks like this:
(
{
parameter => 'test_one_count',
result => 0,
stderr => qq{Expected "test_one_count=2" and the actual value is 0\ntest_one_count=0},
},
{
parameter => 'test_two_count',
result => 4,
stderr => qq{Expected "test_two_count=2" and the actual value is 4\ntest_two_count=4},
}
)
Now you can pass just a single data structure around which contains all of your records, and you can add more fields in the future (even multi-line ones) and they'll be correctly handled.
If you're not using Perl 5.10, then this may be a good excuse to upgrade. If not, you can translate the given/when structures into more traditional if/elsif/else structures, but they lose much of their beauty in the conversion.
Paul
The main thing that jumps out for refactoring is the repetition in the matching, stripping, and storing. Something like this (untested) code is more concise:
my( $err_msg , %data );
while (<ERR_LOG>) {
if(( my $key ) = $_ =~ s/^<(parameter|result|stderr)>:// ) {
if( $key eq 'stderr' ) {
push #{ $data{$key} } , $err_msg if $err_msg;
$err_msg = $_;
}
else { push #{ $data{$key} } , $_ }
}
else { $err_msg .= $_ }
}
# grab the last err_msg out of the hopper
push #{ $data{stderr} } , $err_msg;
... but it may be harder to understand six months from now... 8^)
Looks nice. =) An improvement is probably to anchor those tags at the beginning of the line:
if (/^<parameter>:/)
It'll make the script a bit more robust.
You can also avoid the stripping of the tag if you catch what's after it and use only that part:
if (/^<parameter>:(.*)/s)
{
push #parameter, $1;
}