Hello monks

I am playing with Text::Fuzzy in order to match and replace strings in a text file with a fuzzy logic (I need to take account in my matching of inflected words, such as sing/plural, etc.). The function that seems most promising is:

my ($offset, $edits, $distance) = fuzzy_index ($needle, $haystack);
[download]

Once I have the offset of a fuzzy much I can apply:

my $needleLenght=length ($needle);
substr($haystack, $offset, $needleLenght) = "my new value";
[download]

However, the module's documentation states that the value returned is the offset of the closest match found. However, I need to find ALL offsets of my $needle in $haystack. Do you know any module that achive this? Or any trick to have it with this module?

use Data::Dumper;
use DateTime::Format::Strptime;
use POSIX qw(strftime);
use MongoDB;
use Data::Structure::Util qw( unbless );
use strict;
use warnings;

my $mongoclient = MongoDB::MongoClient->new(
    host => '127.0.0.1', port => 27017
    );

my $db = $mongoclient->get_database('database');

my $collect = $db->get_collection('collection')->aggregate([
    {'$group' => {
        '_id' => {_path => '$path' , _ip => '$IP', _time => '$TIME'},
        '_count' => { '$sum' => 1},
        '_docs' => { '$push' => '$_id' }
     }    
    },
    { '$match' => {
        '_count' => { '$gt' => 1}
    }}
]);
my $mongo_aggregate = unbless $collect;
my @out = (@$mongo_aggregate);
print Dumper @out;
[download]

use Data::Dumper;
use DateTime::Format::Strptime;
use POSIX qw(strftime);
use MongoDB;
use Data::Structure::Util qw( unbless );
use strict;
use warnings;

my $mongoclient = MongoDB::MongoClient->new(
    host => '127.0.0.1', port => 27017
    );

my $db = $mongoclient->get_database('database');

my $collect = $db->get_collection('collection')->aggregate([
    {'$group' => {
        '_id' => {_path => '$path' , _ip => '$IP', _time => '$TIME'},
        '_count' => { '$sum' => 1},
        '_docs' => { '$push' => '$_id' }
     }    
    },
    { '$match' => {
        '_count' => { '$gt' => 1}
    }}
]);
my $mongo_aggregate = unbless $collect->{'_docs'};
my @out = (@$mongo_aggregate);
print Dumper @out;
[download]

So, I had a user of my Mock::Sub distribution file an issue report where trying to mock a subroutine that has prototypes threw a warning. After monkeying about with it, I was able to quell said warnings, but it raised something else that I don't understand. I'll post some code and context, then get to what I'm hoping to have answered.

This is a runnable example based on the snippet that the user reported:

use warnings;
use strict;

use Mock::Sub;

my $m = Mock::Sub->new;

sub foo ($$$){
    return undef;
}

my $foo_sub = $m->mock('foo');
[download]

Result:

Prototype mismatch: sub main::foo ($$$) vs none at /home/stevieb/perl5
+/perlbrew/perls/perl-5.26.1/lib/site_perl/5.26.1/Mock/Sub/Child.pm li
+ne 122.
Prototype mismatch: sub main::foo: none vs ($$$) at /home/stevieb/perl
+5/perlbrew/perls/perl-5.26.1/lib/site_perl/5.26.1/Mock/Sub/Child.pm l
+ine 140.
[download]

All well and good. As a response to the user, I drummed up a test script with a signal handler to catch Prototype warnings, and just evaporate them (I'll incorporate this into the distribution directly if the reporter is satisfied, enabled only if requested explicitly):

use warnings;
use strict;
use feature 'say';

use Mock::Sub;

$SIG{__WARN__} = sub {say $_[0] if $_[0] !~ /Prototype/};

my $m = Mock::Sub->new;

sub foo ($$$){
    say "hello!"; # doesn't get called
    return undef;
}

my $foo = $m->mock('foo');
$foo->return_value('test');

say foo(1, 2, 3);
say foo(1, 2, 3);
say foo(1, 2, 3);

say $foo->called_count;
[download]

That code does the right thing, insofar that the mocked sub is properly called and the prototype warnings are no longer displayed:

test
test
test
3
[download]

Now, what I found while testing, is that initially, I called foo() with no parameters, but the prototype stuck, resulting in fatality. Instead of foo(1, 2, 3); (proper number of params), I had just foo(), and...

Not enough arguments for main::foo at mock.pl line 21, near "()"
Execution of mock.pl aborted due to compilation errors.
[download]

All I do when I mock out a sub, is overwrite the symbol table for it (actual code from the module):

    {
        no strict 'refs';
        no warnings 'redefine';
 
        my $mock = $self;
        weaken $mock;
 
        *$sub = sub {
 
            @{ $mock->{called_with} } = @_;
            ++$mock->{called_count};
 
            if ($mock->{side_effect}) {
                if (wantarray){
                    my @effect = $mock->{side_effect}->(@_);
                    return @effect if @effect;
                }
                else {
                    my $effect = $mock->{side_effect}->(@_);
                    return $effect if defined $effect;
                }
            }
 
            return if ! defined $mock->{return};
 
            if ($mock->{return}[0] && $mock->{return}[0] eq 'params'){
                return ! wantarray ? $_[0] : @_;
            }
            else {
                return ! wantarray && @{ $mock->{return} } == 1
                    ? $mock->{return}[0]
                    : @{ $mock->{return} };
            }
        };
    }
[download]

My question here, is if the symtab entry was overwritten correctly (ie. the mocked sub is most definitely called as desired), why does perl still think that it requires the prototyped parameters? Clearly, that information is stored somewhere, but where and how?

Can someone point me in a direction I can look down to understand this, or even explain it to me?

Thanks, as always,

-stevieb

Fellow monks,

I can't install Win32::OLE 0.1712 on my cygwin64. I already changed stricmp into strcasecmp by means of look Win32::OLE, but make Win32::OLE now gives me an unexpected error:

OLE.xs:925:17: fout: formaat is geen stringconstante en er zijn geen f
+ormaat-argumenten [-Werror=format-security]
   warn(SvPVX(sv));
[download]

As my cygwin64 is in dutch, it reads: error: format is no string constant and there are no format arguments.

Any ideas on how to proceed? Do I log a bug in cpan for this module or is there a depency on some sort of cygwin library that I am missing?

#!/usr/bin/perl
# SSCCE from examples at "perldoc Memoize"
# Memoize works as expected on recent Perls 5.20-28.
# Builds huge cache and does not work on 5.18.
# Thoughts on why, and how to handle it?

use strict;
use warnings;
use diagnostics;

use Data::Dumper;
use DB_File;
use File::Spec;
use integer;
use Memoize;
use POSIX ();

my $title = 'Compute Fibonacci numbers';
my $tempd = File::Spec->tmpdir;
my $tempf = $] . '_memoize_fib';
my $cache = File::Spec->catfile($tempd,$tempf);

my $ARGS = @ARGV ? shift : 8;

unlink $cache if -e $cache and $ARGS eq 'purge';

my $db = tie my %cache => 'DB_File', $cache, POSIX::O_RDWR|POSIX::O_CR
+EAT, 0666;
memoize 'fib', SCALAR_CACHE => [HASH => \%cache]; 

print "Perl $]
Memoize  $Memoize::VERSION
Tempdir  $tempd
Tempfile $tempf
Filesize ", -s $cache, " bytes
Question $ARGS
Answer ", fib($ARGS), "\n\n",

# Because Data::Dumper panics on multigig dumps with
# panic: sv_setpvn called with negative strlen -8260

eval { Data::Dumper->Dump([\%cache],[('%cache')]) };
unlink $cache if $@;

print "$title\nUsage: $0 n, $0 purge\n";

sub fib {
  my $n = shift;
  return $n if $n < 2;
  fib($n-1) + fib($n-2);
}

[download]

Perl 5.018002
Memoize  1.03
Tempdir  /tmp
Tempfile 5.018002_memoize_fib
Filesize 146800640 bytes
Question 8
Answer 21

$%cache = {
            '0' => undef,
            '1' => undef,
            '2' => undef,
            '3' => undef,
            '4' => undef,
            '5' => undef,
            '6' => undef,
            '7' => undef
          };

Perl 5.020003
Memoize  1.03
Tempdir  /tmp
Tempfile 5.020003_memoize_fib
Filesize 49152 bytes
Question 8
Answer 21

$%cache = {
            '0' => '0',
            '2' => '1',
            '4' => '3',
            '6' => '8',
            '1' => '1',
            '3' => '2',
            '5' => '5',
            '7' => '13'
          };

Perl 5.028000
Memoize  1.03_01
Tempdir  /tmp
Tempfile 5.028000_memoize_fib
Filesize 49152 bytes
Question 8
Answer 21

$%cache = {
            '0' => '0',
            '2' => '1',
            '4' => '3',
            '6' => '8',
            '1' => '1',
            '3' => '2',
            '5' => '5',
            '7' => '13'
          };

my $mech = WWW::Mechanize::Chrome->new();
$mech->get('https://www.google.com/');
[download]

Hi guys,

I'm very frustrated with this code

#!/usr/bin/perl -w

# a simple web crawler

use strict;
use LWP::Simple;

my $url = shift || die 'Please provide an initial url after filename!'
+;
my $max = 10;

my $html = get($url);
my @urls;
while ($url =~ s/(https:\/\/\S+)[">]//) {
        push @urls, $1;
        print @urls;
}

mkdir "web" , 0755;
open (URLMAP, ">", "web/url.map" ) || die ("can't open web\/url.map\n"
+);
my $count = 0;

for (my $i=0; $i<$max; $i++) {
        my $source = $urls[int(rand($#urls+1))];
        getstore($source, 'web/$count.html');
        print URLMAP "$count\n$source\n";
        $count++;
}
close URLMAP;
[download]

I run the script, perl web_crawl.pl https://www.money.co.uk and I get this!

perl web_crawl.pl https://www.google.com
Use of uninitialized value $source in concatenation (.) or string at web_crawl.pl line 27.
Use of uninitialized value $source in concatenation (.) or string at web_crawl.pl line 27.
Use of uninitialized value $source in concatenation (.) or string at web_crawl.pl line 27.
Use of uninitialized value $source in concatenation (.) or string at web_crawl.pl line 27.
Use of uninitialized value $source in concatenation (.) or string at web_crawl.pl line 27.
Use of uninitialized value $source in concatenation (.) or string at web_crawl.pl line 27.
Use of uninitialized value $source in concatenation (.) or string at web_crawl.pl line 27.
Use of uninitialized value $source in concatenation (.) or string at web_crawl.pl line 27.
Use of uninitialized value $source in concatenation (.) or string at web_crawl.pl line 27.
Use of uninitialized value $source in concatenation (.) or string at web_crawl.pl line 27.

I'm trying to eventually get the prices and company names, so for example for this part of the site https://www.money.co.uk/travel-money/japanese-yen-exchange-rate.htm I want to get the prices on offer into an array in order (highest first), maybe keeping a note of the company name so may need a hash or array of hashes.
That's the end goal, but stuck on the first hurdle, which is viewing the sites html in files where i can search the prices, then extract them from the files!!! If you can think of a better way and point me in the right direction on finding the solution, I'm all ears! Thanks in advance!

Please help!

This is greatly simplified - I hope it makes sense. :)

I am trying to loop over rows of an array doing a test. If the test fails, I want to go all the way back to the outer loop, which the documentation suggests will work only with foreach.

#!/usr/bin/perl -w
use strict;

my @x =
    (
    ['aaaaa', 'bbbbb', 'ccccc', 'ddddd',],
    ['eeeee', 'fffff', 'ggggg', 'hhhhh',],
    ['iiiii', 'jjjjj', 'kkkkk', 'lllll',],
    );

for my $i (1 .. 1000)
    {
    for my $a (@x)
        {
        my $ifails = 0;
        for my $j (0 .. (scalar @$a) - 1 )
            {
            <get external data string for pattern matching here, put i
+n $c>
            if ($c =~ /$a->[$j]/) { $ifails++; }
            }
        if ($ifails > 1) { want to go to outer loop here, and not proc
+ess the next (and subsequent) row(s) }
        }
    }
[download]

Is there some way of doing that? Note that in the actual application, I do have more more processing below the inner loop, so a "last" statement at the test doesn't work.

Thank you in advance.

Hi,

I'm trying to replace strings in a text file but cannot get it to work using the following code:

system("sed -i -e 's/The action failed./failed_build/g' $lookuptxtfile
+");
[download]

Any help modifying this code or using a better way to accomplish this would be greatly appreciated.

sub print_query_results {
   my $dbh                = shift;
   my $sql_query          = shift;
   my $sql                = SQL::Beautify->new;
   my ( $sql_id, $min_last_load_time, $buffer_gets, $disk_reads, $exec
+utions, $sorts, $parse_calls, $sql_fulltext );
   my $return_scalar      = qq{
};

   my $sth = $dbh->prepare( $sql_query );
   $sth->execute();
   $sth->bind_columns( undef, \$sql_id, \$min_last_load_time, \$buffer
+_gets, \$disk_reads, \$executions, \$sorts, \$parse_calls, \$sql_full
+text );

   while( $sth->fetch() ) {
format OUTPUT =
@|||||||||||||||@||||||||||||||||||||@|||||||||||||||@|||||||||||||||@
+|||||||||||||||@|||||||||||||||@|||||||||||||||
'SQL_ID',       'min_last_load_time','buffer_gets',  'disk_reads',   '
+executions',   'sorts',        'parse_calls',
$sql_id,        $min_last_load_time, $buffer_gets,   $disk_reads,    $
+executions,    $sorts,         $parse_calls,

@<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$sql->query( $sql_fulltext )

.

open OUTPUT, '>', \$return_scalar;
write OUTPUT;
close OUTPUT;
}

   return $return_scalar;
}
[download]