my $sock_Zona = IO::Socket::INET->new(
    PeerAddr => $par{addr_Zona},
    PeerPort => $par{port_Zona},
    Proto => "tcp",
    Type => SOCK_STREAM,
    Timeout => $par{conn_tmo}
);
[download]

unless (defined $sock_Zona) {
    $abort++;
    $sock_Zona = -1;
    ABORT("Zona se ne javlja: $!");
} else {
    IO::Socket::Timeout->enable_timeouts_on($sock_Zona);
    $sock_Zona->read_timeout($par{read_tmo_Zona});    
}
[download]

I use the following code with Gtk2 to download an image with LWP and then display the image after converting from data in memory. I can do it with Gtk3 by saving file to hard rdrive but I wish to do it from memory as I did with Gtk2. Any ideas please?

  
my $pdata = $ua->get($ur_to_image);
my $pixbufloader = Gtk2::Gdk::PixbufLoader->new;
my $raw_data = $pdata->decoded_content;
$pixbufloader->write($raw_data);
$pixbufloader->close;        
$pixbuf = $pixbufloader->get_pixbuf;
my $w = $pixbuf->get_width;
my $h = $pixbuf->get_height;
$w = int($w *1.2);
$h = int($h * 1.2);
my $scaled = $pixbuf->scale_simple($w, $h, 'GDK_INTERP_BILINEAR');
$im->set_from_pixbuf ($pixbuf);
[download]

Suppose I'm not targeting latest Perl versions and their 'trim' built-in, and reluctant to depend on other modules, -- then practically every FAQ or cookbook or tutorial recommend what's "usual" method in test below. Now, I have fair amount of medium-size "records" (variable length and containing white-space somewhere in the middle, NOT as in test below), which may terminate in unpredictable WS sequences, which I want to trim. Performance freak, I've been unsatisfied with the speed and came with "better" version. Then accidentally discovered "unpack" method. Now I'm puzzled if this nice and fast way is kept secret and why :-)

use strict;
use warnings;
use 5.014;                  # s///r
use Benchmark 'cmpthese';

my @a = map { 
    ( 'a' x 123 ) . 
    ( ' ' x rand 2 ) .
    ( "\n" x rand 2 )
} 0 .. 999;

cmpthese -1, {
    usual  => sub { my @ret = map { s/\s*$//r } @a; \@ret },
    better => sub { my @ret = map { s/.*\S\K\s*$//sr } @a; \@ret },
    unpack => sub { my @ret = map { unpack 'A*', $_ } @a; \@ret },
};

__END__

         Rate  usual better unpack
usual   159/s     --   -88%   -95%
better 1284/s   707%     --   -56%
unpack 2899/s  1722%   126%     --
[download]

Trying to work out why this isn't returning all the rows of data from the mock. Have I messed up the session instantiation?

use v5.36;
use DBI;
use DBD::Mock;
use Data::Dumper;

my $session = DBD::Mock::Session->new('testing' => (
    {
        statement => 'SELECT * FROM bar',
        results   => [ 
          ['one', 'two'], 
          ['three', 'four'] 
        ], 
    }
));

my $dbh = DBI->connect('dbi:Mock:', '', '') or die $DBI::errstr;
$dbh->{mock_session} = $session;

my $data = $dbh->selectall_arrayref("SELECT * FROM bar");
say Dumper({ DATA => $data });
[download]

Output:

$VAR1 = {
          'DATA' => [
                      [
                        'three',
                        'four'
                      ]
                    ]
        };
[download]

open(FH, "/Users/anaordonez/Documents/my_languages.txt")or die "Sorry!
+! couldn't open"; 
print "Reading file \n"; 
  
# Reading the file till FH reaches EOF 
while(<>) 
{ 
    # Printing one line at a time 
    next unless $_ = "Java";
    print $_; 
} 
close;
[download]

if ($path[0] eq 'cms' && ($path[1] eq 'auth' || $path[1] eq 'upload'))
+ {
    $Response->{Status} = 403;
    $Response->End();
    return;
}
[download]

Only if I use $Server->Transfer( "index.asp" ) instead of $Response->End(); only then I get the 403 status but then I get the following error in the logs.

error executing code for include /opt/apache/htdocs/..../index.asp: no
+ include
[download]

But why when there is an error then the status does change to 403, and when I just use $Reponse->End() or just return, it doesn't work?

While writing a perl script, I wanted to flush a handle, and wrote

flush $gp;

like the C coder I am. The code worked. Then while cleaning up the syntax for consistency, I added parens, i.e. flush($gp), but this did not work. Turns out flush is not a function (it's not in perlfunc). So why did my first attempt work?

I have a little exercise which might sound like homework, but I promise you it isn't! Lol And I almost got it to work, but I can't figure out how to make the last function do what it's supposed to. Update: *Got it!

So, I wanted to write four functions--one that doubles certain characters in a string and another sub that removes double characters from a string. I think I want to clarify that what I want is not this:

$S =~ tr| ||s;

I know, this would collapse multiple spaces to a single space, but that's not what I want to do. I want to do this: "AAAAAA" => "AAA" just replace each pair with a single character. OK. So, I already figured out how to do this.

But then I want to write another sub that repeats certain characters N number of times and finally a last one that finds N number of occurrences of certain characters in a string and replaces each group of characters with one character.
Find groups of 3 letter A's and replace them: "AAAAAA" => "AA"

I'm having trouble with this last sub. It just doesn't want to do what I want. Can someone please help me show me how to do this? It's called SingleCharsX()

#!/usr/bin/perl

use strict;
use warnings;

# This should print: "AABBC"
print "\n", DoubleChars("ABC", "AB");

# This should print: "LALA LLAALLAAN N"
print "\n", SingleChars("LALA LLLAAALLLLAAAAN NN", "LANG"), "\n\n";

# Okay. Now, make it more complicated...

foreach (2..7)
{
  print "\n x $_ : |",
    DoubleCharsX("ABCD", "ABXY", $_), "|";
}
print "\n\n";

foreach (2..7)
{
  print "\n x $_ : |",
    SingleCharsX("LLLLLLLL-AAAAAAAA", "ABX", $_), "|";
}

exit;

############################################
##                FUNCTIONS               ##
############################################

# This function doubles every instance of a list of characters in
# a string and returns a new string. For example, it can be used
# to double every instance of space or new line characters.
#
#    DoubleChars("Helo World!", "!lo ")  =>  "Helloo  Woorlld!!"
#    DoubleChars("Helo World!", "HHH")   =>  "HHelo World!"
#
# Usage: STRING = DoubleChars(STRING, CHARS)
#
sub DoubleChars
{
  defined $_[0] && length($_[0]) or return '';
  defined $_[1] && length($_[1]) or return $_[0];
  my $S = $_[0];
  $S =~ s/([\Q$_[1]\E]{1})/$1$1/g;
  return $S;
}

############################################
#
# This function removes certain characters that appear twice next
# to each and leaves only one instance. This can be used to undo
# the effects of the DoubleChars() function.
#
#    SingleChars(" HEELLLLLLO OO!", "OL")  =>  " HEELLLO O!"
#    SingleChars("AABBCAABBC", "AB")       =>  "ABC"
#
# Usage: STRING = DoubleChars(STRING, CHARS)
#
sub SingleChars
{
  defined $_[0] && length($_[0]) or return '';
  defined $_[1] && length($_[1]) or return $_[0];
  my $S = $_[0];
  $S =~ s/([\Q$_[1]\E]{1})\1/$1/g;
  return $S;
}

############################################

# This function doubles or triples every instance of
# a list of characters in a string and returns a new string.
# For example, it can be used to repeat every instance of
# the exclamation point. The second argument tells what
# to repeat, and the third argument tells how many times
# to repeat those characters.
#
#    DoubleCharsX("Hello World!", "!", 3)  =>  "Hello World!!!"
#
# Usage: STRING = DoubleCharsX(STRING, CHARS, [REP])
#
sub DoubleCharsX
{
  defined $_[0] && length($_[0]) or return '';
  defined $_[1] && length($_[1]) or return $_[0];
  my $REP = defined $_[2] ? int($_[2]) : 2;
  $REP >= 2 or $REP = 2;
  my $S = $_[0];
  $S =~ s/([\Q$_[1]\E]{1})/$1 x $REP/ge;
  return $S;
}

# This function doubles or triples every instance of
# a list of characters in a string and returns a new string.
# For example, it can be used to repeat every instance of
# the exclamation point. The second argument tells what
# to repeat, and the third argument tells how many times
# to repeat those characters.
#
#   SingleCharsX("Pressss a keeeeyyy!", "ey", 3) => "Pressss a keey!"
#
# Usage: STRING = SingleCharsX(STRING, CHARS, [REP])
#
sub SingleCharsX
{
  defined $_[0] && length($_[0]) or return '';
  defined $_[1] && length($_[1]) or return $_[0];
  my $REP = defined $_[2] ? int($_[2]) : 2;
  $REP >= 2 or $REP = 2;
  my $S = $_[0];
  foreach my $CHAR (split(//, $_[1]))
  {
    $S =~ s/\Q$CHAR\E{$REP}/\Q$CHAR\E/g;
  }
  return $S;
}
[download]

Update: Also, I am not sure how one should call these subs. I mean DoubleCharsX is not a very creative name. Maybe RepChars() would be better? But then how would I call SingleCharsX() ? The other thing is I don't even know what kind of title to give this thread. I'm not very good at naming these things. :P

Update: I think, everything works fine, it's not that the program doesn't do what it's supposed to, but I was expecting a different output. And since the output didn't match what I imagined it should be, I thought it was an error. I thought it should print something like this:

AABBC
LALA LLAALLAAN N


 x 2 : |AABBCD|
 x 3 : |AAABBBCD|
 x 4 : |AAAABBBBCD|
 x 5 : |AAAAABBBBBCD|
 x 6 : |AAAAAABBBBBBCD|
 x 7 : |AAAAAAABBBBBBBCD|


 x 2 : |LLLLLLLL-AAAAAA|
 x 3 : |LLLLLLLL-AAAAA|
 x 4 : |LLLLLLLL-AAAA|
 x 5 : |LLLLLLLL-AAA|
 x 6 : |LLLLLLLL-AA|
 x 7 : |LLLLLLLL-A|


AND INSTEAD IT WAS PRINTING THIS:


AABBC
LALA LLAALLAAN N


 x 2 : |AABBCD|
 x 3 : |AAABBBCD|
 x 4 : |AAAABBBBCD|
 x 5 : |AAAAABBBBBCD|
 x 6 : |AAAAAABBBBBBCD|
 x 7 : |AAAAAAABBBBBBBCD|


 x 2 : |LLLLLLLL-AAAA|
 x 3 : |LLLLLLLL-AAAA|
 x 4 : |LLLLLLLL-AA|
 x 5 : |LLLLLLLL-AAAA|
 x 6 : |LLLLLLLL-AAA|
 x 7 : |LLLLLLLL-AA|
[download]