[
       {
        foo => {
                browser => "firefox",
                contact => [{ email => "foo\@example.org" }, { phone =
+> 2125551212 }],
                lang    => "en",
               },
       },
       {
        bar => {
                browser => "lynx",
                contact => [{ email => "bar\@example.com" }, { phone =
+> 9125551212 }],
                lang    => "fr",
               },
       },
      ];
[download]

One of the problems is to avoid autovivification.

The usual answers imply

• no autovivifation
• use Data::Diver

after some meditation I came up with the following solution.

It looks so idiomatic and generic to me that I'm asking myself if I missed something:

use v5.12.0;
use warnings;
use Test::More;
use Data::Dump;


sub orig_data {
    return
      [
       {
        foo => {
                browser => "firefox",
                contact => [{ email => "foo\@example.org" }, { phone =
+> 2125551212 }],
                lang    => "en",
               },
       },
       {
        bar => {
                browser => "lynx",
                contact => [{ email => "bar\@example.com" }, { phone =
+> 9125551212 }],
                lang    => "fr",
               },
       },
      ];
}

my $data = orig_data();

my @emails;

# ------ short version
@emails =
  map { $_->{email} // () }
  map { @{ $_->{contact} // [] } }
  map { $_->{bar} // () }
  @$data;

is_deeply(\@emails, ["bar\@example.com"], "result ok");
is_deeply($data, orig_data(), "no autovivification");


# ------ long symmetrical version
@emails =
  map { $_->{email} // () }
  map { @$_ }
  map { $_->{contact} // () }
  my @users =                            # only necessary to check uni
+queness
  map { $_->{bar} // () }
  map { @$_ }
  $data;

is_deeply(\@emails, ["bar\@example.com"], "result ok");
is_deeply($data, orig_data(), "no autovivification");



# --------- this would vivify new elements
# map { $_->{bar}{contact} // () }
#   map { @$_ }
#   $data;

# is_deeply($data, orig_data ,"no autovivification");

done_testing;
[download]

OUTPUT:

ok 1 - result ok
ok 2 - no autovivification
ok 3 - result ok
ok 4 - no autovivification
1..4
[download]

NB: as an extra benefit I can check if @emails and @users have only one element to catch glitches in the data. Those arrays of one element hashes like

• [{ email => "bar\@example.com" }, { phone => 9125551212 }],

Thoughts???

I'm confronted with a young developer who is producing a lot of blog posts concerning Perl with plenty of speculative, untested and broken code.

I can't tell yet if it's genuinely from him° or if he just ran it through ChatGPT.

But the amount is staggering and it looks believable at first glance. One needs to know Perl to spot the nonsense.

I don't wanna sound an alarm, but this could be the beginning of a trend to flood the net with "AI" wisdom.

meta meditation

The next step in this arms race might be to use machine learning to test if code really does what it should.

And this feedback loop might really lead to a more useful AI coding.

°) he seems to be from one of those offshore places with a different education system

Around a year ago, we were treated to a gripping duel, in which the redoubtable talexb pipped PM veteran jdporter by just three Experience Points, and so scale the highly coveted Chancellor plateau first.

With the delightful planetscape still inactive, I'm pleased to report that this original 100 metre sprint to Chancellor has transmogrified into an exciting three-way 1500 metre race to join the Top Fifty Perl Monks of All Time:

#	User	Experience	Level	Writeups	User Since	Last Here
50	planetscape	31378	Chancellor (21)	1303	2005-03-27 09:28	34 weeks ago
51	jdporter	30760	Chancellor (21)	3687	2002-05-30 16:48	18 hours ago
52	afoken	30573	Chancellor (21)	2217	2009-02-28 20:01	13 hours ago
53	talexb	30559	Chancellor (21)	2250	2001-12-12 20:34	2 days ago

As you can see, a fresh interloper has snuck in between old rivals jdporter and talexb. Who do you predict will win this race to the Top 50?

Updated: fixed minor typos in above table.

after so many years I still lack the understanding of basics.

I always thought of sort as if it should check every element of a list against any other element: this is not true. Infact rereading the sort docs, the very bottom line, I read: is implemented via the mergesort algorithm

Mergesort is based on old Latin motto divide et impera and because of this not every combination is take in count while sorting. It is optimized to compute only the lowest number of checks.

Let clean the field: sort is not like map infact:

• perl -we "sort @ARGV" 1 2 gives Useless use of sort in void context at -e line 1
• perl -we "$x = sort @ARGV" 1 2 gives Useless use of sort in scalar context at -e line 1

Why?

In the docs I read also subroutine that returns an integer less than, equal to, or greater than 0 so I tried to see what happens forcing the returned value:

perl -le "@a = sort{ print qq($a $b); 0 }@ARGV" 1 2 3 4
1 2
3 4
1 3
3 2

perl -le "@a = sort{ print qq($a $b); 1 }@ARGV" 1 2 3 4
1 2
3 4
2 4
2 3

perl -le "@a = sort{ print qq($a $b); -1 }@ARGV" 1 2 3 4
1 2
3 4
1 3
3 2
2 4                                                      # one iterati
+on more with -1
[download]

In the last example there is an iteration more: why? I'm fooling the algorithm telling $b is always less than $a or what?

Also the only missing couple frome the last example is 1 4 can I force sort to be unoptimized as I wanted in my oneliner example?

Beside Very nice title but: hey kid! Stop messing with sort code! do you have something wise to share?

L*

Avery

Intro

I've been looking at the docs for the new 'class' OO in upcoming Perl versions.

While i agree that Perl would benefit from a modern OO system, i think this new system shouldn't give up any of the flexibilities ye olde 'bless' provides.

Before i go into details, i must admit that i'm not a huge fan of the "attributes" stuff that most OO system use. Or at least not to the extend they are used anyway. I've seen code that uses like 4-5 attributes for a single class and just as much for a variable. I call this C++ line noise. Yes, it makes the code more concise(1), but when you have to spend a minute per line of code just to understand just the implication of these flags, they are not what i call helpful. Going forward, the new 'class' system will have to be very carefully design to avoid making a mess with attribute feature creep.

I also understand that 'class' is still in the early stages, so i can only look on what has been designed so far. My main questionmarks are:

• Abort object creation?
• Constructor not proper functions?
• Deciding when to call parent constructor?

Let's look at those in detail:

Abort object creation?

One of the nice things about 'bless' is that constructors are just functions with return values. This allows the constructor a lot of flexibility. One of those is to not construct an object under some circumstances. Something like this:

package Foo::Bar::UrlHandler;

sub new($proto, %config) {
    my $class = ref($proto) || $proto;

    if(!defined($config{url})) {
        # No URL given, don't know what to do next
        return;
    }

    my $self = bless \%config, $class;

    return $self;
}
[download]

The caller can easily check if things worked out:

my $handler = Foo::Bar::UrlHandler->new(url => 'http://perlmonks.org')
    or do_some_error_handling();
[download]

From what i understand, a 'class' is pretty much required to be created, no matter if that makes sense with the given parameters. This will probably make error handling/detection in the caller more complicated. And no, eval() is seldomly the solution to such problems but many times the cause of them.

Constructor not proper functions?

From the design, it seems you don't write the constructor as a proper function, you can only 'ADJUST()' what it does. This has a few implications that make it much less flexible than bless():

No "named" constructor

Modules like DBI (among others) make use of the fact that bless() can run in arbitrarily names constructors. For DBI, this is connect(). In my opinion, this makes it much clearer to the user of this module that constructing an new instance is not only an in-memory operation, it also connects to the server.

No option for multiple constructors

In my projects, i have a few modules that provide multiple constructor. For example, there might be a classic new(list-of-parameters), but also a newFromConfig(filename) that takes a filename to a configuration file. This makes especially sense when using sub signatures. Another example would be, say, a file parser that has a newFromFile() and newFromUrl() method.

Yes, you can achieve this by subclassing with the new 'class' OO, but that can make the code harder to maintain, especially if only the initialization differs.

No simple "factories"

I sometimes use the concept of "factories", e.g. modules that decide on given parameters which object to return. In keeping with the example of the UrlHandler above, something like this isn't too uncommon:

package Foo::Bar::UrlHandler;

sub new($proto, %config) {
    my $class = ref($proto) || $proto;

    if(!defined($config{url})) {
        # No URL given, don't know what to do next
        return;
    }
    
    if($config{url} =~ /^http\:/) {
        return Foo::Bar::UrlHandler::HTTP->new();
    } elsif($config{url} =~ /^file\:/) {
        return Foo::Bar::UrlHandler::FILE->new();
    }

    # Invalid URL?
    return;
}
[download]

Deciding when to call parent constructor?

Sometimes it's useful to decide WHEN and IF(2) to call the parent constructor. I don't see how that is properly handled by the 'class' OO.

sub new($proto, %config) {
    my $class = ref($proto) || $proto;

    # Override the default template
    $config{htmltemplate} = 'righttoleft.tt';

    # Call parent constructor to load and parse template
    my $self = $class->SUPER::new(%config);
    
    # Re-bless
    bless $self, $class; # Re-bless with our class
    
    $self->do_our_own_stuff();
    
    return $self;
}
[download]

Conclusion

The new 'class' OO is a long overdue project and i thank the developers for their hard work. But at this early stage, it seems to be only a copy of other programming languages, without the flexibility Perl can (and currently does) provide when it comes to object orientation.

I'm using Perl (and ignore the Moo* stuff(3)) because i can shape the language to fit the problem. If we go the way in which we have to shape the problem to fit the language, we all might as well switch to there-is-only-one-way-to-do-it languages like C++, Java or TypesScript.

Yes, 'class' has the potential to make object oriented code easier to read and write, and i'm certainly all for that. We just need to make sure that it turns out TIMTOWTDI enough not to feature the same headaches as Java or C++. I can only talk about this from one own, small personal viewpoint, but because of (not "despite of"!) the flexibility of the old bless() OO and the typelessnes of Perl variables, in the last two decades i was able to single-handedly write a big web framework and implement multiple commercial systems in Perl.

Footnotes:
(1) just as $_ does. Which makes following code flow (and debugging it) a huge pain. Use $_ is banned in my projects.

(2) Sometime you override, sometime you enhance, sometimes the parameters to new() tell you what to do

(3) Combining the rigidity of C++ with the speed of Windows Vista somehow never appealed to me.

After chastising Bod recently for not writing his unit tests first, I felt obliged to finally write some unit tests for Rosetta Code: Long List is Long.

I was too lazy to act though until further provoked by a new version of the get_properties function that updated a non-const global variable. After changing its interface to avoid the need to modify the dreaded global, I felt obliged to write some unit tests for my new interface, in both Perl and C++, as a fun learning exercise. This meditation describes that endeavour.

Create the Test Files

I started by writing a helper script create-test-files.pl to create two simple LLiL-format (each line must match: ^[a-z]+\t\d+$) test files to be read by the unit tests:

# create-test-files.pl

use strict;
use warnings;

sub build_file {
   my ( $file, $data ) = @_;
   open( my $fh, '>', $file ) or die "open '$file': $!";
   print {$fh} $data or die "write '$file': $!";
}

my $tt_1_data = <<"LLiL";
camel\t50
dromedary\t70
pearl\t42
LLiL

my $tt_2_data = <<"LLiL";
dromedary\t3
kibitzer\t1000
dromedary\t2
camel\t19
dromedary\t1
LLiL

my %test_files = (
   'llil-1.txt' => $tt_1_data,
   'llil-2.txt' => $tt_2_data
);

for my $fname (sort keys %test_files) {
   print STDERR "Create test file '$fname'...";
   unlink($fname);
   build_file( $fname, $test_files{$fname} );
   print STDERR "done.\n";
}
[download]

After running this script, you should have two short LLiL-format text files: llil-1.txt and llil-2.txt. These files will be used by the unit tests. If you reply with unit tests written in another language, please use these two files in your unit tests.

LLiL.pm

package LLiL;
use strict;
use warnings;

# Read a LLiL-format file.
# Return the number of lines in the file or -1 if the file could not b
+e opened
# Update $hash_ret, a reference to a hash of properties
sub get_properties {
   my $fname    = shift;    # in:    a LLiL-format filename
   my $hash_ret = shift;    # inout: a reference to a hash of properti
+es
   my $cnt = 0;
   open( my $fh, '<', $fname ) or return -1;
   while (<$fh>) {
      ++$cnt;
      chomp;
      my ($word, $count) =  split /\t/;
      $hash_ret->{$word} += $count;
   }
   close($fh);
   return $cnt;
}

# Note: Some extra validation that could be done in get_properties() a
+bove
#       ( not done because, to allow the code to run as fast as possib
+le,
#         get_properties assumes the input data adheres to the LLiL sp
+ec,
#         that is, each line matches ^[a-z]+\t\d+$ ):
#   s/^\s+//; s/\s+$//;          # remove leading and trailing whitesp
+ace
#   next unless length;          # ignore empty lines
#   $word =~ /^[a-z]+$/ or die "error: invalid word  '$_' (must contai
+n [a-z] only)";
#   $count =~ /^\d+$/   or die "error: invalid count '$_' (must contai
+n [0-9] only)";

1;
[download]

llil.t

# llil.t
# Simple unit test of get_properties() function in LLiL.pm.

# Normal run of this test : prove -v -I . llil.t
# Can also run with       : perl -I . llil.t

# Note: before running this test, create the test files
# llil-1.txt and llil-2.txt by running: perl create-test-files.pl

use strict;
use warnings;
use LLiL;

use Test::More;
my $ntests = 5;
plan tests => $ntests;

my $expected_href = {
   'camel'     => 69,
   'dromedary' => 76,
   'kibitzer'  => 1000,
   'pearl'     => 42
};

my %hash_ret;
my $href = \%hash_ret;

# Error tests
{
   my $n = LLiL::get_properties( 'non-existent-file', $href );
   cmp_ok( $n, '==', -1, "get_properties non existent file return valu
+e" );
}

# Normal tests
{
   my $n = LLiL::get_properties( 'llil-1.txt', $href );
   cmp_ok( $n, '==', 3, "get_properties file 1 return value" );
   $n = LLiL::get_properties( 'llil-2.txt', $href );
   cmp_ok( $n, '==', 5, "get_properties file 2 return value" );
   cmp_ok( scalar(%{$href}), '==', 4, "number of items in hash" );
   is_deeply( $href, $expected_href, "hash content" );
}
[download]

Running the Test

With that done, you can run the unit test with core Perl testing tools with:

perl -I . llil.t
[download]

prove -v -I . llil.t
[download]

The output from running the prove command above is:

> prove -v -I . llil.t
llil.t ..
1..5
ok 1 - get_properties non existent file return value
ok 2 - get_properties file 1 return value
ok 3 - get_properties file 2 return value
ok 4 - number of items in hash
ok 5 - hash content
ok
All tests successful.
Files=1, Tests=5,  0 wallclock secs ( 0.00 usr +  0.00 sys =  0.00 CPU
+)
Result: PASS
[download]

Note that this only unit tests that the hash contains the correct keys and values. The sorting/ordering of the values in the hash is performed in a separate later step.

Please feel free to respond with improved Perl versions of llil.t or with a version of this simple unit test in another language.

@rem = q:to/use strict;/;
@echo off
raku -e "('no strict;' ~ (slurp q<%~f0>)).EVAL" %*
goto :EOF
use strict;
 
say "Hello! I am Raku.";
say @*ARGS;
[download]

@@; $_ = q:to/@@; goto :EOF/; # 2>nul
@@; raku "%~f0" %*
@@; goto :EOF
 
say "Hello! I am Raku.";
say @*ARGS;
[download]

@@; #`{ 2>nul
@echo off
raku "%~f0" %*
goto :EOF
}

say "Hello! I am Raku.";
say @*ARGS;
[download]

Thanks to Bob Rogers, Spreadsheet::Read now supports Gnumeric using Spreadsheet::ReadGnumeric as parsing backend.

  my $book = ReadData ("test.gnumeric");               # function
  my $book = Spreadsheet::Read->new ("test.gnumeric"); # OO
[download]

Bob has taken Spreadsheet::Read as API definition, so integration should be smooth!

Most attributes are supported.

Version 0.87 has just been released. Get it while it is hot.

Welcome to the first (?) Sunday Perl Challenge Trip! The challenge will last one week and then points will be calculated. I dont hope someone is mad enough to accept the challange, but I think is more fun this way, instead of posting my code alone. But who knows..

Assignement

We need to implement nested autocompletion while reading user input: the command A lead to options 1 2 3 and command B to 4 5 etc..

Simple? No: a dread :) Let specify it better. Given the following data:

# dummy items to play with
my @animals = (qw( cow camel dog cat  ));
my @foods   = (qw( fish pasture meat  ));
my @places  = (qw( wood sea    desert ));

# commands 
my $commands = {
    select => {
        completion_list => \@animals,
        commands => {
                        give => {
                                    completion_list => \@foods,
                        },
                        take_to => {
                                    completion_list => \@places,
                        },
        },
    },
    kill  => {
        completion_list => \@animals,
    }
};
[download]

the first choices are only select and kill and if you choose select (entering it or using selTAB to autocomplete it) then autocomplete should permit only one item from @animals Once you entered (directly or autocompleting it) an animal then only the two commands give and take_to should be available. And so on.

I used hardcoded keywords commands and completion_list to drive my solution: feel free to use them or not or to change them.

An example session:

Press TAB for autocompletion or available options

autocompletion nested>("kill", "select")                              
+ # 'TAB' on empty input shows available commands
autocompletion nested>select c("camel", "cat", "cow")                 
+ # 'cTAB' shows animals but not 'dog'
autocompletion nested>select ca("camel", "cat")                       
+ # 'caTAB' shows two animals starting with 'ca'
autocompletion nested>select camel ("give", "take_to")                
+ # I press 'mTAB' thae autocomplete in 'camel' 
                                                                      
+ #    'TAB' again for next level commands: give and take_to
autocompletion nested>select camel take_to ("desert", "sea", "wood")  
+ # 'tTAB' and 'TAB' again
autocompletion nested>select camel take_to desert                     
+ # 'desTAB' leads to 'desert'
                                                                      
+ # ENTER 1
autocompletion nested>                                                
+ # ENTER 2 exits the user input cycle
CHOOSEN: select camel take_to desert                                  
+ # finally we print the resulting path
[download]

Points

• +50 points to get the job done. Runnable code.
• +Reputation of the node when the challenge close
• -5 for reading Hint1 (declare it in the answer):
  <Reveal this spoiler or all spoilers in this node or all in this thread>
• -10 for reading Hint2 (declare it in the answer):
  <Reveal this spoiler>
• -20 for reading my solution (declare it in the answer: it includes Hint1 and Hint2) and use it as starting point :)

Extra points

• +40 points for not using Term::ReadLine family modules :)
• +20 points for a correct use of BACKSPACE to have editable lines: you change your mind and you go back through the line
• +10 points if you are able to avoid the double ENTER I need to end the line building when we reached the end of the datastructure
• +100 points if you publish it as CPAN module in this week
• my ethernal gratidute if I understand your code :)

My solution

My code is ugly enough, but it works. It is full of comments to help you understing what's going on. Some unused code is commented to show possible improvemnts. It has some debug options: 0 (default), 1, 2 that ruins a bit the output but are useful to see the flow.

Avoid to comment my code before the challange ends. Here we are:

Have fun!

L*

$findme="olsijdf9823";
$len=length($findme);

$pid=$$; #"self";
$heap=`cat /proc/$pid/maps | grep heap | cut -d ' ' -f 1`;
$stack=`cat /proc/$pid/maps | grep stack | cut -d ' ' -f 1`;
print("my pid is $pid\n");

#while(){sleep 1;}

if ($heap =~ /([a-f0-9]+)-([a-f0-9]+)/) {
  $start_heap = hex($1);
  $end_heap = hex($2);
}

if ($stack =~ /([a-f0-9]+)-([a-f0-9]+)/) {
  $start_stack = hex($1);
  $end_stack = hex($2);
}


open(MEM, "+<", "/proc/$pid/mem") or die "no permissions";

for $addr ($start_heap..$end_heap) {
  seek(MEM, $addr, 0);
  read(MEM, $buff, $len, 0);
  #print(sprintf("0x%x %s\n", $addr, $buff));
  if ($buff eq $findme) {
    print("found\n");
    seek(MEM, $addr, 0);
    print(MEM "hacked\x00");
  }
}

close(MEM);
`sync`;

print "---> $findme \n";
#EOF
[download]

$ perl test.pl
my pid is 127249
found
---> hacked9823
[download]

Questions:

• Is it possible to filter speech frequencies in a video with significant accuracy to identify the passages were people talk?
• Can the resulting pattern be used to synchronize a subtitle file, to match the gaps?

Background:

I'm often downloading foreign language movies and like to see them with original voice and subtitles to practice and learn vocabulary, but am often obliged to download and adjust the subtitles timing, because

• they are shifted, because of trailers or of "what happened last time" intros
• they are stretched, because of different frame rates
• they need readjustment in the middle because scenes were cut out

That is, if the parameters are known. But finding them can be tricky.

FWIW: VLC offers an option for such synchros, but tends to freeze for a minute if the shift is in the area of 20 secs. No fun when trying out the best settings.

Dmitri: What is this regex for?

((?:(?:[^\n@]+|@[^@]*@)\n?)+)
[download]

ChatGPT: This regular expression is used to match a pattern that contains multiple lines of text. The regular expression is designed to match one or more occurrences of a sequence of characters that can include any characters except a newline (represented by \n) or an at sign (@), or an at sign that is immediately followed by one or more other characters (also represented by @) and then another at sign.

The outermost parentheses ( ) define a capturing group that captures the matched text, this group will be repeated one or more times + . The first non-capturing group (?: ) is used to match any characters except a newline or an at sign. The second non-capturing group (?:@[^@]*@) matches an at sign, followed by zero or more characters that are not an at sign, followed by another at sign.

The ? after the first non-capturing group means that the preceding element is optional and can match zero or one time. The ? after the second non-capturing group means that the preceding element can match zero or one time, and the \n means that it will match a new line.

This regular expression should be used in conjunction with other tests or validation to ensure that it only matches valid input. It is not a complete solution to validate emails or other texts, just a pattern matching.

Dmitri: Can you optimize it?

ChatGPT: Yes, it can be optimized for performance. Here's one possible way:

((?:(?:[^\n@]|@[^@]*@)[^\n]*\n?)+)
[download]

• The first change I made is that instead of using \n? after the second non-capturing group, I added [^\n]*\n? which means that the pattern matches zero or more characters that are not a newline, followed by an optional newline. This change allows the regular expression engine to stop looking for a newline as soon as it encounters a character that is not a newline.
• The second change I made is that I used [^\n@] instead of [^\n] before the @ . This change allows the regular expression engine to stop looking for an at sign as soon as it encounters a character that is not an at sign.

However, it's worth noting that regular expressions can be very complex and it's hard to give a definitive answer without knowing more about the specific use case and the input data. You can also try different variations and test them on your specific input to see which one performs better.

Have you used ChatGPT? What do you think?

Every few years I try to update this post so that people are aware.

Question is how to send email through GMail, or otherwise a Google Account.

It's still easy, but different. The instructions can be found in the above link through your own research. It can be done.

I want to keep this knowledge alive. When I have difficulty and find a solution, I want others to know how I overcame it. We should all be able to send mail or text messages through our Google accounts.

use warnings;
use strict;

use Net::SMTP;

my $smtp = Net::SMTP->new(
    'smtp.gmail.com',
    Hello => 'local.example.com',
    Timeout => 30,
    Debug   => 1,
    SSL     => 1,
    Port    => 465
);

# Password here is an app password. Need to enable 2FA on Google
# account to generate one

$smtp->auth('steve.bertrand@gmail.com', '*app_password*') or die;
$smtp->mail('steve.bertrand@gmail.com');
$smtp->to('steve.bertrand@gmail.com');
$smtp->data();
$smtp->datasend("hey!\n");
$smtp->quit();
[download]

The above is copy and pastable working code. I'm all in with no obfu with my real email address. I'm good with seeing how the cards fall.

Which is a bit surprising given all the struggle Strawberry is going thru.

I remember there might be "restrictions" with this since it's optimized to work inside bash and expects *nix path conventions. But I'm wondering - well meditating - if this might not be a viable substitution for Strawberry.

I also suppose that the c-compiler/make combo might cause problems when installing further modules ... (?)

But portable means one could keep an unaltered git version in one directory and adjust another in a second directory...

Opinions?

update

for a similar recent discussion see Perl::Dist::APPerl - Actually Portable Perl