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.
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 @!;
}
}
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;
}
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?
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");
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/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.
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.
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.
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;
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.
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!
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:
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.
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).