If you're new here please read PerlMonks FAQ and Create a new user.
Supplications
|
qq? with regards to Regexp::Grammars
2 direct replies — Read more / Contribute
|
by Anonymous Monk
on Jul 04, 2022 at 17:06
|
|
#! /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 @!;
}
}
Thanks!
|
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?
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");
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 ="";
}
output
((( STDOUT :::
1
2
))) STDOUT :::
((( STDOUT :::
1
2
3
))) STDOUT :::
((( STDOUT :::
1
2
))) STDOUT :::
exit by EOF
update
found this
Bidirectional Communication with Another Process
doesn't seem to be overly portable and I doubt run3 is the solution...
|
Challenge: Perl::Tidy subprocess for faster formatting
1 direct reply — Read more / Contribute
|
by LanX
on Jul 03, 2022 at 10:47
|
|
Hi
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__
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.
|
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
|
|
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,
-Richard
|
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
|
|
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 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.
|
|
|
|