Pray tell, what does the "pp?" in the following Regexp::Grammar example do/mean? Searching the docs only turns up Tracking and reporting match positions.

#! /usr/bin/perl

use strict;
use warnings;
use 5.010;
use Regexp::Grammars;

my $grammar = qr{

    <delimited_text>

    <token: delimited_text>
        qq? <delim> <text=(.*?)> </delim>
    |   <matchpos> qq? <delim>
        <error: (?{"Unterminated string starting at index $MATCH{match
+pos}"})>
    <token: delim>  [[:punct:]]++

}x;

use IO::Prompter;

while (my $input = prompt) {
    if ($input =~ $grammar) {
        use Data::Show;
        show %/;
    }
    else {
        say 'Failed: ';
        say for @!;
    }
}
[download]

Thanks!

Input:
Date|Amount|Category|Description
2022-06-23|123.45|Software & Tech|BACKBLAZE HTTPSWWW.BACKCA|
2022-06-24|63.45|Internet|RECURRING PAYMENT AUTHORIZED ON 06/11 SPECTR
+UM TX|
2022-06-24|69.34|Phone|RECURRING PAYMENT AUTHORIZED ON 06/02 VZWRLSS*A
+POCC VISE|
(Max widths 10,6,15,55)

Simple expansion
Date      |Amount|Category       |Description                         
+                    |
2022-06-23|123.45|Software & Tech|BACKBLAZE HTTPSWWW.BACKCA           
+                    |
2022-06-24|63.45 |Internet       |RECURRING PAYMENT AUTHORIZED ON 06/1
+1 SPECTRUM TX       |
2022-06-24|69.34 |Phone          |RECURRING PAYMENT AUTHORIZED ON 06/0
+2 VZWRLSS*APOCC VISE|
(Col widths 10,6,15,55)

Shrunk to fit 52-char-wide window
Date      |Amount|Category       |Description      |
2022-06-23|123.45|Software & Tech|BACKBLAZE HTTPSWW|
2022-06-24|63.45 |Internet       |RECURRING PAYMENT|
2022-06-24|69.34 |Phone          |RECURRING PAYMENT|
(Col widths 10,6,15,17)

Shrunk to fit 46-char-wide window
Date      |Amount|Category     |Description  |
2022-06-23|123.45|Software & Te|BACKBLAZE HTT|
2022-06-24|63.45 |Internet     |RECURRING PAY|
2022-06-24|69.34 |Phone        |RECURRING PAY|
(Col widths 10,6,13,13)
[download]

I'd appreciate any comments or suggestions for a simpler algorithm (for one thing, I don't think making it recursive helped any). I'd be particularly intrested in solutions that exeercise v5.36 features.

#!/usr/bin/env perl
use v5.36; # implies use warnings

my $target_weight = shift // die 'need target_weight';

# Starting weights
my @weights = ( 20, 3, 25, 10, 3, 24, 25 );

say "Before:\n" . display( \@weights );
shrink( \@weights, $target_weight );
say "After:\n" . display( \@weights );

# shrink($bags, $target_weight)
#
# $bags = ref. to array of bag weights
# $target_weight = maximum allowed weight of all bags
#
# If bags exceed target_weight, lighten the bags to achieve target by
# lightening the heaviest bags first.

no warnings q/experimental::for_list/;
no warnings q/experimental::builtin/;
use builtin    qw/indexed/;
use List::Util qw/sum/;

sub shrink ( $bags, $target_weight, $curr_weight = undef ) {

    # Outer call only:
    if ( not defined $curr_weight ) {
        $curr_weight = sum @$bags;
        # quick exit if no shrink req'd
        return if ( $curr_weight <= $target_weight );

        # copy input array and sort by weight, descending
        my @indexed_weights;
        for my ( $i, $wt ) ( indexed @$bags ){
            push @indexed_weights, [ $i, $wt ];
        }
        @indexed_weights = sort { $b->[1] <=> $a->[1] }
            @indexed_weights;
        # split indexes and weights into two arrays
        my @sorted_indexes = map { $_->[0] } @indexed_weights;
        my @sorted_weights = map { $_->[1] } @indexed_weights;
        say "Sorted:\n" . display( \@sorted_weights );

        shrink( \@sorted_weights, $target_weight, $curr_weight );

        # Deliver de-sorted result to caller
        for my ( $i, $wt ) ( indexed @sorted_weights ) {
            $bags->[ $sorted_indexes[$i] ] = $wt;
        }
        return;
    }

    # For inner call:
    return if ( $curr_weight <= $target_weight );

    my $nbags    = scalar @$bags;
    my $heaviest = $bags->[0];      # weight of heaviest bag

    # Count the heaviest bags and also find the next-heaviest
    my $n_of_heaviest;
    my $next_heaviest;
  COUNT:
    for ( 1 .. $nbags - 1 ) {
        if ( $bags->[$_] < $heaviest ) {
            $n_of_heaviest = $_;
            $next_heaviest = $bags->[$_];
            last COUNT;
        }
    }
    $n_of_heaviest //= $nbags;
    $next_heaviest //= 0;

    my $loss       = $heaviest - $next_heaviest;
    my $total_loss = $loss * $n_of_heaviest;
    if ( $curr_weight - $total_loss >= $target_weight ) {
        $curr_weight -= $total_loss;
        $bags->[$_]  -= $loss for ( 0 .. $n_of_heaviest - 1 );
        say "Reduce bags #0-#"
            . ( $n_of_heaviest - 1 )
            . " by $loss to weight of next_heaviest, "
            . "$next_heaviest:\n"
            . display($bags);
        shrink( $bags, $target_weight, $curr_weight );
    }
    else {
        # Need to do an equally-distributed shrink of the heaviest
        # bags to hit the target
        use integer;
        my $target_loss = $curr_weight - $target_weight;
        my $div         = $target_loss / $n_of_heaviest;
        my $rem         = $target_loss % $n_of_heaviest;
        for my $i ( -( $n_of_heaviest - 1 ) .. 0 ) {
            $loss = $div + ( $rem-- > 0 ? 1 : 0 );
            $bags->[ -$i ] -= $loss;
        }
        say "Finally, reduce bags #0-#"
            . ( $n_of_heaviest - 1 )
            . " to target weight of $target_weight:\n"
            . display($bags);
    }
}

sub display ($aref) {
    my $r = '';
    for my ( $i, $wt ) ( indexed @$aref ) {
        $r .= sprintf "%2s: %s (%d)\n", "#$i", ( '-' x $wt ), $wt;
    }
    $r .= sprintf "Weight %d, target %d\n",
        sum(@$aref), $target_weight;
    return $r;
}
[download]

~/private/perl$ shrink 100
Before:
#0: -------------------- (20)
#1: --- (3)
#2: ------------------------- (25)
#3: ---------- (10)
#4: --- (3)
#5: ------------------------ (24)
#6: ------------------------- (25)
Weight 110, target 100

Sorted:
#0: ------------------------- (25)
#1: ------------------------- (25)
#2: ------------------------ (24)
#3: -------------------- (20)
#4: ---------- (10)
#5: --- (3)
#6: --- (3)
Weight 110, target 100

Reduce bags #0-#1 by 1 to weight of next_heaviest, 24:
#0: ------------------------ (24)
#1: ------------------------ (24)
#2: ------------------------ (24)
#3: -------------------- (20)
#4: ---------- (10)
#5: --- (3)
#6: --- (3)
Weight 108, target 100

Finally, reduce bags #0-#2 to target weight of 100:
#0: ---------------------- (22)
#1: --------------------- (21)
#2: --------------------- (21)
#3: -------------------- (20)
#4: ---------- (10)
#5: --- (3)
#6: --- (3)
Weight 100, target 100

After:
#0: -------------------- (20)
#1: --- (3)
#2: ---------------------- (22)
#3: ---------- (10)
#4: --- (3)
#5: --------------------- (21)
#6: --------------------- (21)
Weight 100, target 100
[download]

How do I implement the following, including catching stdout and stderr with run3?

the docs claim

compared to system(), qx'', open "...|", open "|..."

... BUT ...

Note that this form of redirecting the child's I/O doesn't imply any form of concurrency between parent and child - run3()'s method of operation is the same no matter which form of redirection you specify.

I'm confused, is it even possible to have a bidirectional communication between two simultaneously running processes with run3?

If not what's the appropriate solution?

client.pl

use v5.12;
use warnings;
use IPC::Run3;


my ($cmd, $in, $out, $err);

$cmd = 'perl ./server.pl';


open my $fh_in,"|-", $cmd;

#my @in;
#run3($cmd, \@in);

sub out {
    $fh_in->say(@_);
}


my $doit;

for my $try (2,3,2) {
    $doit = "$;" x $try;
    out($doit);
    out($_) for 1..$try;
    out($doit);
}

out("EOF");
[download]

server.pl

use v5.12;
use warnings;

STDOUT->autoflush;
my $doit;
my $input;

while ( my $line = <STDIN> ) {
    unless ( defined $doit ){
        $doit = $line;
        last if $doit eq "EOF";
        next;
    }

    if ($line eq "$doit") {
        doit();
        undef $doit;
    } else {
        $input .= $line;
    }
}

say "exit by $doit";
exit;

sub doit {
    print "((( STDOUT ::: $doit";
    print $input;
    print "))) STDOUT ::: $doit";
    #warn "STDERR:",$input," ";
    $input ="";
}
[download]

output

((( STDOUT ::: 
1
2
))) STDOUT ::: 
((( STDOUT ::: 
1
2
3
))) STDOUT ::: 
((( STDOUT ::: 
1
2
))) STDOUT ::: 
exit by EOF
[download]

update

found this

Bidirectional Communication with Another Process

doesn't seem to be overly portable and I doubt run3 is the solution...

for many years now many IDEs offer to run code-snippets thru perltidy in a launched sub-process.

But this comes with noticeable delay, because most of the time is lost for startup of perltidy, while Perl::Tidy offers a server mode.

A faster tidying would allow formatting on-the-fly on key-triggers, like when typing return or closing a sub.

Proof

The following code is formatting itself 1,10 and 100 times thru perltidy, and an average run takes less than 0,07 secs

Challenge

• Write an IDE solution which starts a constant Perltidy server-process in the background and sends code-snippets back and forth.

Possible technologies

• comint-mode in emacs
• Language server protocol plugin for various IDEs (reference implementation Visual Studio Code)
• ... whatever your favourit IDE

Extra Points

• implement a GUI to try out perltidy configs on the fly, be it in Tk or inside an IDE.

demo code

use v5.12;
use warnings;
use Perl::Tidy;
use Time::HiRes qw/time/;

seek DATA,0,0;
my $code = join "",<DATA>;
#say $code;

my $show;


my $rc = <<'__CFG__';
--indent-columns=4
--maximum-line-length=80
--variable-maximum-line-length
--whitespace-cycle=0
__CFG__


time_it();


sub time_it {
    for my $times (1,10,100) {
        my $start=time;
        run_it() for 1..$times;
        my $end =time;
        warn "$times took: ", ($end-$start);
    }

}


sub run_it {
    my $clean;
    my $stderr;

    my $error = Perl::Tidy::perltidy
      (
       source      => \$code,
       destination => \$clean,
       stderr      => \$stderr,
       perltidyrc  => \$rc,
      );

    return unless $show;
    say $code;
    say '--------';
    if ($error) {
        say 'ERROR';
        say $stderr;
    } else {
        say $clean;
    }

}

__DATA__
[download]

1 took: 0.0720160007476807 at c:/tmp/pm/my_tidy.pl line 29, <DATA> lin
+e 59.
10 took: 0.643707036972046 at c:/tmp/pm/my_tidy.pl line 29, <DATA> lin
+e 59.
100 took: 6.37499022483826 at c:/tmp/pm/my_tidy.pl line 29, <DATA> lin
+e 59.
[download]

Hello wise ones!

I'm looking to have users of my Web CGI script upload images using a form in their browser, and then prompt the users to crop whatever they upload to be square and no more than 600pixels in any dimension. I have no idea of any tools or modules I can use to do so.

Any advice? Thanks in advance!

I have a task that can be best summarized by the keywords in the title, and I wonder if there is a somewhat ready-made solution, preferably in Perl, that I've overlooked.

I have a set of points in a plane (originally coordinates of known features in an image), in two versions: one from a reference version of the image, the other from a distorted and warped version of the same image. The points themselves belong to two subsets: for the first subset, let's call them "known" points, I know the coordinates from both images, and for the second subset, "target" points, I know their coordinates only from the reference image. What I want is to determine the coordinates of these "target" points, based on the transformation determined by the corresponding "known" points.

Maybe I'm not looking right, but I haven't found anything besides Imagemagick, dodgy Matlab recipes and a bunch of research articles.

UPDATE:

Here are some example datasets. Columns are x, y, name. Points named p01..p12 are the "known" points, or the red points from the image downthread, q01..q05 are the "target" or blue points.

And here is an explanatory drawing, repeated for visibility: https://imgur.com/KxH62Sa

Each labeled red point from the reference image corresponds to the same labeled red point on the distorted image. And I know the coordinates for both. Similarly, one blue point on the reference image corresponds to one blue point on the distorted image, but I only know their coordinates on the reference, and I want to find them on the other.

Let's assume I have a module which needs 3 import parameters.

package My::Test;

use strict;
use warnings;

use Carp;

sub import
{
    my $class = shift;
    croak "Number of import parameters is wrong, stopped " unless @_ =
+= 3;
    # ...
}

1;
[download]

The good case I can check with use_ok. But the bad cases are my problem, e.g. use this class with less than 3 parameters.

use My::Test "Param1", "Param2"; # dies because it are 2 params and no
+t 3 as expected
[download]

I want to test that this exception was thrown and I also want to check its error message for correctness. Usually I use throws_ok for this. But in this case it doesn't work because the use command is at compile time. I have no idea how to test for this exception.

Thanks for your help!

use DBI;
use strict;
use warnings;

my $driver= "mysql";
my $dsn = "DBI:$driver:database=$database;host=$host";
my $dbh = DBI->connect($dsn, $user, $pw);
$dbh->do('INSERT INTO test_table (fname, lname, email, comment) VALUES
+ (?, ?, ?, ?)',
    undef,
    $fname, $lname, $email, $comment);
[download]

i am writing a code where i have to find version associated with the name from a file. i am trying below code but the pattern match is not working. the file /home/test.txt contains multiple entries like below:

Anls/01.00/windows
abc/02.00/windows
core/03.00/windows
route/04.00/windows
.
.
.
[download]

my $file = "/home/test.txt";
        if (-e $file) {
            my @list = ("Anls", "core", "route");
            open(FH, '<', $file) or die $!;
            foreach my $x (@list) {
                while(<FH>){
                  my $pattern;
                  if (defined($pattern) && ($pattern =~ /$x\/(.*)\/(.*
+)/)) {
                      my $version = $1;
                      print "$x: $version\n";
                  }
                }
            }
            close(FH);
        }
[download]