Beefy Boxes and Bandwidth Generously Provided by pair Networks
more useful options

The Monastery Gates

( #131=superdoc: print w/replies, xml ) Need Help??

If you're new here please read PerlMonks FAQ
and Create a new user.

poll ideas quest 2022
Starts at: Jan 01, 2022 at 00:00
Ends at: Dec 31, 2022 at 23:59
Current Status: Active
4 replies by pollsters
    First, read How do I create a Poll?. Then suggest your poll here. Complete ideas are more likely to be used.

    Note that links may be used in choices but not in the title.

Perl News
Admins for RT
on Jul 05, 2022 at 15:02
1 reply by hippo

    TPF is calling for volunteers to assist with the administration of, specifically to help with keeping it free from spam. If you have the necessary time, skill and inclination please consider supporting this.


Recordings for TPC 2022 in Houston
on Jun 27, 2022 at 06:12
0 replies by LanX
qq? with regards to Regexp::Grammars
2 direct replies — Read more / Contribute
by Anonymous Monk
on Jul 04, 2022 at 17:06

    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 @!; } }


Algorithm to reduce the weight of a collection of bags
3 direct replies — Read more / Contribute
by ibm1620
on Jul 04, 2022 at 16:10
    I am writing a tool to expand a CSV file to a columnar format, with each column sized to accommodate the max width encountered in the file. That's easily done with two passes. But now I want to narrow the columns so that each record fits on one line in the terminal, at the expense of truncating some wide values. For example:
    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)
    I recast the problem as an ordered set of bags whose contents vary in weight, and removing enough from the bags so they don't exceed some total weight. Furthermore, I want to penalize the heaviest bags first. I coded up a working solution (trying to use as many v5.36 features as I could). But I can't get over the feeling that there is a much simpler solution that's eluded me.

    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; }
    Shrink to 100:
    ~/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
Concurrency with IPC::Run3 ?
1 direct reply — Read more / Contribute
by LanX
on Jul 03, 2022 at 18:10
    Pardon my ignorance, but I have trouble understand the docs of IPC::run3

    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?
    use v5.12; use warnings; use IPC::Run3; my ($cmd, $in, $out, $err); $cmd = 'perl ./'; 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");
    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 =""; }

    ((( STDOUT :::  1 2 ))) STDOUT :::  ((( STDOUT :::  1 2 3 ))) STDOUT :::  ((( STDOUT :::  1 2 ))) STDOUT :::  exit by EOF


    found this

    Bidirectional Communication with Another Process

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

    Cheers Rolf
    (addicted to the Perl Programming Language :)
    Wikisyntax for the Monastery

Challenge: Perl::Tidy subprocess for faster formatting
1 direct reply — Read more / Contribute
by LanX
on Jul 03, 2022 at 10:47

    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.


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

    • 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__

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

    Cheers Rolf
    (addicted to the Perl Programming Language :)
    Wikisyntax for the Monastery

Image Uploader that Sizes the Photo Like An Avatar
4 direct replies — Read more / Contribute
by Anonymous Monk
on Jul 03, 2022 at 08:27

    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!

Testing of exception during import
4 direct replies — Read more / Contribute
by Dirk80
on Jul 01, 2022 at 10:09

    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;

    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

    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!

DBI mysql router mysqlrouter cluster
2 direct replies — Read more / Contribute
by RedJeep
on Jun 30, 2022 at 15:07
    Hello friends, I am exploring using MySQL cluster with MySQL router with Perl 5. I have not been able to find any information on how to modify my database interface in Perl to connect to a cluster. Have any of you done this? My objective is for both fail over and scaling. Here is my existing code for how I connect to MySQL. Currently, this is just a single instance of MySQL.
    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);
    The above works fine. My hope is that MySQL clustering magically lets me use DBI and everything just like above. However, in the literature it seems that I would point my application to a MySQL router (mysqlrouter) instead of directly to the MySQL database. If I should be taking an entirely different direction to clustering for fail over and scaling feel free to let me know. The only requirements for the project are that we stick with Perl 5 and MySQL. Thank you in advance!
Pattern matching in perl
3 direct replies — Read more / Contribute
by noviceuser
on Jun 30, 2022 at 11:12

    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 . . .
    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); }
Send before headers - in perl,
3 direct replies — Read more / Contribute
by bizactuator
on Jun 30, 2022 at 01:32
    I programmed a site in Perl back in 2007, from then until about 2012. I wrote well over 100k lines, maybe 250k lines in over 100 files.

    I cannot remember how I did it, but I remember something about it, isn't there a way to have something execute before the headers?

    Like if we already printed the headers but then need to do something to do before them, I remember I used to have to do that somehow, but I for the life of me cannot find it in my programming, or on here, but I'm pretty sure someone on here helped me with it back then.

    I may not be describing it right, but I think it was for window redirects, when we already had printed header files.
    but I cannot recall for sure.

    Do you know what I'm trying to say? or what I'm talking about?

    Sorry, I got sleep apnea so severe I almost died and it ruined my brain, I cannot recall a lot of things in whole sentences.

    I would appreciate anyone who can understand what I'm trying to say.

    Thank you,
Must have CLI of Perl's sed's n command
3 direct replies — Read more / Contribute
by abdan
on Jun 29, 2022 at 21:38

    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'
Cool Uses for Perl
Bulk check for successful compilation
1 direct reply — Read more / Contribute
by davebaker
on Jul 02, 2022 at 17:16

    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();
Mite: an OO compiler for Perl
No replies — Read more | Post response
by tobyink
on Jul 02, 2022 at 13:34

    This article has also been posted on 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' );

    And a class to implement the functionality:

       # lib/Your/Project/
       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 );

    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/ (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/

    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/, 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',

    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.


    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.

Log In?

What's my password?
Create A New User
Domain Nodelet?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others romping around the Monastery: (4)
As of 2022-07-06 21:44 GMT
Find Nodes?
    Voting Booth?

    No recent polls found