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!

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]

How do we have CLI of Perl's sed's n command ?
e.g. illustration:

cat script.txt| perl -nle 'if (/^===\w+\s*$/){ next # ??? how to ignor
+e first $_, here eg. ===Hello, to directly become replaced by next li
+ne ; # ... } print'
[download]

Just a note to say how much fun it was for me to try the Test::Compile::Internal module, which zips through every Perl module and script in my cgi-bin directory and its subdirectories, making sure each such file successfully compiles.

This lets me feel more at ease about there not being any lurking problems that have arisen due to my having renamed or deleted some custom module, and that scripts or modules I'm still developing haven't "use"d a module and its specified subroutines (whether custom or in my Perl libraries) in a way that misspelled the module name or the subroutine name, or that tries to import a subroutine that doesn't actually exist in the "use"d module (such as a subroutine I meant to add to a "use"d custom module but never got around to adding).

#!/opt/perl524

use strict;
use warnings;

use Test::Compile::Internal;

my $test = Test::Compile::Internal->new();

$test->all_files_ok( '/www/cgi-bin' );

$test->done_testing();
[download]

This article has also been posted on blogs.perl.org here.

Moose is great, but it does introduce a slight performance hit to your code. In the more than 15 years since it was first released, hardware improvements have made this less of a problem than it once was. Even so, if performance is a concern for your project, Moose might not be what you want. It also has a fairly big collection of non-core dependencies.

Moo is a lighter weight version, minus with meta-object protocol, but supporting nearly all of Moose's other features. It loads faster, sometimes runs faster, and has fewer dependencies. (And most of the dependencies it does have are just modules which used to be part of Moo but were split out into separate distributions.)

But what if you could have fast Moose-like object-oriented code without the dependencies?

In 2013, Michael Schwern started work on Mite to do just that. It was abandoned in 2014, but I've taken it over and expanded the feature set to roughly equivalent to Moo.

Mite is an object-oriented programming compiler for Perl. It allows you to write familiar Moose-like object-oriented code, then compile that into plain Perl with zero non-core dependencies. Your compiled code does not even have a dependency on Mite itself!

How do I use Mite?

Here's how you could start a project with Mite or port an existing Moose/Moo project.

   cd Your-Project/
   mite init 'Your::Project'
   mite compile

After you've run those commands, Mite will create a module called Your::Project::Mite. This module is your project's own little gateway to Mite. This module is called the shim.

Now let's write a test case:

   # t/unit/Your-Project-Widget.t
   use Test2::V0
      -target => 'Your::Project::Widget';
   
   can_ok( $CLASS, 'new' );
   
   my $object = $CLASS->new( name => 'Quux' );
   isa_ok( $object, $CLASS );
   
   subtest 'Method `name`' => sub {
      can_ok( $object, 'name' );
      is( $object->name, 'Quux', 'expected value' );
      
      my $e = dies {
         $object->name( 'XYZ' );
      };
      isnt( $exception, undef, 'read-only attribute' );
   };
   
   subtest 'Method `upper_case_name`' => sub {
      can_ok( $object, 'upper_case_name' );
      is( $object->upper_case_name, 'QUUX', 'expected value' );
   };
   
   done_testing;

And a class to implement the functionality:

   # lib/Your/Project/Widget.pm
   package Your::Project::Widget;
   use Your::Project::Mite;
   
   has name => (
      is     => 'ro',
      isa    => 'Str',
   );
   
   sub upper_case_name {
      my $self = shift;
      return uc( $self->name );
   }
   
   1;

Run mite compile again then run the test case. It should pass.

How does Mite work?

It's important to understand what Mite is doing behind the scenes.

When you ran mite compile, Mite created a file called lib/Your/Project/Widget.pm.mite.pm. (Yes, a triple file extension!) This file contains your class's new method. It contains the code for the accessor.

That file does not contain the code for upper_case_name which is still in the original lib/Your/Project/Widget.pm.

When Perl loads Your::Project::Widget, it will see this line and load the shim:

   use Your::Project::Mite;

The shim just loads lib/Your/Project/Widget.pm.mite.pm, exports a has function that does (almost) nothing, and then gets out of the way. This gives Perl a working class.

What features does Mite support?

Most of what Moo supports is supported by Mite. In particular:

extends @superclasses

Mite classes within your project can inherit from other Mite classes within your project, but not from non-Mite classes, and not from Mite classes from a different project.

with @roles

As of version 0.002000, Mite also supports roles. If you want your package to be a role instead of a class, just do:

   package Your::Project::Nameable;
   use Your::Project::Mite -role;
   has name => (
      is => 'ro',
      isa => 'Str',
   );
   1;

As with extends, a limitation is that you can only use Mite roles from within your own project, not non-Mite roles, nor Mite roles from a different project.

(A future development might add support for Role::Tiny roles though.)

has $attrname => %spec

Attributes are obviously one of the main features people look for in a Perl object-oriented programming framework and Mite supports nearly all of Moose's features for defining attributes.

This includes is => 'ro', is => 'rw', is => 'bare', is => 'rwp' (like Moo), and is => 'lazy' (like Moo); required and init_arg for attribute initialization; reader, writer, accessor, predicate, clearer, and trigger; lazy, default, and builder; weak_ref; isa and coerce for type constraints, including support for any type constraints in Types::Standard, Types::Common::Numeric, and Types::Common::String; and delegation using handles. It also supports an option which Moose doesn't provide: alias for aliasing attributes.

Mite builds in the functionality of MooseX::StrictConstructor, dying with an appropriate error message if you pass your class's constructor any parameters it wasn't expecting.

BUILDARGS, BUILD, and DEMOLISH

Methods you can define to control the life cycle of objects.

before $method => sub { ... }

after $method => sub { ... }

around $method => sub { ... }

Mite classes and roles can define method modifiers.

As long as your needs aren't super-sophisticated (introspection using the MOP, runtime application of roles, etc), Mite probably has the features you need for even medium to large projects.

Mite itself uses Mite!

Be honest, what are the drawbacks?

This code still doesn't have a lot of testing "in the wild". Moose and Moo have proven track records.

You need to remember to mite compile your code after making changes before running your test suite or packaging up a release. This can be annoyingly easy to forget to do. (Though Mite does also include extensions for ExtUtils::MakeMaker and Module::Build to help integrate that into your workflow.)

The Mite compiler's scope of only looking at the files within your own project limits the ability to create roles which can be composed by third-parties, or classes which can easily be extended by third-parties. If you want that, Moose or Moo are a better option.

Okay, I'm interested

If you've read this and you're thinking about porting a Moose or Moo project to Mite, feel free to @-mention tobyink on Github in issue tickets, pull requests, etc if you need any help.

If there are features which you think Mite is missing which you'd need to port your project to Mite, file bugs with the Mite issue tracker.