I need an efficient way to process a sequence of transforms. For example, here are some individual transforms as code references:

# some code references
$f1 = sub {map {$_ + 1} @_};
$f2 = sub {map {log($_)} @_};
$f3 = sub {map {$_ * 3} @_};
[download]

They may be combined into a sequence

 # combined transform
sub trans1 {&$f3(&$f2(&$f1))};

# some data
@data = (1, 2, 3);

# call the transform
@trans = trans1(@data);

print "@trans\n";
[download]

The sequence could have fewer or more steps, so I would like to make an array of code references:

# make a sequence array
@seq = ($f1, $f2, $f3);

# combined transform
sub trans2 {
    
    # for each code reference
    for (@seq) {
        
        # transform data
        @_ = &$_;
        
    }
    
    # return
    return(@_);
    
}

# call the transform
@trans = trans2(@data);
[download]

This works okay, but I wonder if there is a better and faster way.

I'm trying to make a Queue Manager that get jobs when files are created in a specific folder. I've created my code using AnyEvent so it's async.

My problem is, i'm trying to deliver a return value from the subroutines add_route, and del_route, using callbacks, but the AE::timer won't stop, and the value that the callback gets, won't saved in the variable $return_code. Where have I gone wrong?

#!/usr/bin/perl
use strict;
use warnings;

use AnyEvent;
use AnyEvent::Filesys::Notify;
use Const::Fast;
use DDP;
use File::Basename;
use File::Copy;
use File::Slurp;
use FindBin '$Bin';
use List::Util qw(first);
use Regexp::Common qw(net);
use v5.10.1;

const my $true  => 1;
const my $false => 0;

my $cv = AE::cv;
my $jobs_folder_path    = $Bin . '/jobs';
my $interval = 5;
my $after    = 10;

my %jobs_folders        = (
    "new"       => "$jobs_folder_path/new",
    "progress"  => "$jobs_folder_path/progress",
    "failed"    => "$jobs_folder_path/failed",
);

my $notifier = AnyEvent::Filesys::Notify->new(
    dirs        => [ $jobs_folders{'new'} ],
    interval    => $interval,
    cb          => sub {
        my (@events) = @_;

        for my $event (@events) {
            if ($event->is_created) {
                process_new_job($event->path);
            }
        }
    }
);

my $timer = AE::timer $after, $interval, sub {
    my @files = read_dir($jobs_folders{'progress'}, prefix => $true);

    if (@files) {
        foreach my $file (@files) {
            my $file_name   = basename($file);
            my $line        = read_file($file);

            for ($file_name) {
                when (/add/) {
                    my ($ip_address, $next_hop) = split(/ /, $line);
                    my $return_code;
                    my $cb = sub {
                        my $ret_val =  shift;

                        $return_code = $ret_val;
                    };

                    add_route($ip_address, $next_hop, $cb);

                    print $return_code;
                    #post_job_process($return_code, $file_name);
                }
                when (/del/) {
                    my ($ip_address) = $line;
                    my $return_code;
                    my $cb = sub {
                        my $ret_val =  shift;

                        $return_code = $ret_val;
                    };

                    del_route($ip_address, $cb);

                    print $return_code, "\n";

                    #post_job_process($return_code, $file_name);
                }
            }
        }
    }
};

$cv->recv;

sub process_new_job {
    my ($new_job) = shift;

    my $file_name = basename($new_job);
    move("$jobs_folders{'new'}/$file_name", "$jobs_folders{'progress'}
+/$file_name");
}

sub post_job_process {
    my ($return_code, $file_name) = @_;

    if ($return_code == $false) {
        move("$jobs_folders{'progress'}/$file_name", "$jobs_folders{'f
+ailed'}/$file_name");
        send_email();
    }

}

sub send_email {
    print "Sending Email...\n";
}

sub add_route {
    my ($ip_address, $next_hop, $cb) = @_;

    my $attempt = 0;
    my $sleep   = 10;

    my $add_timer; $add_timer = AE::timer 0, $sleep, sub {

        if ($attempt++ >= 3) {
            undef $add_timer;
            $cb->($false);
        }

        print "$attempt. Adding Route $ip_address via $next_hop\n";

        my @addresses = get_routing_table();

        my ($comparable_ip) = $ip_address =~ /($RE{net}{IPv4})\/32$/;
        my $is_in_routing_table = first { $_->{'ip_address'} eq $compa
+rable_ip } @addresses;

        if ($is_in_routing_table) {
            undef $add_timer;
            $cb->($true);
        }
    };
}

sub del_route {
    my ($ip_address, $cb) = @_;

    my $attempt = 0;
    my $sleep   = 10;

    my $delete_timer; $delete_timer = AE::timer 0, $sleep, sub {

        if ($attempt++ >= 3) {
            undef $delete_timer;
            $cb->($false);
        }

        print "$attempt. Deleting Route $ip_address\n";

        my @addresses = get_routing_table();

        my ($comparable_ip) = $ip_address =~ /^($RE{net}{IPv4})\/32/;
        my $is_in_routing_table = first { $_->{'ip_address'} eq $compa
+rable_ip } @addresses;

        if (not $is_in_routing_table) {
            undef $delete_timer;
            $cb->($true);
        }
    };
}

sub get_routing_table {
    #my @routing_table = `ip ro`;
    my @routing_table = (
      '127.0.0.0/8 dev lo  proto kernel  scope link  src 127.0.0.1',
      '127.0.0.11 via 10.0.0.11 dev eth0  proto baba',
    );
    my @ret_val;

    foreach my $line (@routing_table) {
        my ($ip_address, $next_hop) = $line =~ /^($RE{net}{IPv4}) via 
+($RE{net}{IPv4}) .*proto baba$/;
        if (defined ($ip_address) and defined ($next_hop)) {
            push @ret_val, { ip_address => $ip_address, next_hop => $n
+ext_hop };
        }
    }

    return @ret_val;
}
[download]

I passing the data from html page(contactus.html) to cgi page.Every time I passing Other language string as input.Showing wrong length.

use HTML::Entities;
use CGI;
my $cgi=new CGI;
my $message=$cgi->param('message');

$message=decode_entities($message);

my $message_fld_length=length($message);

print "$message_fld_length";

[download]

The same code working... I passing the data from cgi page(contactus.cgi) to cgi page.I passing other language data as input.Here length working good. Can u please give a suggestion.Why input coming from html page na not working decode_entites.

Hi,I am very new to PERL.I have been confusing so far regarding directories.I mean,suppose if I run the below code

 #!/usr/bin/perl
use warnings;
use strict;

opendir DH, "." or die "couldn't ope $!";

while ($_ = readdir(DH)) {
    next if $_ eq "." or $_ eq ".." ;
    print $_, " " x (30 - length($_));
    print "d" if -d $_;
    print "r" if -r _;
    print "w" if -w _;
    print "x" if -x _;
    print "o" if -o _;
    print "\t";
    print -s _ if -r _ and -f _;
    print "\n";
}
 
[download]

I am getting proper output as file-names ,permission and their sizes. But whenever I had change "opendir" as

I have been getting only file-names,neither permissions nor file-size. Any-one can help me regarding this.Thanks in Advance

I didn't understand why the results would be different when printing out $string1 and $string2 in below script. I thought the 'tr' operator would work the same way on both strings. Please help! The result from printing $string1: "b b b." The result from printing $string2: " ."

#!/usr/bin/perl 

$string1 = 'the cat sat on the mat.';
$string1 =~ tr/a-z/b/d;
print "$string1\n";

$string2 = 'the cit sit on the mit.';
$string2 =~ tr/a-z/b/d;
print "$string2\n";
[download]

[Tue Jun 18 22:07:59 2013] [warn] [client 98.210.237.116] mod_fcgid: s
+tderr: [error] Caught exception in engine "Can't locate object method
+ "has_io_fh" via package "Moose::Meta::
[Tue Jun 18 22:07:59 2013] [warn] [client 98.210.237.116] mod_fcgid: s
+tderr: Class::__ANON__::SERIAL::20" at /home4/stayputs/perl5/lib/perl
+5/Catalyst.pm line 1799."
[download]

I am working on a script which the user calls a route called /add_news but that route should be able to call itself with a query parameter. This is the smallest amount of code I can come up with to do what I want but it fails every time. The Mojolicious documentation is not clear enough for me to understand what I need to do.

#!/usr/bin/perl

use Mojolicious::Lite;

get '/add_news' => sub {
    
    my $self = shift;
    my $offset = $self->param('offset') // 0;
        
    if ( $offset > 9 ) {
        $self->render(text => "offset = $offset\n");
    } else {
        $self->redirect_to('/add_news?offset=10');
    }    
};

app->start;
[download]

When the code runs with and the offset is greater than 10 I see the rendered text but once I use an offset less than 10 I get a 302 error. I understand it is redirecting but when I look at the output the URL looks correct.

[Tue Jun 18 23:24:49 2013] [info] Listening at "http://*:3000".
Server available at http://127.0.0.1:3000.
[Tue Jun 18 23:24:57 2013] [debug] Your secret passphrase needs to be 
+changed!!!
[Tue Jun 18 23:24:57 2013] [debug] GET /add_news (Mozilla/5.0 (X11; Li
+nux x86_64; rv:24.0) Gecko/20130618 Firefox/24.0).
[Tue Jun 18 23:24:57 2013] [debug] Routing to a callback.
[Tue Jun 18 23:24:57 2013] [debug] 200 OK (0.000952s, 1050.420/s).
[Tue Jun 18 23:25:00 2013] [debug] GET /add_news (Mozilla/5.0 (X11; Li
+nux x86_64; rv:24.0) Gecko/20130618 Firefox/24.0).
[Tue Jun 18 23:25:00 2013] [debug] Routing to a callback.
[Tue Jun 18 23:25:00 2013] [debug] 302 Found (0.000915s, 1092.896/s).
[Tue Jun 18 23:25:00 2013] [debug] GET /add_news (Mozilla/5.0 (X11; Li
+nux x86_64; rv:24.0) Gecko/20130618 Firefox/24.0).
[Tue Jun 18 23:25:00 2013] [debug] Routing to a callback.
[Tue Jun 18 23:25:00 2013] [debug] 200 OK (0.000518s, 1930.502/s).
[download]

I am using the following curl commands.

curl http://127.0.0.1:3000/add_news?offset=10
and
curl http://127.0.0.1:3000/add_news?offset=2
[download]

How can I make the route call itself?

I keep getting "readline() on unopened filehandle DATA at (eval 1) line 5." when evaling a script with a __DATA__ section. Would you have any pointers to fix?

Thanks!

#!/usr/bin/perl
use strict;
use warnings;

open(F, "test.pl");
my $f = do { local $/; <F> };
close(F);
eval ($f);


Test.pl:


#!/usr/bin/perl
use strict;
use warnings;

while (<DATA>)
{   
   chomp;
   print "TEST: *$_*\n";
}   

close DATA;


__DATA__
TEST 1 2 3

[download]

I am needed to edit a large, 500+ megabyte file in Perl, to remove one line near the beginning of the file, and one near the end. I need to do this for many many files, so performance and speed are a slight issue; reading every file and editing/reprinting them out could take days.

How can I find two lines of the file, remove them, without reading the entire file and taking a huge amount of time?

I am attempting to collect information based upon prompts generated within the script. Using perl-5.16.3 on MacOSX this code works perfectly. If I attempt to use it on a windows machine with Activeperl or Strawberry perl (both also 5.16.3) installed it never returns after entering the string and hitting the enter key.

Any assistance or alternative would be appreciated. Please keep in mind that in the original script I am asking for a password at one of th prompts so proper obfuscation needs to be available.

Here is the code I am using for the prompt in one of the entries. It must not be a empty string, when I enter something at the prompt it doesn't even print out the value or an error or anything.

use 5.14.0;
use strict;
use warnings;
use IO::Prompter [-v];

my $string="";
do {
    $string = prompt("Input a string:");
    print "$string\n";
} until ($string ne "");
[download]