Just a quick question!

Is there a shorthand way to assign multiple array elements (from the same array) to new variables? Ordinarily I would use:

However it would be nicer if this could be done where the array handle only has to be specified once e.g:

(which does not appear to populate the variables)

#!usr\bin\perl -w
open HUBFILE,"1048_undefined.tsv";
@hub=();
while(my $line = <HUBFILE>){
        if($line=~m/\d \t (\w+) \t \.+/g){
        push(@hub,$1);
            }
            }close HUBFILE;
    open OUT,">hubs.txt";
    print OUT "HUB:$hub[0]\n";
    close OUT; 
[download]

I have this example setup:

Table PROJECT
   id (primary key for the table)
   ...

Table ACCOUNT
   id (primary key for the table)
   project_id (reference to PROJECT.id)
   ...

Table QUOTA
   id (primary key for the table)
   account_id (reference to ACCOUNT.id)
   ...
[download]

Using belongs_to it's easy to setup quick accessors and SQL magic like this:

Quota->belongs_to(account => 'Account');
Account->belongs_to(project => 'Project');
[download]

... which in turn make it easy to get the one project induced by a quota, like this:

my $project_from_quota = $quota->account()->project();
[download]

It's also easy to setup a convenience method, of course:

package Quota;
sub project { return shift->account()->project() }
#...
my $project_from_quota = $quota->project();
[download]

I have the feeling that this is a bit hackish though, as it does not provide hints for SQL optimizations (like being able to easily prefetch the project when fetching the quota).

Is there any quick way to add that project accessor that also eases the SQL generator life, e.g. for prefetching stuff? Or should I rely upon the convenience method written above, and then put a bit more effort for using prefetch correctly?

I was thinking about has_one but that seems to be confined to direct relationships between two tables, while here I have the ACCOUNT table providing a bridge (that is anyway NOT inducing a many_to_many, as there is only ONE account for a quota, and ONE project for an account, hence ONE project for a quota).

Thanks for any hint!

I turned off autovivification in my code, but for loops broke that and my hashes got populated with unwanted data.

For loops do aliasing, and array is created to be aliased... But I really don't understand my code works despite reading documentation. Could anyone explain why @{$$n{'x'}} throws exception outside loop, and is accepted inside loop (see code below), and why square brackets make so much difference to autovivification?

#!/usr/bin/perl -CSDA

use utf8; 
use strict; 
use warnings; 
no warnings qw{uninitialized numeric}; 
no autovivification; #  qw{fetch exists delete store}; 
use Data::Dumper; 

print "\n\ninitialize data structures, no autovivification\n"; 
my $n = { 
    a => [1, 2 ], 
    b => [3, 4], 
}; 
$$n{'x'}{'y'}{'z'} and die; 
$$n{'x'}{'y'}[0] and die; 
$$n{'x'}{'y'} and die; 
$$n{'x'} and die; 
print "so far, so good, no 'x' autovivified:\n"; 
print Dumper $n; 

# "Can't use an undefined value as an ARRAY reference": 
# @{$$n{'x'}} and die;  

print "\n\nnow the same but in loop:\n"; 
for my $e (@{$$n{'x'}}) { 
}
print "why 'x' autovivified?\n"; 
print Dumper $n; 

print "\n\nnow the same but in loop:\n"; 
for my $e (@{[ $$n{'y'} ]}) { 
}
print "why 'y' NOT autovivified?\n"; 
print Dumper $n; 


1; 
[download]

Here comes the output of this program:

initialize data structures, no autovivification
so far, so good, no 'x' autovivified:
$VAR1 = {
          'a' => [
                   1,
                   2
                 ],
          'b' => [
                   3,
                   4
                 ]
        };


now the same but in loop:
why 'x' autovivified?
$VAR1 = {
          'x' => [],
          'a' => [
                   1,
                   2
                 ],
          'b' => [
                   3,
                   4
                 ]
        };


now the same but in loop:
why 'y' NOT autovivified?
$VAR1 = {
          'x' => [],
          'a' => [
                   1,
                   2
                 ],
          'b' => [
                   3,
                   4
                 ]
        };
[download]

Oh monks, enlighten me. Why is sub AUTOLOAD called for each call to $object->SUPER::method(), even after the initial call to sub AUTOLOAD installs an appropriate sub within *{$AUTOLOAD}? This changed in perl 5.18 and baffles me.

pre 5.18: If you installed your own getter/setter then later calls skipped sub AUTOLOAD.

post 5.18 (to 5.25.5): sub AUTOLOAD is called for every $bar->SUPER::method() invocation, and warns about redefinition.

#!/usr/bin/perl

use strict;
use warnings;

package Bar;
our @ISA = qw(Foo);

sub data {
    my $self = shift;
    return $self->SUPER::data(@_);
}

package Foo;

our $AUTOLOAD;
sub AUTOLOAD {
    my $self = shift;
    return if $AUTOLOAD =~ /^(.*::)?DESTROY$/;
    
    no strict 'refs';
    my $old = defined *{$AUTOLOAD} ? *{$AUTOLOAD}{CODE}//'' : '';

    my $force_new_code_ref = '';
    *{$AUTOLOAD} = sub { warn "running sub $force_new_code_ref"; };
    # usually a getter/setter, but simplified here.

    my $new = *{$AUTOLOAD}{CODE};
    warn "installed sub AUTOLOAD=$AUTOLOAD new=$new old=$old";

    &$new($self, @_);
}


package main;
my $bar = bless {}, 'Bar';

$bar->data('baz');
$bar->data('bip');
$bar->data('bop');
$bar->data('boo');
[download]

Here are the results for select versions (5.14.4, 5.16.3, 5.18.4, 5.25.5)

Adding no warnings 'redefine'; within sub AUTOLOAD bothers me. Creating a sub on every getter/setter invocation seems far from ideal.

I could avoid creating the subs by doing so only if ( ( not defined *{$AUTOLOAD} ) && ( not defined *{$AUTOLOAD}{CODE} ) ), but isn't that exactly what perl itself should be checking before calling sub AUTOLOAD? If a method exists there, why is sub AUTOLOAD being called?

Hi Monks,

I have a requirement to provide stats on the last 12 months from current day. I have an array of months so I would need to report out Oct 15', Nov 15', Dec 15', Jan 16' thru Sep 16' as the last column. Next month, the report would run on Oct, 1st and so the report would begin with Nov 15', Dec 15', Jan 16', etc...

My code is as follows

#!/usr/bin/perl
use POSIX 'strftime';

use strict;

my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime;
my $curr_mth = sprintf "%2d", strftime('%m', $sec,$min,$hour,$mday,$mo
+n,$year,$wday,$yday,$isdst);

my @month_name = qw(January February March April May June July August 
+September October November December);

while (<DATA>) {
         my %by_month = split ' ', $_;
        for my $m ( $curr_mth .. $#month_name) {

                if ( exists ( $by_month{$month_name[$m]} ) ) {
                        print "$by_month{$month_name[$m]} EXISTS for $
+month_name[$m] Row $.\n";
                } else {
                        print "$by_month{$month_name[$m]} DOES NOT EXI
+STS $month_name[$m] for row $.\n";
                }
        }
}
__DATA__
February 1 March 5 July 4 August 5 October 7
January 3 March 4 April 6 May 5 June 7 July 8 August 10 September 4 Oc
+tober 9 November 11 December 8
March 2 June 3 August 1 December 7
[download]

I have figured out how to start looping thru the Months array at October, but I can't figure out how to go past the end to September.

thanks very much for your time and effort and ideas.

package CSelTest;

use 5.020000;
use strict;
use warnings;

our $RE =
    qr{
          (?&ATTR_SELECTOR) (?{ $_ = $^R->[1] })

          (?(DEFINE)

              (?<ATTR_SELECTOR>
                  \[\s*
                  (?{ [$^R, []] })
                  (?&ATTR_SUBJECTS)
                  (?{
                      $^R->[0][1][0] = $^R->[1];
                      $^R->[0];
                  })

                  (?:
                      (
                          \s*=\s*|
                          #\s*!=\s*| # and so on
                          \s+eq\s+
                          #\s+ne\s+  # and so on
                      )
                      (?{
                          my $op = $^N;
                          $op =~ s/^\s+//; $op =~ s/\s+$//;
                          $^R->[1][1] = $op;
                          $^R;
                      })

                      (?:
                          (?&LITERAL_NUMBER)
                          (?{
                              $^R->[0][1][2] = $^R->[1];
                              $^R->[0];
                          })
                      )
                  )?
                  \s*\]
              )

              (?<ATTR_NAME>
                  [A-Za-z_][A-Za-z0-9_]*
              )

              (?<ATTR_SUBJECT>
                  (?{ [$^R, []] })
                  ((?&ATTR_NAME))
                  (?{
                      push @{ $^R->[1] }, $^N;
                      $^R;
                  })
                  (?:
                      # attribute arguments
                      \s*\(\s*
                      (?{
                          $^R->[1][1] = [];
                          $^R;
                      })
                      (?:
                          (?&LITERAL_NUMBER)
                          (?{
                              push @{ $^R->[0][1][1] }, $^R->[1];
                              $^R->[0];
                          })
                          (?:
                              \s*,\s*
                              (?&LITERAL_NUMBER)
                              (?{
                                  push @{ $^R->[0][1][1] }, $^R->[1];
                                  $^R->[0];
                              })
                          )*
                      )?
                      \s*\)\s*
                  )?
              )

              (?<ATTR_SUBJECTS>
                  (?{ [$^R, []] })
                  (?&ATTR_SUBJECT)
                  (?{
                      push @{ $^R->[0][1] }, {
                          name => $^R->[1][0],
                          (args => $^R->[1][1]) x !!defined($^R->[1][1
+]),
                      };
                      $^R->[0];
                  })
              )

              (?<LITERAL_NUMBER>
                  (
                      -?
                      (?: 0 | [1-9]\d* )
                      (?: \. \d+ )?
                      (?: [eE] [-+]? \d+ )?
                  )
                  (?{ [$^R, 0+$^N] })
              )

          ) # DEFINE
  }x;

sub parse_csel {
    state $re = qr{\A\s*$RE\s*\z};

    local $_ = shift;
    local $^R;
    eval { $_ =~ $re } and return $_;
    die $@ if $@;
    return undef;
}

1;
[download]

This code tries to parse expression like [attr] or [attr=1] or [attr eq 1] which is similar to the CSS attribute selector.

% perl -I. -Ilib -MCSelTest -MData::Dump -E'dd( CSelTest::parse_csel(q
+{ [attr] }) )'
[[{ name => "attr" }]]

% perl -I. -Ilib -MCSelTest -MData::Dump -E'dd( CSelTest::parse_csel(q
+{ [attr=1] }) )'
[[{ name => "attr" }], "=", 1]

% perl -I. -Ilib -MCSelTest -MData::Dump -E'dd( CSelTest::parse_csel(q
+{ [attr eq 1] }) )'
[[{ name => "attr" }], "eq", 1]
[download]

No problem so far. Now, this code also recognizes the form [meth()] or [meth(1,2,3)] or [meth(1,2,3) = 1], which is recognizing an argument list after the attribute/method name. And this is where the problem happens:

% perl -I. -Ilib -MCSelTest -MData::Dump -E'dd( CSelTest::parse_csel(q
+{ [attr()] }) )'
[[{ args => [], name => "attr" }]]

% perl -I. -Ilib -MCSelTest -MData::Dump -E'dd( CSelTest::parse_csel(q
+{ [attr()=1] }) )'
[[{ args => [], name => "attr" }], "=", 1]

% perl -I. -Ilib -MCSelTest -MData::Dump -E'dd( CSelTest::parse_csel(q
+{ [attr() eq 1] }) )'
do {
  my $a = [
    [
      { args => [], name => "attr" },    # .[0]
      { args => 'fix', name => "attr" }, # .[1]
    ],    # [0]
    "eq", # [1]
    1,    # [2]
  ];
  $a[0][1]{args} = $a[0][0]{args};
  $a;
}
[download]

As you can see, if I use the eq operator, (which is recognized by \s+eq\s+ part in the regex, notice the \s+ instead of \s*) instead of the = operator (which is recognized by \s*=\s* part in the regex, notice the \s* instead of \s+), I'm getting a duplicated section in the result (marked by the # .[1] comment.

I'm using perl 5.22.1 but have tried 5.24.0 as well as 5.25.4, with the same results.

Any hints?

An array of hashes, each hash containing one path, its ID, and its order ( foreward (F) or reverse (R) )

each path is initialized in the F position

my @paths = [ { id => 1, path => [A,B], order => 'F' }, { id => 2, pat
+h => [C,D,E], order => 'F' }, { id => 3, path => [E,B], order => 'F' 
+} ];
[download]

each node or vertex of each path also has an orientation ( + or - )

my %plus_minus;
$plus_minus{1}{A} = '+';
$plus_minus{1}{B} = '+';
$plus_minus{2}{C} = '+';
$plus_minus{2}{D} = '-';
$plus_minus{2}{E} = '-';
$plus_minus{3}{E} = '-';
$plus_minus{3}{B} = '-';
[download]

You can reverse the order of a path ( e.g., A, B to B, A )

When you reverse order from F => R or R => F you also switch the orientation of each node in the path from + to - or - to +

The paths with orientations look like this:

1 .A+ : B+

2. C+ : D- : E-

3. E- : B-

this is the problem input for output, i'd like to know whether or not it is possible by reverseing path orders to create a consensus path and also what is the way to do this such that you are guaranteed to find the consensus path

for example, if we reversed path 1 we'd get:

1. B- : A-

2. C+ : D- : E-

3. E- : B-

and the resulting consensus path would be:

C+ : D- : E- : B- : A-

but it's not clear to reverse path 1 first; for example; what if started by reversing path 3? So you can't proceed randomly. Does anyone recognize this problem? Does it have a solution? Thanks.

I have what I thought would be a simple issue. I'm reading a YAML file full of user names, email, phone, etc. Many are French-Canadian, and have accented characters. In the file I'm reading, it looks like:

I know that \xe7 is "ç", and \xe9 is "é", etc., but it prints to the terminal as just \xe7, \xe9.

I've looked up all sorts of stuff: use utf8; use Encode; binmode(STDOUT, ":utf8"), blah blah blah.

I just want to print the stupid messed up characters the way they're supposed to look; for the love of God, please, help me.

(The next step, of course, is to forbid our French-Canadian employees to use ridiculous non-english characters when creating user accounts - but one thing at a time).

Regards & God Bless,

Sister Mary Guacamole

sub splitLine {
    my $line = shift;
    my $pattern = shift; # by default, it is "ERROR"
    my %header;
    #                     DD.MM.YYYY           HH:MM:SEC       USEC   
+     ERROR/WARN           [pool-def]   class-name   msg
    my $sPattern = '(\d{2}.\d{2}.\d{4}).*?(\d{2}:\d{2}:\d{2}).\d{0,3}.
+*?\*(' . $pattern . ')\*.*?(\[.*?\]).(.*?\..*?\s+?)(.*)';

    if ($line =~ /$sPattern/s) {
        my $ts = parseLogEntryTimeStamp($1, $2);
        %header = ( 'timestamp' => $ts,
                    'date' => $1,
                    'time' => $2,
                    'severity' => $3,
                    'thread' => $4,
                    'class' => $5,
                    'msg' => $6);
        print "$7 \n";
        #doTrace %header;
    }
    return %header;
}
[download]

30.08.2016 08:00:00.004 *ERROR* [pool-7-thread-5] com.day.cq.reporting
+.impl.snapshots.SnapshotServiceImpl Error accessing repository during
+ creation of report snapshot data
javax.jcr.LoginException: Cannot derive user name for bundle com.day.c
+q.cq-reporting [313] and sub service null
[download]

I just spent several hours debugging some code using LWP::UserAgent. The code could be reduced to this:

use strict;
use warnings;
use LWP::UserAgent;

my $URL = 'https://myhost.local/';

my $ua = LWP::UserAgent->new;
$ua->ssl_opts( verify_hostname => 0 );
my $response = $ua->get($URL);

if ($response->is_success) {
    print $response->decoded_content;  # or whatever
}
else {
    die $response->status_line;
}
[download]

So pretty much a copy&paste from the LWP::UserAgent docs.

The error message I got was:

Can't connect to myhost.local:443\n\n
500 Can't connect to myhost.local:443 at foo.pl line 15.
[download]

After some debugging, strace finally showed me an ENOENT for an SSL CA file, which nudged me into the right direction.

So, my questions are:

• Why does a missing CA file cause the request to fail, even though I've used ua->ssl_opts( verify_hostname => 0 );?
• What do I have to do to get a better error message out of LWP::UserAgent? Is this a bug in LWP::UserAgent?

This is on a Debian Jessie box with perl 5.20.2, and LWP::UserAgent 6.06.

Hello, dear esteemed monks!

I have made a test script that makes cover -t include untested modules into the summary, thus lowering the overall coverage level and the developer's exaggerated ego.

Not even sure how I didn't come up with something like that earlier. So... Here it is:

dallaylaen/todo.t

#!/usr/bin/env perl

# This script tests nothing (except the fact that modules load w/o war
+nings).
# However, it tries to load them all.
# This means that untested modules would also be included into
# code coverage summary, lowering total coverage to its actual value.

# I.e. having a well-covered module and a totally uncovered one 
# will result in 50% coverage which is probably closer to truth.

use strict;
use warnings;
use Test::More;
use FindBin qw($Bin);
use File::Basename qw(dirname);

# Try to load EVERY module in t/../lib
my $path = dirname($Bin)."/lib";
my @files = `find $path -type f -name \*.pm`;

# Save warnings for later
my @warn;

foreach my $file (@files) {
    chomp $file;

    # This sub suppresses warnings but saves them for later display
    local $SIG{__WARN__} = sub {
        my $w = $_[0];

        $w =~ /^Subroutine.*redefined/
            or push @warn, "$file: $w";
        return; # somehow this supresses warnings under make test
    };

    ok ( eval{ require $file }, "$file loaded" )
        or diag "Error in $file: $@";
};

# print report
foreach (@warn) {
    diag "WARN: $_";
};

# If you are concerned about cover -t, then probably 
# warnings during load are not OK with you
is( scalar @warn, 0, "No warnings during load (except redefined)" );

done_testing;
[download]

P.S. Despite my countermeasures, it still produces A LOT of redefined warnings during cover -t run (but not under normal make test), not sure how to suppress them.

Suggestions, improvements are welcome!

One idea is to (automatically) integrate a link to PM per slide into the PDF, clicking would show a sub-thread in PM for this slide.

Another is to embed Youtube videos in a thread start here like reddit does.

Other ideas? :)