Beefy Boxes and Bandwidth Generously Provided by pair Networks
"be consistent"

Seekers of Perl Wisdom

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

If you have a question on how to do something in Perl, or you need a Perl solution to an actual real-life problem, or you're unsure why something you've tried just isn't working... then this section is the place to ask.

However, you might consider asking in the chatterbox first (if you're a registered user). The response time tends to be quicker, and if it turns out that the problem/solutions are too much for the cb to handle, the kind monks will be sure to direct you here.

Post a new question!

User Questions
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!

Abstract image registration or feature detection [UPDATED w examples]
8 direct replies — Read more / Contribute
by kikuchiyo
on Jul 01, 2022 at 10:55

    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.


    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:

    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.

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,

Add your question
Your question:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post, it's "PerlMonks-approved HTML":

  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or or How to display code and escape characters are good places to start.
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 meditating upon the Monastery: (1)
As of 2022-07-06 00:44 GMT
Find Nodes?
    Voting Booth?

    No recent polls found