Beefy Boxes and Bandwidth Generously Provided by pair Networks
laziness, impatience, and hubris
 
PerlMonks  

Cool Uses for Perl

( [id://1044]=superdoc: print w/replies, xml ) Need Help??

This section is the place to post your general code offerings -- everything from one-liners to full-blown frameworks and apps.

CUFP's
Fixing bad CSS in EPUB files
1 direct reply — Read more / Contribute
by jimhenry
on Sep 05, 2023 at 21:02

    Many epubs come with unprofessional CSS that will not display correctly on some ebook readers. For instance, the font size may be illegibly small on a mobile device, or the user may have dark mode turned on, but the CSS specifies element foreground colors according to an assumed (but not specified) white background, so there is little or no contrast with the actual black background. I recently wrote a script to detect epubs with those problems, then one to detect and fix them.

    My first attempt at this used EPUB::Parser, but I soon found that it didn't (as far as I could tell) have the functionality I needed to get at the internal CSS files and edit them. So I fell back on Archive::Zip (which EPUB::Parser uses) -- an epub is a zip file containing css, html, and xml files (and sometimes jpg's, etc.).

    The full code and assocated files
    The documentation

    Here, I present two of the trickier functions; inverse_color() is passed a CSS color value of some kind (which can be a wide array of formats), calculates a complementary color, and returns it. It makes use of functions from Graphics::ColorUtils to map CSS color names to rgb values. It is called by fix_css_colors() when it finds a CSS block containing a color: attribute but no background-color: attribute.

    sub inverse_color { my $color = shift; die "Missing argument to inverse_color()" unless $color; state $color_names; if ( not $color_names ) { #set_default_namespace("www"); $color_names = available_names(); } $color =~ s/^\s+//; $color =~ s/\s+$//; if ( $color =~ /^#[[:xdigit:]]{3}$/ ) { $color =~ s/#//; my $n = hex $color; my $i = 0xFFF - $n; my $inverse = sprintf "#%03x", $i; return $inverse; } elsif ( $color =~ /^#[[:xdigit:]]{6}$/ ) { $color =~ s/#//; my $n = hex $color; my $i = 0xFFFFFF - $n; my $inverse = sprintf "#%06x", $i; return $inverse; } elsif ( $color =~ /rgb \s* \( \s* ([0-9]+) \s* , \s* ([0-9]+) , +\s* ([0-9]+) \s* \) /x ) { my ($r, $g, $b) = ($1, $2, $3); my $n = $r * 65536 + $g * 256 + $b; printf "converted %s to %06x\n", $color, $n if $verbose; my $i = 0xFFFFFF - $n; my $inverse = sprintf "#%06x", $i; return $inverse; } elsif ( $color =~ /rgba \s* \( \s* ([0-9]+) \s* , \s* ([0-9]+) , + \s* ([0-9]+) \s* , \s* ([0-9.]+) \s* \) /x ) { my ($r, $g, $b, $alpha) = ($1, $2, $3, $4); my $inverse = sprintf "rgba( %d, %d, %d, %0.2f )", 255 - $r, 255 - + $g, 255 - $b, 1 - $alpha; return $inverse; } elsif ( $color =~ /hsl \s* \( \s* ([0-9]+) \s* , \s* ([0-9]+)% +, \s* ([0-9]+)% \s* \) /x ) { my ( $hue, $saturation, $lightness ) = ($1, $2, $3); my $hue2 = ($hue + 180) % 360; my $sat2 = 100 - $saturation; my $light2 = 100 - $lightness; my $inverse = sprintf "hsl( %d, %d%%, %d%% )", $hue2, $sat2, $ligh +t2; return $inverse; } elsif ( $color =~ /hsla \s* \( \s* ([0-9]+) \s* , \s* ([0-9]+)% + , \s* ([0-9]+)% \s* , \s* ([0-9.]+) \s* \) /x ) { my ( $hue, $saturation, $lightness, $alpha ) = ($1, $2, $3, $4); my $hue2 = ($hue + 180) % 360; my $sat2 = 100 - $saturation; my $light2 = 100 - $lightness; my $alpha2 = 1 - $alpha; my $inverse = sprintf "hsl( %d, %d%%, %d%%, %0.2f )", $hue2, $sat2 +, $light2, $alpha2; return $inverse; } elsif ( $color =~ /currentcolor/i ) { warn "Should have removed currentcolor in fix_css_colors()"; } elsif ( $color =~ /inherit/i ) { return "inherit"; } elsif ( $color_names->{ "www:". $color} or $color_names->{ $colo +r} ) { my $hexcolor = name2rgb( $color ); if ( not $hexcolor ) { $hexcolor = name2rgb( "www:" . $color ); if ( not $hexcolor ) { die "Can't resolve color name $color"; } } $hexcolor =~ s/#//; my $i = 0xFFFFFF - hex($hexcolor); my $inverse = sprintf "#%06x", $i; return $inverse; } else { die "Color format not implemented: $color"; } } sub fix_css_colors { my ($csstext, $css_fn, $epub_fn) = @_; return if not $csstext; my $errors = 0; my $corrections = 0; my $printed_filename = 0; say "Checking $epub_fn:$css_fn for bad colors\n" if $verbose; # this might be a good use of negative lookbehind? my @css_blocks = split /(})/, $csstext; for my $block ( @css_blocks ) { if ( $block =~ m/color: \s* ( [^;]+ ) \s* (?:;|$) /x ) { my $fgcolor = $1; print "found color: $fgcolor\n" if $verbose; if ( $fgcolor =~ m/currentcolor/i ) { $block =~ s/(color: \s* currentcolor \s* ;? \s* ) \n* //xi; print "Stripping out $1 as it is a pleonasm\n" if $verbose; $corrections++; next; } if ( $block !~ m/background-color:/ ) { my $bgcolor = inverse_color( $fgcolor ); $block =~ s/(color: \s* [^;}]+ \s* (?:;|$) )/background-color: + $bgcolor;\n$1/x; print "corrected block:\n$block\n}\n" if $verbose; $corrections++; } } } if ( $corrections ) { my $new_css_text = join "", @css_blocks; return $new_css_text; } else { return undef; } }
A podcatcher in Perl
5 direct replies — Read more / Contribute
by jimhenry
on Sep 05, 2023 at 20:39

    A while ago I wrote a podcatcher in Perl. In the last few days I've finally gotten around to cleaning it up a bit, finishing the documentation, and getting it out where people can use it (on my website for now -- maybe I'll try to submit it to CPAN at some point).

    The full code (and associated files) can be found at http://jimhenry.conlang.org/software/podcatcher.zip and the documentation (including per-function summaries) at http://jimhenry.conlang.org/software/podcatcher.html

    Here, I'll just briefly discuss one of the functions that gave me some trouble, given the variety of podcast RSS feeds out there and how weirdly (sometimes invalidly) formatted some of them are.

    This function is passed an RSS feed as a single string and attempts to extract the podcast episode URLs from it. First it tries to parse the RSS using XML::RSS::LibXML. Then, if that worked, it tries to find episodes in <enclosure> tags, then if that fails, it tries looking in <media:content> tags. If it failed to parse the RSS file, or if it parsed and failed to find any podcasts in the appropriate tags, it does a brute force regular expression match on the whole RSS file to find anything that starts with http and ends with one of the file extensions we're looking for (which is configurable).

    sub get_mp3_links_from_string { my $pagecontent = shift; my @episodes; my $parser = XML::RSS::LibXML->new; # for some bizarre reason, putting curly brackets around this eval + generates # syntax errors. use q// instead. eval q/ $parser->parse($pagecontent) /; if ( $@ ) { writelog "Could not parse page as XML/RSS: $@\n"; $parser = undef; } if ( $parser ) { foreach my $item (@{ $parser->{items} }) { my $ep; if ( defined $item->{enclosure} ) { if ( $ep = $item->{enclosure}{url} and $ep =~ m!$extension_reg +ex$! ) { push @episodes, { url => $ep }; } elsif ( $ep = $item->{media}{content}{url} and $ep =~ m!$ext +ension_regex$! ) { push @episodes, { url => $ep }; } next if not $ep; } else { next; } if ( $config{description} ) { $episodes[ $#episodes ]->{title} = $item->{title}; $episodes[ $#episodes ]->{description} = $item->{description}; } } # end for each <item> } # end if we have a valid parse unless ( @episodes ) { writelog "Found no $config{extensions} files by parsing XML, check +ing via regex for any $config{extensions} links in any context\n"; my @mp3s = uniq ( $pagecontent =~ m/(http[^\s>]+$extension_re +gex)/gi ); return undef unless ( @mp3s ); foreach ( @mp3s ) { push @episodes, { url => $_ }; } } return \@episodes; # @mp3s; }
MCE Sandbox 2023-08
2 direct replies — Read more / Contribute
by marioroy
on Aug 28, 2023 at 02:03

    The MCE Sandbox repository is where I try writing fast code using Perl MCE + Inline::C, Math::Prime::Util, and the C/C++ libprimesieve library. The demos and examples folders are new for the 2023 update. I learned Codon, a Python-like language that compiles to native code.

    .Inline/ Where Inline::C is configured to cache C object file +s. bin/ algorithm3.pl Practical sieve based on Algorithm3 from Xuedong Luo + [1]. primesieve.pl Calls the primesieve.org C API for generating primes +. primeutil.pl Utilizes the Math::Prime::Util module for primes. demos/ primes1.c Algorithm3 in C with OpenMP directives. primes2.codon Algorithm3 in Codon, a Python-like language. primes3.c Using libprimesieve C API in C primes4.codon Using libprimesieve C API in Codon examples/ Progressive demonstrations. practicalsieve.c single big loop segmentsieve.c segmented variant, faster rangesieve.c process range; start stop prangesieve.c parallel rangesieve in C cpusieve.codon parallel rangesieve in Codon (CPU) gpusieve.codon parallel rangesieve in Codon (GPU) pgpusieve.codon using Codon @par(gpu=True) syntax cudasieve.cu using NVIDIA CUDA Toolkit lib/ Sandbox.pm Common code for the bin scripts. CpuAffinity.pm CPU Affinity support on Linux. src/ algorithm3.c Inline::C code for algorithm3.pl. bits.h Utility functions for byte array. output.h Fast printing of primes to a file descriptor. primesieve.c Inline::C code for primesieve.pl. sandbox.h Header file, includes bits.h, output.h, sprintull.h. sprintull.h Fast base10 to string conversion. typemap Type-map file for Inline::C.
Sending items to the windows recycle bin
1 direct reply — Read more / Contribute
by CrashBlossom
on Aug 11, 2023 at 16:08

    Not very sexy, but it some may find it useful.

    The following code was tested on Window 11 using the 64-bit version of strawberry 5.30.3. It was assembled by extracting the relevant bits from the Win32::FileOp module and making a simple change to account for the fact that I am using a 64-bit version of perl.

    use strict; use warnings; use Win32::API; sub FO_DELETE () { 0x03 } sub FOF_SILENT () { 0x0004 } # don't create progress/report sub FOF_NOCONFIRMATION () { 0x0010 } # Don't prompt the user. sub FOF_ALLOWUNDO () { 0x0040 } # recycle bin instead of delete sub FOF_NOERRORUI () { 0x0400 } # don't put up error UI sub Recycle { # a series of null-terminated pathnames, with a double null at the e +nd my $paths = join "\0", @_, "\0"; my $recycle = new Win32::API('shell32', 'SHFileOperation', 'P', 'I') +; my $options = FOF_ALLOWUNDO | FOF_NOCONFIRMATION | FOF_SILENT | FOF_ +NOERRORUI; # for everything except paths and options, pack with Q (rather than +L), since we're using 64-bit perl # my $opstruct = pack ('LLpLILLL', 0, FO_DELETE, $paths, 0, $options +, 0, 0, 0); my $opstruct = pack ('QQpQIQQQ', 0, FO_DELETE, $paths, 0, $options, +0, 0, 0); return $recycle->Call($opstruct); } my $file = "C:\\Users\\James\\fish"; my $rc = Recycle($file); print "RC: $rc\n";

    Return codes are described here:

    https://learn.microsoft.com/en-us/windows/win32/debug/system-error-codes--0-499-

Imagecat - show color images in a terminal
5 direct replies — Read more / Contribute
by cavac
on Jun 28, 2023 at 08:26

    A few days ago a played around with displaying (color) ASCII art in a Terminal in Re: 80x25 ASCII text art in terminal, because harangzsolt33 peaked my interest. i mentioned that it should be possible to display low res color images in the text console as well and that i would look into it if someone was interested.

    Turns out, the first interested party was myself. Literally a couple of hours after i posted, i had to sort through some PNG icons through an SSH connection. "Instead of downloading the folder, opening the files locally and finding the correct icon, wouldn't it be nice to just display a low res version in my terminal?". Yes, i know there are technically a few other tools that can already do this. But i decided i wanted a Perl version, so that i can easily customize it to my liking. I wanted to build it in a way that it ONLY uses very basic ANSI colors, to support as many color terminals as possible (and as long as they support Unicode).

    So, i created imagecat:

    Had a slight problem posting the original code to PerlMonks. The while @shades initialization is a single line in my original code, but PM refused to show Unicode in code tags. Basically, this is what it should look like (that is, unless there are more PM rendering bugs):

    my @shades = (' ', '░', '▒', '▓', '█');
    

    Yes, this could be improved with using full RGB colors and 2 "pixels" per character using something like 'Upper half block ▀' for a higher resolution. But for now, i just wanted to learn if i can do a version with much more basic color support. HSV color mapping is a strange beast... Edit: I wrote the full color, double-vertical resolution imagecat2, see my post below.

    PerlMonks XP is useless? Not anymore: XPD - Do more with your PerlMonks XP
Interactive or assisted data cleansing of public budget data
1 direct reply — Read more / Contribute
by fishy
on May 04, 2023 at 10:59
    Problem

    As they were created and maintained manually, over the years the descriptions of each code of the economic classification of expenditures and revenues were becoming polluted. For example, for one year the description for code 20 is "Automotive repairments", for other year the same code has "Auto repairs", for other year it has "Vehicle maintenance", and so on. Although most of the time the descriptions match, there are differences between years. Not just word differences, also abbreviations, accents, lower-uppercase, blanks, etc...

    Unfortunately, all the values for one field (column) are composed of the concatenation of the code and the description, e.g. "20.- Vehicle maintenance". There aren't two separate fields for code and description. This way, it is hard to create pivot tables and such things by people who don't know how to program.

    Task

    Normalize the values (strings composed of code and description) of a specific field. Write a program showing to the user all the codes for which the associated description differ between years. Also, as a suggestion present the most recent (by year) code+description string (assuming it is the "best", more accurate, more descriptive, ...). Let the user interactively choose from all the options shown or introduce a new description.
    Once finished, write out a CSV file with just one column containing the normalized values. This file can then be used to easily replace the whole column in the original input CSV file by using a spreadsheet app, like LibreOffice Calc or MS Excel.

    Example session (target column 12):

    $ raku clean_class.raku -t=12 PPP_INC_2014-2021_Liq_20230424.csv Read rows: 4139 WARNING: unexpected separator: 1 WARNING: empty txt: 1 Processed rows: 4139 1. Impost sobre la renda 2021 2. Sobre la renda 2014 2015 2016 2017 2018 2019 2020 [code: 10 remaining: 12] Which one (1-2)[1]: 1. Sobre transmissions patrimonials i actes jurídics documentats 2014 2015 2016 2017 2018 2019 2020 2. Transmissions patrimonials i actes jurídics documentats 2021 [code: 20 remaining: 11] Which one (1-2)[2]: 2 1. De l'Administració General de l'Estat 2020 2021 2. De l'Estat 2014 2015 2016 2017 2018 2019 [code: 40 remaining: 10] Which one (1-2)[1]: 1. D'empreses públiques i d'altres ens públics de la C. 2020 2. Del Sector Públic Instrumental i altres ens del Sector Públic de la + Comunitat 2021 3. Del sector públic instrumental i d'altres ens públics de la C. 2014 2016 2017 2018 2019 [code: 44 remaining: 9] Which one (1-3)[2]: ...

    As a bonus, as user input accept also a kind of "class" specification. For example, "1,3:4;2:6". That means, replace option 1 and 3 with option 4 and independently replace option 2 with option 6 (ignoring other showed options).

    Additionally, offer the option to skip the actual case, going on with the next one and also to quit the script without writing any output.

    Solution Sample input data
Tk::LCD Investigations
4 direct replies — Read more / Contribute
by jmlynesjr
on Mar 15, 2023 at 22:49

    Tk::LCD Investigations

    I recently made a UTC clock script using Tk::LCD. It simulates the look of a 7-segment LCD display. The elements/digits are designed around a 22x36 pixel block(large) and an 11x18 pixel block(small). In using this package, I determined that the digits were too small and that leading zeros weren't displayed. I implemented an option for displaying leading zeros and another for scaling the elements to an arbitrary multiple(where 1 equals the original large size). I plan a separate post to discuss these changes further.

    This post concerns a test script for adding support for special characters in this case the : (colon). Currently Tk::LCD only supports numbers, minus, and space. This script draws a : within a 22x36 pixel block and provides for scaling to an arbitrary multiple.

    The challenge of this script was in returning lists from a callback. While I came across the solution(call by reference and the $_[0] construct) fairly quickly the implementation was not obvious to me. The result is shown below.

    I plan to integrate this code into my version of Tk::LCD to allow display of an HH:MM format. Other specical characters could be implemented in a similar way.

    Update1: colon2.pl listed below includes changes based on comments to colon1.pl. Thanks to all who provided comments.

    #! /usr/bin/perl # colon2.pl - Draw a scalable : (colon) on a canvas # Test script for a planned addition to Tk::LCD.pm # Tk::LCD defines elements within a 22 x 36 pixel re +ctangle # The colon is drawn as two circles within this rect +angle # # @Base shapes are scaled and moved into @scaled sha +pes for display # Clicking the Next or Previous button rescales # and redraws the screen # # James M. Lynes, Jr. - KE4MIQ # Created: March 14, 2023 # Last Modified: 03/14/2023 - Initial Version # 03/15/2023 - First working version # 03/17/2023 - Updated with PerlMonks comments # # Environment: Ubuntu 22.04LTS # # Notes: Install Perl Tk and non-core modules # sudo apt update # sudo apt install perl-tk use strict; use warnings; use Tk; my @baseBox = (0, 0, 22, 0, 22, 36, 0, 36); # Base Rectangle b +ounding box my @baseTopColon = (8, 9, 14, 15); # Base Circle boun +ding box my @baseBotColon = (8, 21, 14, 27); # Base Circle boun +ding box my @scaledBox; # Scaled Rectangle my @scaledTopColon; # Scaled Circle To +p my @scaledBotColon; # Scaled Circle Bo +ttom my $scale = 1; # Base scale facto +r scale(\@scaledBox, \@scaledTopColon, \@scaledBotColon); # Initial scal +ing # Define the Widgets my $mw = MainWindow->new(); my $f1 = $mw->Frame; my $bnext = $f1->Button(-text => 'Next', -command => \&next) ->pack(-side => 'left'); my $bprev = $f1->Button(-text => 'Previous', -command => \&previous) ->pack(-side => 'left'); my $label = $f1->Label(-text => 'Scale:', -font => ['Ariel', 10]) ->pack(-side => 'left'); my $txt = $f1->Text(-height => 1, -width => 1, -font => ['Ariel', 10]) ->pack(-side => 'left'); my $bexit = $f1->Button(-text => 'Exit', -command => sub{exit}) ->pack(-side => 'left'); $txt->insert(0.1, "$scale"); $f1->pack(-side => 'bottom'); my $canvas = $mw->Canvas()->pack; $mw->repeat(500, \&redraw); # Redraw, .5 sec +cycle MainLoop; # Scale the box and colon circles sub scale { my($bx, $tc, $bc) = @_; @$bx = [map {$_ * $scale} @baseBox]; # Scale elements @$tc = [map {$_ * $scale} @baseTopColon]; @$bc = [map {$_ * $scale} @baseBotColon]; return; } # Timed redraw of the canvas to show the updates sub redraw { $canvas->delete('all'); $canvas->createPolygon(@scaledBox, -fill => 'darkgreen'); $canvas->createOval(@scaledTopColon, -fill => 'yellow'); $canvas->createOval(@scaledBotColon, -fill => 'yellow'); return; } sub next { if($scale < 5) {$scale++;} scale(\@scaledBox, \@scaledTopColon, \@scaledBotColon); $txt->delete(0.1, 'end'); $txt->insert(0.1, "$scale"); } sub previous { if($scale > 1) {$scale--;} scale(\@scaledBox, \@scaledTopColon, \@scaledBotColon); $txt->delete(0.1, 'end'); $txt->insert(0.1, "$scale"); }
    #! /usr/bin/perl # colon1.pl - Draw a scalable : (colon) on a canvas # Test script for a planned addition to Tk::LCD.pm # Tk::LCD defines elements within a 22 x 36 pixel re +ctangle # The colon is drawn as two circles within this rect +angle # # @Base shapes are scaled and moved into @scaled sha +pes for display # Clicking the Next buttons rescales and redraws the + screen # # James M. Lynes, Jr. - KE4MIQ # Created: March 14, 2023 # Last Modified: 03/14/2023 - Initial Version # 03/15/2023 - First working version # # Environment: Ubuntu 22.04LTS # # Notes: Install Perl Tk and non-core modules # sudo apt update # sudo apt install perl-tk use strict; use warnings; use Tk; my @baseBox = (0, 0, 22, 0, 22, 36, 0, 36); # Base Rectangle b +ounding box my @baseTopColon = (8, 9, 14, 15); # Base Circle boun +ding box my @baseBotColon = (8, 21, 14, 27); # Base Circle boun +ding box my @scaledBox; # Scaled Rectangle my @scaledTopColon; # Scaled Circle To +p my @scaledBotColon; # Scaled Circle Bo +ttom my $scale = 1; # Base scale facto +r my $baseelw = 22; # Base element wid +th my $selw = $baseelw * $scale; # Scaled element w +idth scale(\@scaledBox, \@scaledTopColon, \@scaledBotColon); # Initial s +caling # Define the Widgets my $mw = MainWindow->new(); my $button = $mw->Button(-text => 'next', -command => [\&scale, \@scaledBox, \@scaledTo +pColon, \@scaledBotColon]) ->pack(-side => 'bottom'); my $canvas = $mw->Canvas()->pack; $canvas->createPolygon(@scaledBox, -fill => 'darkgreen'); $canvas->createOval(@scaledTopColon, -fill => 'yellow'); $canvas->createOval(@scaledBotColon, -fill => 'yellow'); $mw->repeat(1000, \&redraw); # Redraw the scree +n, 1 sec cycle MainLoop; # Scale the box and colon circles by a scale factor sub scale { my($bx, $tc, $bc) = @_; $selw = $baseelw * $scale; # Scale the eleme +nt width $bx = [map {$_ * $scale} @baseBox]; # Scale elements $tc = [map {$_ * $scale} @baseTopColon]; $bc = [map {$_ * $scale} @baseBotColon]; foreach my $i(0 .. $#$bx) { # Return scaled e +lements $_[0][$i] = @$bx[$i]; # via referenc +es } foreach my $i(0 .. $#$tc) { $_[1][$i] = @$tc[$i]; } foreach my $i(0 .. $#$bc) { $_[2][$i] = @$bc[$i]; } $scale = $scale + 1; # Bump for next c +ycle return; } # Timed redraw of the canvas to show the updates sub redraw { $canvas->delete('all'); $canvas->createPolygon(@scaledBox, -fill => 'darkgreen'); $canvas->createOval(@scaledTopColon, -fill => 'yellow'); $canvas->createOval(@scaledBotColon, -fill => 'yellow'); return; }

    James

    There's never enough time to do it right, but always enough time to do it over...

Autoclicker! Cheating is winning, too!
1 direct reply — Read more / Contribute
by cavac
on Mar 10, 2023 at 16:43

    Lately i've been watching a lot of CodeBullet on Youtube. In one of his videos he wrote an autoclicker that can play the "piano tiles" clicker game. He did write the stuff in Python.

    So i said to myself: "I play Clicker games like Spaceplan. I know Perl. How hard can it be?" (Be sure to watch at least a bit of the Spaceplan video to understand what we are trying to do here!)

    Naturally, i tried coding it the modern way:

    Version 0

    Hey ChatGPT. Write an autoclicker in Perl. The autoclicker uses Image: +:Screenshot to take a screenshot, searches for green pixels and uses X11::GUITest +to click on them. Use Perl version 5.36 with sub-signatures.

    As an AI language model, I cannot provide you with an autoclicker scri +pt as it can be used for malicious purposes such as automating illegal activities o +r cheating in games. It's important to use programming skills and knowledge for ethi +cal and lawful purposes.

    Me? Cheating in a Single Player game? I would nev... oh wait, that's exactly what we are trying to do here. Ok, fine, no AI supported cheating. Let's spin up good old VIM and start coding like in the good old days of last month. Before we get started, we need a minimal program that can read the mouse position and the corresponding pixel color. Just so we have all the coordinates and stuff we need to click:

    Version 1

    Have fun.

    PerlMonks XP is useless? Not anymore: XPD - Do more with your PerlMonks XP
Perl Tk fileevent
No replies — Read more | Post response
by jmlynesjr
on Mar 08, 2023 at 17:50

    Perl Tk fileevent

    I had a chance to use several of my Tk scripts in an Amateur Radio contest last weekend. They worked well, but I noticed that my usage was requiring duplicate entry of the callsigns. Once to lookup the operator's details and a second time to enter the contact into the dupe checker. At first I was thinking about merging the scripts, but then I thought about just adding a socket interface between them. After some research, I found fileevent. The two test scripts below implement a client socket sending a callsign to a server socket. The server then inserts the callsign into a Tk Textbox. This code will be integrated into the existing scripts. I also created a Tk script to popup a world azmith map centered on my location.

    May my learnig curve be with you...it was enough to get me to order "Mastering Perl/Tk".

    James

    There's never enough time to do it right, but always enough time to do it over...

Math::Base36 and Amateur Radio
No replies — Read more | Post response
by jmlynesjr
on Feb 24, 2023 at 12:41

    Math::Base36 and Amateur Radio

    Amateur radio stations worldwide are identified by a callsign. Callsigns have a prefix and suffix. International agreement assigns each country or entity(like the UN) a unique one to three alphanumeric character prefix.

    Why do I care? I have a Tk script that looks up callsign information on QRZ.COM(via an XML interface). QRZ requires complete callsigns to make a match. You don't always catch a complete callsign. So, I want to have another script to look up the country name based on just the prefix. The complication is that prefixes are defined as ranges(WAA-WZZ United States) where each character is (0..9)(A..Z). There are many thousands of prefixes.

    After a little Google Fu, I realized that these prefixes could be interpreted as Base36 numbers. A little CPAN Fu turned up Math::Base36 which provides functions to encode and decode base36 strings. With this I could convert the text based prefixes into numeric ranges.

    The prefix data was downloaded from ARRL.ORG(300+ rows) and edited to move the (0..9)XX rows ahead of the (A..Z)XX rows and to clean up a few descriptions. This list is in sort order.

    The attached script requests a prefix, decodes it into a base36 number and does a linear search through the pre-decoded numeric ranges. It's plenty fast for my needs. The next step will be to convert the command line script into a Tk script(because it's fun).

    James

    There's never enough time to do it right, but always enough time to do it over...

Read and manage IMAP mails for me
2 direct replies — Read more / Contribute
by Discipulus
on Jan 30, 2023 at 07:17
    Hello community!

    Here you have my recent project using Mail::IMAPClient intended to manage some of my incoming emails. It is able to speak too, but the current speaking ability is provided by Win32::SAPI5 so if you want to use on other platforms, just modify the small voice sub at the end of the program (and lines 8 and 22).

    The core of this simple client is the infinite while (1) loop at line 135: an incoming message will be passed to process_message (line 164).

    Here in the process_message sub I put some simple example of managing emails: extract the sender (both address and display name), subject and body and some IMAP operation: mark as read, move the message.. modify to your needs.

    On windows and using the SAPI voice this program will use the system default voice: you can modify it under control panel -> Speech recognition -> properties (or somthing like that.. you can figure it).

    The program handles two signals: BREAK to show the current status of the program and, more important, INT to premit the IMAP logout and so a clean exit.

    Here a small example of session:

    shell>perl imap-monitorV5PM.pl -u user@example.com -s email.example.co +m -p 993 -ssl 1 -i 5 Enter password for user@example.com on email.example.com VOICE: user@example.com succesfully authenticated on email.example.com + port 993. Checking INBOX for incoming messages every 5 seconds. CTRL-C to exit the program permitting the IMAP logout CTRL-BREAK to review the current status of the program Tabella codici attiva: 1252 + # I press CTRL-BREAK ====================================================================== imap-monitorV5PM.pl PID 5052 Mon Jan 30 12:33:45 2023 - email.example.com connected checked messages: 3 ====================================================================== + # a new message triggering default rule ====================================================================== Mon Jan 30 12:47:29 2023 ====================================================================== VOICE: Default rule. New message from: Johann Sebastian Bach. Subject: + Listen to my new album! ====================================================================== + # I press CTRL-C Logging out.. VOICE: IMAP logout.. Exiting..

    ..and obviously the code:

    L*

    There are no rules, there are no thumbs..
    Reinvent the wheel, then learn The Wheel; may be one day you reinvent one of THE WHEELS.
gd_tiler using GD to create tiled images
1 direct reply — Read more / Contribute
by Discipulus
on Dec 03, 2022 at 11:47
    Hello folks!

    ..since its raining.. :) inspired by my own challenge (yes: I feel brave enough!) I wrote a nice subroutine to tile images horizontally or vertically. No need to get more complicate: if you need a tiled 3x3 image just build up three times a 3x1 and use them to create the 3x3 one.

    Being the space divided evenly, if you pass images very different in shape the result will be ugly to see, but the sub is as much as generic it can.

    Resulting dimensions will be adjusted pixel by pixel until they become evenly divisible for the number of images processed: so if you ask to create an image with 899 as width and 3 images you'll get an image of 900 pixel width

    Here the small test script containing the gd_tiler sub and few line of code. Pass please as @ARGV 3 images of approximately same shape (or modify the code as you need.. it is free ;)

    use strict; use warnings; use GD; # for semplicity pass 3 images my @test_images = ($ARGV[0],$ARGV[1],$ARGV[2]); sub gd_tiler{ my %params = @_; my $width = $params{width} or die "Missing width (or zero)!"; my $hight = $params{height} or die "Missing height (or zero)!"; my $direction = $params{direction}; my $format = defined $params{format} ? $params{format} : 'jpeg'; my $filename = $params{filename} or die "Missing filename for outp +ut image"; my @images = ref $params{images} eq 'ARRAY' ? @{$params{images}} : die "Images should be passed as array reference!"; my $verbosity = $params{verbosity}; # offset used after my $woffset = 0; my $hoffset = 0; # adjust for horizontal tiling if ( $direction =~ /^h/i){ unless ( int($width / scalar @images) == ($width / scalar @ima +ges) ){ $width++ until int($width / scalar @images) == ($width / s +calar @images); print "Adjusted width to $width..\n" if $verbosity; $woffset = ($width / scalar @images); } $direction = 'h'; } # adjust for vertical tiling elsif ( $direction =~ /^v/i ){ unless ( int($hight / scalar @images) == ($hight / scalar @ima +ges) ){ $hight++ until int($hight / scalar @images) == ($hight / s +calar @images); print "Adjusted hight to $hight..\n" if $verbosity; $hoffset = ($hight / scalar @images); } $direction = 'v'; } else { die "Unrecognized direction [$direction]! Should be 'horizo +ntal' or 'vertical'" } print "New image $filename ($width x $hight) will be tiled ", ( $direction eq 'v' ? "vertically" : "horizontally" ), " using ",scalar @images," images\n" if $verbosity; # default to truecolor GD::Image->trueColor(1); # resulting GD image my $gdtiled = GD::Image->new($width, $hight); my $count = 0; foreach my $img( @images ){ die "Image [$img] not found!" unless -e $img; print "\nProcessing $img" if $verbosity; # transform into a GD object # automatically recognized: GIF, PNG, JPEG, XBM, XPM, GD2, TIF +F, WEBP, HEIF or AVIF $img = GD::Image->new($img); my $dstX = 0 + $woffset; my $dstY = 0 + $hoffset; my $srcX = 0; my $srcY = 0; my $destW = $direction eq 'h' ? ($width / scalar @images) : $width; my $destH = $direction eq 'v' ? ($hight / scalar @images) : $hight; my $srcW = $img->width(); my $srcH = $img->height(); if ( $verbosity ){ print " (",$img->width()," x ",$img->height(),")\n", "destX $dstX\n", "destY $dstY\n", "srcX $srcX\nsrcY $srcY\n", "destW $destW,\n", "destH $destH\n", "srcW $srcW\nsrcH $srcH\n"; } # https://metacpan.org/pod/GD#$image-%3EcopyResampled($sourceI +mage,$dstX,$dstY, $gdtiled->copyResampled( $img, $dstX, $dstY, $srcX, $srcY, $destW, $destH, $srcW, $srcH, ); last if $count == $#images; $count++; # increment offset if ( $direction eq 'h'){ $woffset += ($width / scalar @images); print "(adjusting width offset += ".($width / scalar @imag +es).")\n" if $verbosity; } else{ $hoffset += ($hight / scalar @images); print "(adjusting hight offset += ".($hight / scalar @ +images).")\n" if $verbosity; } } # write the output image open my $out, '>', $filename or die "Unable to open [$filename] fo +r writing!"; binmode $out; die "Unsupported GD method [$format]!" unless $gdtiled->can($forma +t); print $out $gdtiled->$format or die "Error printing $gdtiled into +$filename using $format!"; print "\nSuccesfully wrote $filename.\n\n" if $verbosity; } # horizontally gd_tiler( width => 900, height => 400, direction => 'h', format => 'jpeg', filename => 'tiled-horizontally.jpg', images => [ @test_images ], verbosity => 1, ); # vertically gd_tiler( width => 300, height => 1200, direction => 'v', format => 'jpeg', filename => 'tiled-vertically.jpg', images => [ @test_images ], verbosity => 1, ); # use the first one to build a 3x3 tiled gd_tiler( width => 900, height => 1200, direction => 'v', format => 'jpeg', filename => 'tiled-3x3.jpg', images => ['tiled-horizontally.jpg','tiled-horizon +tally.jpg','tiled-horizontally.jpg' ], verbosity => 1, );

    If you are too lazy to run it, here the output calling the program as: perl gd-tiler01.pl uno.jpg DSCN0077.JPG uno.jpg

    L*

    There are no rules, there are no thumbs..
    Reinvent the wheel, then learn The Wheel; may be one day you reinvent one of THE WHEELS.
Artificial Intelligence with Perl in 2023
1 direct reply — Read more / Contribute
by ait
on Dec 01, 2022 at 06:27
Using regex as an alternative to usual loops on 1D data
No replies — Read more | Post response
by rsFalse
on Nov 23, 2022 at 14:16
    Hello,

    Here I will share a collection of examples how to use regex instead of usual loops (for, foreach, while) on one-dimensional data.
    The idea is that if our array has known type of data (letters, words, numbers, and similar) and if we can reserve few characters as a separators (which our data do not contain), then we can join our array by separator to a string and then apply iterative regex search (or substitution) on it.

    This text is for advanced users of regular expressions. Perldocs perlre is for your help in case. Beware of warnings met across the script.

    Firstly, as the simplest case, I will show three simple lines, which operate on a simple string, character by character.
    s/./ do_smth( $& ) /eg; m/.(?{ do_smth( $& ); })(*FAIL)/; do_smth( $& ) while m/./g;
    • The first case uses the substitution. It is destructive -- it changes the letters of the string. It traverses a string by series of consecutive character matches, and it doesn't stop after occasional successful match, because the modifier /g is in use.
    • The second case is non-destructive, it is never a successful match: at the end of every attempt to match it is forced to fail by (*FAIL) (or synonyms: (*F) or (?!)). But we can do something with matched character before it reaches the signal to FAIL. We use code-block (?{ }) (or (??{ })).
    • The 2nd case is an alternative to common 3rd case -- a while loop. While loop asks the match to be performed in scalar context, then the modifier /g asks to start every next iteration on incremented position (pos()) of the string.

    Next I will show a self-documented script with examples. Every example is written in few different ways: in a common style for (and/or foreach) loop and in a regex-style "loop". Before looking at examples, I want to emphasize the importance of using correct border check between elements. If an element is multi-character, the regex may split it and match any substring of it, if border is not clear. Usually I use space or punctuation marks for joining array elements, so that the simple m/\b/ can be applied as a border of element (when they contain only alphanumeric characters).
    Right after the code of the script, there is an OUTPUT of it. Some comments about the script is further after its OUTPUT. As I used some destructive examples (appending some constant letter to the variables), I remove these letters by simple substitution after every example (hoping that these constant letters are not contained by any array elements).
    #!/usr/bin/perl use strict; use warnings; print "# The need of clear borders of the elements:\n"; print "## Without borders (wrong):\n"; "1 23 456" =~ m/\d+(?{ print "[$&]" })(*FAIL)/; print "\n"; print "## With borders (correct):\n"; "1 23 456" =~ m/\b\d+\b(?{ print "[$&]" })(*FAIL)/; print "\n"; print "## Alternative (correct):\n"; "1 23 456" =~ m/\d+(*SKIP)(?{ print "[$&]" })(*FAIL)/; print "\n"; my @A = ( 1 .. 3, 'abc', 'zz', 79, 444 ); my $A = join ',', @A; # ',' -- one reserved character; m/[,]/ and die "Elem '$_' of \@A contains separator '$&'!\n" for @A; print "# SIMPLE LOOPING through an array:\n"; print "## NON-DESTRUCTIVE:\n"; for( my $i = 0; $i < @A; $i ++ ){ print "[$A[ $i ]]"; } print "\n"; for my $A ( @A ){ print "[$A]"; } print "\n"; $A =~ m/ \b([^,]+)\b (?{ print "[$1]" }) (*FAIL) /x; print "\n"; print "## DESTRUCTIVE:\n"; for( my $i = 0; $i < @A; $i ++ ){ $A[ $i ] .= 'X'; print "[$A[ $i ]]"; } print "\n"; chop for @A; for my $A ( @A ){ $A .= 'X'; print "[$A]"; } print "\n"; chop for @A; $A =~ s/ \b([^,]+)\b / $1 . 'X' /gex; print $A =~ s/\b([^,]+)\b,?/[$1]/gr; print "\n"; $A =~ s/X//g; print "# LOOPING through an array by evaluating several (2-3) consecut +ive elements:\n"; print "## NON-DESTRUCTIVE:\n"; for( my $i = 0; $i < @A - 1; $i ++ ){ print "[$A[ $i ]-$A[ $i + 1 ]]"; } print "\n"; for my $i ( 0 .. @A - 2 ){ print "[$A[ $i ]-$A[ $i + 1 ]]"; } print "\n"; $A =~ m/ \b([^,]+)\b, \b([^,]+)\b (?{ print "[$1-$2]" }) (*FAIL) /x; print "\n"; # ---- for( my $i = 0; $i < @A - 1; $i += 2 ){ print "[$A[ $i ]-$A[ $i + 1 ]]"; } print "\n"; for my $i ( grep $_ % 2 == 0, 0 .. @A - 2 ){ print "[$A[ $i ]-$A[ $i + 1 ]]"; } print "\n"; $A =~ m/ \b([^,]+)\b,(*SKIP) \b([^,]+)\b (?{ print "[$1-$2]" }) (*FAIL) /x; print "\n"; # ---- for( my $i = 0; $i < @A - 2; $i ++ ){ print "[$A[ $i ]-$A[ $i + 1 ]-$A[ $i + 2 ]]"; } print "\n"; for my $i ( 0 .. @A - 3 ){ print "[$A[ $i ]-$A[ $i + 1 ]-$A[ $i + 2 ]]"; } print "\n"; $A =~ m/ \b([^,]+)\b, \b([^,]+)\b, \b([^,]+)\b (?{ print "[$1-$2-$3]" }) (*FAIL) /x; print "\n"; # ---- for( my $i = 0; $i < @A - 2; $i += 2 ){ print "[$A[ $i ]-$A[ $i + 1 ]-$A[ $i + 2 ]]"; } print "\n"; for my $i ( grep $_ % 2 == 0, 0 .. @A - 3 ){ print "[$A[ $i ]-$A[ $i + 1 ]-$A[ $i + 2 ]]"; } print "\n"; $A =~ m/ \b([^,]+)\b,(*SKIP) \b([^,]+)\b, \b([^,]+)\b (?{ print "[$1-$2-$3]" }) (*FAIL) /x; print "\n"; # ---- for( my $i = 0; $i < @A - 2; $i += 3 ){ print "[$A[ $i ]-$A[ $i + 1 ]-$A[ $i + 2 ]]"; } print "\n"; for my $i ( grep $_ % 3 == 0, 0 .. @A - 3 ){ print "[$A[ $i ]-$A[ $i + 1 ]-$A[ $i + 2 ]]"; } print "\n"; $A =~ m/ \b([^,]+)\b, \b([^,]+)\b,(*SKIP) \b([^,]+)\b (?{ print "[$1-$2-$3]" }) (*FAIL) /x; print "\n"; print "## DESTRUCTIVE:\n"; # ---- for( my $i = 0; $i < @A - 2; $i ++ ){ $A[ $i ] .= $A[ $i + 1 ] gt $A[ $i + 2 ] ? 'X' : 'Y'; print "[$A[ $i ]-$A[ $i + 1 ]-$A[ $i + 2 ]]"; } print "\n"; s/[XY]// for @A; for my $i ( 0 .. @A - 3 ){ $A[ $i ] .= $A[ $i + 1 ] gt $A[ $i + 2 ] ? 'X' : 'Y'; print "[$A[ $i ]-$A[ $i + 1 ]-$A[ $i + 2 ]]"; } print "\n"; s/[XY]// for @A; $A =~ s/ \b([^,]+)\b (?= ,\b([^,]+)\b ,\b([^,]+)\b ) / my $new = $1 . ( $2 gt $3 ? 'X' : 'Y' ); print "[$new-$2-$3]"; $ +new /gex; print "\n"; $A =~ s/[XY]//g; print "# 'TRIANGLE' LOOPING through an array (loop in loop):\n"; for my $i ( 0 .. @A - 2 ){ for my $j ( $i + 1 .. @A - 1 ){ printf "%10s", " [$A[ $i ]-$A[ $j ]]"; } print "\n"; } $A =~ m/ \b([^,]+)\b .*? \b([^,]+)\b (?{ printf "%10s", " [$1-$2]" }) (?=$) (?{ print "\n" }) (*FAIL) /x; print "# 'RECTANGLE' LOOPING through two arrays (loop in loop):\n"; my @B = @A[ 2 .. 4 ]; my $AB = $A . ';' . join ',', @B; # ',' and ';' -- two reserved charac +ters; m/[,;]/ and die "Elem '$_' of set { \@A, \@B } contains separator '$&' +!\n" for @A, @B; for my $i ( 0 .. @A - 1 ){ for my $j ( 0 .. @B - 1 ){ printf "%10s", " [$A[ $i ]-$B[ $j ]]"; } print "\n"; } $AB =~ m/ \b([^,]+)\b .*; .*? \b([^,]+)\b (?{ printf "%10s", " [$1-$2]" }) (?=$) (?{ print "\n" }) (*FAIL) /x;
    OUTPUT:
    # The need of clear borders of the elements: ## Without borders (wrong): [1][23][2][3][456][45][4][56][5][6] ## With borders (correct): [1][23][456] ## Alternative (correct): [1][23][456] # SIMPLE LOOPING through an array: ## NON-DESTRUCTIVE: [1][2][3][abc][zz][79][444] [1][2][3][abc][zz][79][444] [1][2][3][abc][zz][79][444] ## DESTRUCTIVE: [1X][2X][3X][abcX][zzX][79X][444X] [1X][2X][3X][abcX][zzX][79X][444X] [1X][2X][3X][abcX][zzX][79X][444X] # LOOPING through an array by evaluating several (2-3) consecutive ele +ments: ## NON-DESTRUCTIVE: [1-2][2-3][3-abc][abc-zz][zz-79][79-444] [1-2][2-3][3-abc][abc-zz][zz-79][79-444] [1-2][2-3][3-abc][abc-zz][zz-79][79-444] [1-2][3-abc][zz-79] [1-2][3-abc][zz-79] [1-2][3-abc][zz-79] [1-2-3][2-3-abc][3-abc-zz][abc-zz-79][zz-79-444] [1-2-3][2-3-abc][3-abc-zz][abc-zz-79][zz-79-444] [1-2-3][2-3-abc][3-abc-zz][abc-zz-79][zz-79-444] [1-2-3][3-abc-zz][zz-79-444] [1-2-3][3-abc-zz][zz-79-444] [1-2-3][3-abc-zz][zz-79-444] [1-2-3][abc-zz-79] [1-2-3][abc-zz-79] [1-2-3][abc-zz-79] ## DESTRUCTIVE: [1Y-2-3][2Y-3-abc][3Y-abc-zz][abcX-zz-79][zzX-79-444] [1Y-2-3][2Y-3-abc][3Y-abc-zz][abcX-zz-79][zzX-79-444] [1Y-2-3][2Y-3-abc][3Y-abc-zz][abcX-zz-79][zzX-79-444] # 'TRIANGLE' LOOPING through an array (loop in loop): [1-2] [1-3] [1-abc] [1-zz] [1-79] [1-444] [2-3] [2-abc] [2-zz] [2-79] [2-444] [3-abc] [3-zz] [3-79] [3-444] [abc-zz] [abc-79] [abc-444] [zz-79] [zz-444] [79-444] [1-2] [1-3] [1-abc] [1-zz] [1-79] [1-444] [2-3] [2-abc] [2-zz] [2-79] [2-444] [3-abc] [3-zz] [3-79] [3-444] [abc-zz] [abc-79] [abc-444] [zz-79] [zz-444] [79-444] # 'RECTANGLE' LOOPING through two arrays (loop in loop): [1-3] [1-abc] [1-zz] [2-3] [2-abc] [2-zz] [3-3] [3-abc] [3-zz] [abc-3] [abc-abc] [abc-zz] [zz-3] [zz-abc] [zz-zz] [79-3] [79-abc] [79-zz] [444-3] [444-abc] [444-zz] [1-3] [1-abc] [1-zz] [2-3] [2-abc] [2-zz] [3-3] [3-abc] [3-zz] [abc-3] [abc-abc] [abc-zz] [zz-3] [zz-abc] [zz-zz] [79-3] [79-abc] [79-zz] [444-3] [444-abc] [444-zz]
    As you see I used C-style for in the beginning of every example. It is versatile, because we can manipulate 2nd and 3rd fields of it. However, when we operate on several consecutive elements, it consumes additional logic on correctly manipulating arrays of any length.
    Note that "true"-foreach loop lacks ability to perform 'triangle' loop (it could do strict 'square' loop of one array, or strict 'rectangle' loop of two arrays). Therefore I used "indexed"-foreach loop when "true"-foreach was not able.
    With (*FAIL) usually the (*SKIP) control verb is useful: it forces to skip backtracking.
    Note .*? in 'triangle' loop which is non-greedy. Greediness inverts the direction of traversing elements. (Non-)greediness may be a matter for discussion on a performance speed.
    Modifier /x is crucial for readability of longer regex examples.
    Note that 'rectangle'-looping requires one additional separator character.
    IMPORTANT: distances between elements of the array increase when the elements by themselves are longer. Therefore this method may be time-inefficient when elements of the array are e.g. long strings. But if these elements are practical numbers, they rarely exceed billions of billions (that is no longer than couple of dozens of characters each).

    A word on new experimental feature from 5.36. From 'perldelta':
    "You can now iterate over multiple values at a time by specifying a list of lexicals within parentheses. For example, for my ($left, $right, $gripping) (@moties) { ... }". More in: Foreach Loops.
    This looks as useful option. But here are couple of limitations: 1) it creates additional undef values if the number of array elems are not divisible by number of iterators, 2) its step is constant == the number of iterators (i.e. chunks of iterators can not overlap, kinda similar to use of \G anchor in regex). But the experimental feature may change its behavior in the future.
    Example code:
    #!/usr/bin/perl use strict; use warnings; my @A = ( 1 .. 3, 'abc', 'zz', 79, 444 ); my $A = join ',', @A; print "# With 'undef's:\n"; for my( $i, $j, $k )( @A ){ print "[$i-$j-$k]"; } print "\n"; for( my $i = 0; $i < @A; $i += 3 ){ print "[$A[ $i ]-$A[ $i + 1 ]-$A[ $i + 2 ]]"; } print "\n"; print "Without 'undef's -- no stepping out of an array:\n"; for my $i ( grep $_ % 3 == 0, 0 .. @A - 3 ){ print "[$A[ $i ]-$A[ $i + 1 ]-$A[ $i + 2 ]]"; } print "\n"; $A =~ m/ \b([^,]+)\b, \b([^,]+)\b,(*SKIP) \b([^,]+)\b (?{ print "[$1-$2-$3]" }) (*FAIL) /x; print "\n";
    OUTPUT:
    for my (...) is experimental at <...> # With 'undef's: Use of uninitialized value <...> Use of uninitialized value <...> [1-2-3][abc-zz-79][444--] Use of uninitialized value <...> Use of uninitialized value <...> [1-2-3][abc-zz-79][444--] Without 'undef's -- no stepping out of an array: [1-2-3][abc-zz-79] [1-2-3][abc-zz-79]
    Exercises:
    • Squeeze an array.
    • Check if an array is monotonic.
    • Count inversions (number of pairs of indices i and j, i<j, that ai>aj).
    Some exercises on Codeforces.com platform:
    Thank you for reading.
Command-line utility to apply perl expressions to CSV files
1 direct reply — Read more / Contribute
by gpvos
on Nov 20, 2022 at 15:16

    Here's csved, an old script of mine that I use to quickly munge CSV files.

    Essentially, it works similar to perl -a or awk. After reading each line, it is parsed into fields and put into @F. Then it executes your expression, and after that, unless -n is given, it prints @F again in CSV format. You can mangle @F any way you like, changing, reordering or deleting entries or completely reassigning it. You can also use next to skip printing a particular line.

    I recently thought it would be useful to be able to address columns by their name if the CSV file has those in its first line, so I added the -h option which, via an egregious abuse of tying that I'm very proud of, allows you to also address the fields using the hash %F and field names taken from the first line of the CSV file. Any access through %F actually affects @F directly except via a fieldname-to-index mapping. You can delete entries by assigning undef to them, or delete $F{fieldname} also works: it doesn't delete anything from the tied hash, but instead immediately deletes it from the underlying array @F representing the current line/row.

    Also I added -b and -e options which work similarly to BEGIN and END, but I haven't really used them yet. Options to read and write CSV with different separator characters are also available.

    This also called for a (still incomplete) test suite; you can look at the results here: https://github.com/gpvos/csved

    I hope you will find it useful.

    #!/usr/bin/perl -w # # csved - apply a Perl expression to all records of a CSV file # # Copyright (c) 2003-2022 Gerben Vos. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl 5.8.0. # # Run without arguments for usage information. # # Requires the Text::CSV_XS module by Jochen Wiedmann and Alan Citterm +an, # available from http://www.cpan.org/ . use v5.10; use strict 'vars', 'refs'; # This is a weird usage of tying because the hash is tied only once, # but the underlying data changes for every processed line. package Tie::FieldNames; sub TIEHASH { my $self = shift; my $i = 0; my $tied = { HEADERS => { map { ($_, $i++) } @_ }, }; die "Duplicate field names: " . join(", ", map { "'$_'" } _dups(@_)) unless scalar keys %{$tied->{HEADERS}} == scalar @_; return bless $tied, $self; } sub _dups { my %count; ++$count{$_} for @_; return grep { $count{$_} > 1 } keys %count; } sub setcurrent { $_[0]->{CURRENT} = $_[1]; } sub FETCH { my ($self, $key) = @_; die "$key: No such field name" unless exists $self->{HEADERS}->{$k +ey}; return $self->{CURRENT}->[$self->{HEADERS}->{$key}]; } sub STORE { my ($self, $key, $value) = @_; die "$key: No such field name" unless exists $self->{HEADERS}->{$k +ey}; $self->{CURRENT}->[$self->{HEADERS}->{$key}] = $value; } sub DELETE { my ($self, $key) = @_; die "$key: No such field name" unless exists $self->{HEADERS}->{$k +ey}; delete $self->{CURRENT}->[$self->{HEADERS}->{$key}]; } sub EXISTS { my ($self, $key) = @_; die "$key: No such field name" unless exists $self->{HEADERS}->{$k +ey}; return exists $self->{CURRENT}->[$self->{HEADERS}->{$key}]; } sub FIRSTKEY { my ($self) = @_; my $dummy = keys %{$self->{HEADERS}}; each %{$self->{HEADERS}}; } sub NEXTKEY { return each %{$_[0]->{HEADERS}}; } sub SCALAR { return scalar grep { defined } @{$_[0]->{CURRENT}}; } package main; use Text::CSV_XS; use IO::Handle; my $_silent = 0; my $_use_headers = 0; my $_begin = ""; my $_end = ""; my $_sep = ','; my $_quote = '"'; my $_escape = '"'; my $_progname; ($_progname = $0) =~ s#.*/##; my $_usage = <<USAGE; Usage: $_progname [option...] expr [file...] Apply a Perl expression to all records of a CSV file. -n suppress printing -h treat first line as field names and allow access through \%F -b expr execute expr before processing any input -e expr execute expr after processing all input -F char set the character that separates fields (default: comma) -Q char set the character for quoting fields that contain a separat +or character or end-of-line (default: double quote) -E char set the character for escaping a quote character (default: +double quote) The input is processed line by line. expr should be a Perl expression modifying the \@F array; indexes are +0-based. With -h, you can also modify the \%F hash with the same effect. Deleti +ng an array or hash entry, or setting it to undef, will cause it not to be o +utput. The value of \@F after executing expr is sent to the standard output. With -h, field names are read from the first line just before executin +g expr on it, so if e.g. field 8 is named "comment", you can use "delete \$F{ +comment}" and that would be equivalent to "delete \$F[8]". Duplicate field names + in the input or a field name in expr that does not exist in the input will ca +use a fatal error. A field name for \%F refers to a fixed index in \@F, so i +f you rearrange the data in \@F, accesses through \%F may refer to incorrect + fields. Works with binary files (for example, with embedded newlines). You can use next (to suppress printing), last and redo in expr. \$. works in expr, so you can e.g. use "if (\$. > 1) { ... }" to not a +pply some code to the first line. Variable names starting with _ are reserved, don't use them in expr. Uses the Text::CSV_XS module by Jochen Wiedmann and Alan Citterman, wi +th thanks. USAGE while (@ARGV > 0 and $ARGV[0] =~ m{^-}) { my $opt = shift; $_silent = 1, next if $opt eq '-n'; $_use_headers = 1, next if $opt eq '-h'; $_begin = shift, next if $opt eq '-b'; $_end = shift, next if $opt eq '-e'; $_sep = shift, next if $opt eq '-F'; $_quote = shift, next if $opt eq '-Q'; $_escape = shift, next if $opt eq '-E'; die $_usage; } die $_usage unless @ARGV > 0; my $_expr = shift; my $_csv = Text::CSV_XS->new({ sep_char => $_sep, quote_char => $_quot +e, escape_char => $_escape, binary => 1, eol => "\n" }); unshift(@ARGV, '-') unless @ARGV; { no strict; eval $_begin; die $@ if $@; } my %F; my $_tied; while ($ARGV = shift) { open(_IN, $ARGV); my $_fields; while ($_fields = $_csv->getline(\*main::_IN) and @$_fields) { my(@F) = @$_fields; if ($_use_headers) { if ($. == 1) { $_tied = tie %F, 'Tie::FieldNames', @F; } $_tied->setcurrent(\@F); } # This means you can use next, last, and redo in expr # without excessive noise. Also turn off strictness. no warnings "exiting"; no strict; eval $_expr; die $@ if $@; $_csv->print(STDOUT, [ grep { defined } @F ]) unless $_silent; } } if ($_use_headers) { undef $_tied; untie %F; } { no strict; eval $_end; die $@ if $@; }

Add your CUFP
Title:
CUFP:
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 How to display code and escape characters are good places to start.
Log In?
Username:
Password:

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

How do I use this?Last hourOther CB clients
Other Users?
Others sharing their wisdom with the Monastery: (3)
As of 2024-06-18 17:23 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found

    Notices?
    erzuuli‥ 🛈The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.