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

1. They spelled it: PERL
2. Raptors are extinct.
3. Raw onions? C'mon!

I want cool cryptic, like Perl itself:

$Perl->{5.36}

Obviously: camel code

This shows the probabilities of drawing two specific cards (labeled A and B) in a hand of five cards, from decks of various sizes.

All numbers are percentages.

When the deck contains no 'draw' cards:

When the 'A' card causes Draw 1:

The probabilities of other combinations can be derived from those given in this table:

• A | !B (A or not B - possibly both conditions) is the inverse of A & !B.
• A ^ !B (A or not B but NOT both conditions) is the inverse of A ^ B.
• !A & !B (neither A nor B) is the inverse of A | B
• !A | !B (not A, or not B - possibly both conditions) is the inverse of A & B.
• !A ^ !B (not A, or not B, but NOT both conditions) is logically the same as A ^ B.

Hello my fellow Monks.

I've been absent the last few months. I have, unfortunately, been forced to submit to the snake cult.

I resisted. I resisted for as long as I could. I even thought I might get away with continuing to use Perl until my "retirement" from corporate life that is hopefully less than a half decade away. But alas, the pervasiveness of Python, and it's success in becoming the first language of choice for so many engineering schools for the last several years has backed me in to a corner, and the zealots have come for me demanding I convert or be burned at the stake for heresy. I am in effect being told I can no longer write scripts in Perl and must adopt Python so that others can read and modify my code. :-(

Our young engineers use Python. Our technicians use Python. All our automated tests and data analytics are now written in Python. I had such hope when I joined my current company. They even had an old learning course on video originally taught in person by someone who is now one of our VPs called "Test Automation with Perl Scripting"... but it's almost two decades old now.

Sadly, I simply don't have the capacity at this point to maintain any sort of proficiency in two scripting languages. Frankly, I barely have enough for one. So I am now forced to type their indoctrination mantras in the devil's own parseltoungue. Pity me, for your brother monk has truly fallen from grace.

I may leave the monastery now, some seven years after I joined your order, but I have decided to leave it as I have lived in it. With a bit of my own awkward brand of humor via one final Perl Poetry entry from the Monk who fancies himself a drunken poet.

To those of you who have helped me over the years, or made me laugh, or raised my spirits, I sincerely thank you. Be well, live long, and prosper. :-)

- perldigious

Happy Holidays, fellow Monks!

Over the last decade, with lots of help, I've been able to bring forth some interesting things for Perl, and I'm now in the beginning stage of another one.

I put forth an API to command and control Raspberry Pi devices and dozens of Integrated Circuits and sensors related to it. I then reverse engineered Tesla's API and wrapped it with Perl.

I'm a strong privacy advocate. For years, I distrusted all vendors of all kind. However, through one of my jobs, I was forced to better familiarize myself with Apple. Despite issues and setbacks, they are, IMHO, very reasonable with privacy. Even their legalese is human readable for the most part. In fact, not only am I typing this on a Macbook, I have an iPhone, Apple Watch and several devices that allow me to control my home automation. Yep, I am even friends with Siri.

With that said, I want to embark on another very, very ambitious project... figure out how I can write a Perl API to deal with Apple devices, particularly HomeKit stuff.

To keep this SoPW, does anyone have experience writing Perl software or wrappers against anything Apple? I'm wiggling my way into a position of a starting point.

Happy Holidays all, and thanks for being supportive of both Perl, and myself over the years. You're all the reason I've become the developer I have.

Cheers,

-stevieb

The website didn't tell me anything exciting on my arrival today, but I know it's my Monk Day because it's also my older step-son's birthday. :) Matt's now 35 (yikes).

My Dad, who was 90, died this Fall. He was a retired actuary, and loved Maths. His father was a higher-up at one of the insurance companies in London, so Dad kind of fell into that field, although I think his first love was trains and civil engineering. When I started to show an aptitude for math, he would gladly give me a problem (like calculating ten factorial) to go to sleep with. He worked on his insurance company's computer system, an IBM 360 package called A Life Insurance System (ALIS, an IBM product, obviously), written in COBOL. He also did some work in APL (another brilliantly name IBM package that stands for A Programming Language).

So, by the time my high school got time-sharing access to the school board's mainframe so we could learn BASIC, he was all keen to jump in and try it out (Fall of '73), by writing a program that calculated the probabilities of the various blood types in a population. I became one of the nerds who would hang out in the computer room, trying out code and watching fellow nerds do cool stuff on the teletype. Sometimes, we'd download our programs to yellow paper tape.

University work terms led to me learning assembler, and then C. Full time work led to Pascal, then awk and Perl. SQL crept in pretty soon after that. Once outside the safe walls of university, I had to figure out my own continuing education, which is where the Perl community came in. I started with the local Perlmongers, and continued with this community. It's a cool place to ask questions, read other folks' answers, and maybe provide some answers of your own.

My education continues to this day. And I thank you all. :)

sub setpixel {
  my ($self, %opts) = @_;

#  $self->_valid_image("setpixel") or return;

  my $color = $opts{color};
  unless (defined $color) {
    $color = $self->{fg};
    defined $color or $color = NC(255, 255, 255);
  }

#  unless (ref $color && UNIVERSAL::isa($color, "Imager::Color")) {
#    unless ($color = _color($color, 'setpixel')) {
#      $self->_set_error("setpixel: " . Imager->errstr);
#      return;
#    }
#  }

  unless (exists $opts{'x'} && exists $opts{'y'}) {
    $self->_set_error('setpixel: missing x or y parameter');
    return;
  }
...
}

sub _valid_image {
  my ($self, $method) = @_;
 
  ref $self
    or return Imager->_set_error("$method needs an image object");
 
  $self->{IMG} && Scalar::Util::blessed($self->{IMG}) and return 1;
 
  my $msg = $self->{IMG} ? "images do not cross threads" : "empty inpu
+t image";
  $msg = "$method: $msg" if $method;
  $self->_set_error($msg);
 
  return;
}
[download]

I admit that dualvar was a term I never felt looking up until it came up recently here at the Monastery at Re^2: Rosetta Code: Long List is Long -- dualvar by marioroy. And I had a look at it. I found that Scalar::Util's dualvar can indeed create such a variable but I did not find any way of driving an existing variable into schizophrenic behaviour.

And so here is a gutty way to alter the string and/or numeric part of an existing scalar. Mind you I did a brief search on whether there was already some existing package doing that but did not find any.

This can find applications in some cases of the Schwartzian transform where the "decorations" and "undecorations" can apply on existing data rather than creating new (re: decorate/undecorate, Schwartzian_transform). The concept is not new (e.g. see comments under https://www.endpointdev.com/blog/2009/08/perls-scalarutildualvar/), but I did not find anything without creating new (dual)var but altering existing var. So here it is in a single-file SCSE form (XS can be found in ./_Inline/build dir):

## by: bliako
## on: 2022-12-05
## EDIT: kudos to https://metacpan.org/release/PEVANS/Scalar-List-Util
+s-1.63/source/ListUtil.xs (line 1674, dualvar)

use strict;
use warnings;
use Devel::Peek;
use Inline Config => clean_after_build => 0;
use Inline C => <<'EOC';
        // alter the 'numeric' slot of existing var 'asv' with that of
+ 'theiv'
    void setIV(SV *asv, SV *theiv){
        (void)SvUPGRADE(asv, SVt_PVNV);
        SvIV_set(asv, SvIV(theiv));
        SvIOK_on(asv);
    }
        // alter the 'string' slot of existing var 'asv' with that of 
+'thesv'
    void setSV(SV *asv, SV *thesv){
        sv_setsv(asv, thesv);    
    } 
EOC

my $num = 42;
my $x = "My name is Ace!";
Dump($x);

setIV($x, $num);
Dump($x);
setSV($x, "Hello Ozy!");
Dump($x);

# and here is a one-legged Schwartzian transform
# to sort strings on their lengths using above XS:
my @unsorted = ("Just", "another", "Perl\x{7}\x{7}\x{7}", "hacker\x{7}
+");
my @sorted = sort { $a <=> $b }
    map { setIV($_, length($_)); $_ } @unsorted;
print "Sorted: @sorted\n";
;
[download]

Hacking away with Perl into the new year ... (actually I think I am in 2048 already, riding on Perl)

bw, bliako

I've long found it fun to implement the same algorithm in different languages, especially Perl and C++ ... and then sit back and reflect on the lessons learned ... so when Long list is long appeared recently, I felt it was short and interesting enough to make an excellent Rosetta code node.

Solutions to this problem must read a number of input LLiL-format files (given as command line arguments) and write a single merged LLiL-format file to stdout. The LLiL-format is described in the comments at the top of llil.pl below.

In the interests of keeping the code as short and fast as possible, you may assume the input LLiL files are well-formed. For example, you don't need to check for and remove leading and trailing whitespace on each line. The sample solutions given below in Perl and C++ should clarify program requirements.

Please feel free to respond away with solutions to this problem in your favourite programming language and to offer suggested improvements to my sample Perl and C++ solutions below.

Perl Solution

Here's my Perl solution, heavily influenced by responses to Long list is long, especially kcott's concise and clear solution:

# llil.pl
# Example run: perl llil.pl tt1.txt tt2.txt >oo1.tmp

use strict;
use warnings;

# --------------------------------------------------------------------
+--
# LLiL specification
# ------------------
# A LLiL-format file is a text file.
# Each line consists of a lowercase name a TAB character and a non-neg
+ative integer count.
# That is, each line must match : ^[a-z]+\t\d+$
# For example, reading the LLiL-format files, tt1.txt containing:
#   camel\t42
#   pearl\t94
#   dromedary\t69
# and tt2.txt containing:
#   camel\t8
#   hello\t12345
#   dromedary\t1
# returns this hashref:
#   $hash_ret{"camel"}     = 50
#   $hash_ret{"dromedary"} = 70
#   $hash_ret{"hello"}     = 12345
#   $hash_ret{"pearl"}     = 94
# That is, values are added for items with the same key.
#
# To get the required LLiL text, you must sort the returned hashref
# descending by value and insert a TAB separator:
#   hello\t12345
#   pearl\t94
#   dromedary\t70
#   camel\t50
# To make testing via diff easier, we further sort ascending by name
# for lines with the same value.
# --------------------------------------------------------------------
+--

# Function get_properties
# Read a list of LLiL-format files
# Return a reference to a hash of properties
sub get_properties
{
   my $files = shift;    # in:  reference to a list of LLiL-format fil
+es
   my %hash_ret;         # out: reference to a hash of properties
   for my $fname ( @{$files} ) {
      open( my $fh, '<', $fname ) or die "error: open '$fname': $!";
      while (<$fh>) {
         chomp;
         my ($word, $count) = split /\t/;
         $hash_ret{$word} += $count;
      }
      close($fh) or die "error: close '$fname': $!";
   }
   return \%hash_ret;
}

# ----------------- mainline -----------------------------------------
+--

@ARGV or die "usage: $0 file...\n";
my @llil_files = @ARGV;

warn "llil start\n";
my $tstart1 = time;
my $href    = get_properties( \@llil_files );
my $tend1   = time;
my $taken1  = $tend1 - $tstart1;
warn "get_properties : $taken1 secs\n";

my $tstart2 = time;
for my $key ( sort { $href->{$b} <=> $href->{$a} || $a cmp $b } keys %
+{$href} ) {
   print "$key\t$href->{$key}\n";
}
my $tend2  = time;
my $taken2 = $tend2 - $tstart2;
my $taken  = $tend2 - $tstart1;

warn "sort + output  : $taken2 secs\n";
warn "total          : $taken secs\n";
[download]

What makes this problem interesting to me is the requirement to sort the hash in descending order by value:

sort { $href->{$b} <=> $href->{$a} || $a cmp $b } keys %{$href}
[download]

I'm hoping solving this problem in multiple languages will be fun and instructive -- and perhaps give us insight into how performance changes as the number of items increases.

Greetings, all

The following is a glimpse of what's coming for MCE. There are two new modules; MCE::Semaphore and MCE::Simple. I completed the code tonight. Now, I need to finish the docs and more testing before releasing on Meta::CPAN.

MCE Simple

use MCE::Simple -strict, max_workers => 4;

MCE::Simple->init(
    # mce options
    user_begin => sub {
        MCE->say("hello from ", MCE->wid);
    },
    # spawn options
    on_finish => sub {
        my ( $pid, $exit, $ident, $signal, $error, @ret ) = @_;
        say "@_";
    },
);

mce_foreach my $i ( 1..10 ) {
    MCE->say(MCE->wid, ": $i * 2 = ", $i * 2);
}

spawn "Hello", sub { "one" };
spawn "There", sub { "two" };

foreach my $ident (qw/foo baz/) {
    spawn $ident, sub {
        my $text = "something from $$";
    };
}

sync;

# clear or set options
MCE::Simple->init();

sub fib {
    my $n = shift;
    return $n if $n < 2;

    spawn my $x = fib($n - 1);
    spawn my $y = fib($n - 2);

    sync $x;
    sync $y;
 
    return $x + $y;
}

say "fib(20) = ", fib(20);
[download]

Output

$ perl demo.pl 
hello from 1
hello from 2
hello from 3
hello from 4
3: 2 * 2 = 4
4: 1 * 2 = 2
2: 3 * 2 = 6
3: 5 * 2 = 10
4: 6 * 2 = 12
1: 4 * 2 = 8
4: 7 * 2 = 14
3: 8 * 2 = 16
2: 9 * 2 = 18
1: 10 * 2 = 20
10792 0 Hello 0  one
10793 0 There 0  two
10794 0 foo 0  something from 10794
10795 0 baz 0  something from 10795
fib(20) = 6765
[download]

MCE Semaphore

A fast pure-Perl implementation. Testing involves big number. Notice the mce_foreach_s keyword, for processing a sequence of numbers.

use MCE::Simple -strict, max_workers => 16;

use MCE::Semaphore;
use Time::HiRes 'time';

my $start = time;
my $sem = MCE::Semaphore->new(8);

mce_foreach_s ( 1 .. 1_000_000 ) {
    $sem->down;
    $sem->up;
}

printf "%0.3f seconds\n", time - $start;
[download]

Input file

mce_foreach_f ("/path/to/file") {
    MCE->print($_);
}

# what about file handles? no problem...
open my $fh, "<", "/tmp/infile.txt" or die "open error: $!";

mce_foreach_f my $line ( $fh ) {
    MCE->print($line);
}

close $fh;
[download]