http://www.perlmonks.org?node_id=1044

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

CUFP's
No replies — Read more | Post response
by RonW
on May 06, 2024 at 07:27
A while back, the materials lab got some surplus instruments for materials testing. Interestingly, the data files produced have a mix of base 10, base 16 and base 2 numbers in Ada based numeric constant format:

10#86# 16#FA61# 2#10010110#

After they tried using LabView and Excel to covert the numbers, they came to us software engineers.

My (3/32 baked) solution was using a regular expression to parse out the base and number, then convert using hex and oct as appropriate.

While this worked fine for what was needed, some one asked "Why didn't you make a proper implementation?" My reply, of course, was "This serves our needs" and left it as is. For about a week. My thoughts kept drifting back to it, so I gave in and said "Challenge accepted."

So, I made the "proper implementation" per the Ada standard, including floating point conversion. There is a base converter in CPAN I might have used, but Horner's Method is simple and efficient - and almost habitual to use. I haven't tested whether using a hash or using index (with lc or uc) would be more efficient. I used a hash.

Looking at the CPAN listings, I think Language::Ada is the right namespace. (Though I noticed that C, for example, is top level, rather than Language::C)

Marching Squares (for contouring) with a PDL convolution
No replies — Read more | Post response
by etj
on May 05, 2024 at 12:12
This implements a partial Marching Squares algorithm (see https://en.wikipedia.org/wiki/Marching_squares). Limitations:
• It doesn't do the linear interpolation bit, because I couldn't figure a lazy way of getting it to do that. Probably doubling the coordinate offsets and using those as index offsets would work.
• Making a bunch of individual line-segments and drawing each one is very slow in PGS. Joining them into polylines is possible with the not-yet-released next version of PDL (there's a path_join which allows this), which goes much quicker.
If you change the if (0) to 1, it shows you its lookup table instead of drawing contours.
```use strict; use warnings;
use PDL;
use PDL::Image2D;
use PDL::Graphics::Simple;

my \$LOOKUP = pdl(
# relative to cell, x1,y1,x2,y2 for each line; 0 is invalid: lines s
+tart edge
[[   0,   0,   0,   0],[   0, 0,   0,   0]], # 0
[[-0.5,   0,   0,-0.5],[   0, 0,   0,   0]],
[[   0,-0.5, 0.5,   0],[   0, 0,   0,   0]], # 2
[[-0.5,   0, 0.5,   0],[   0, 0,   0,   0]],
[[   0, 0.5, 0.5,   0],[   0, 0,   0,   0]], # 4
[[   0,-0.5, 0.5,   0],[-0.5, 0,   0, 0.5]],
[[   0,-0.5,   0, 0.5],[   0, 0,   0,   0]], # 6
[[-0.5,   0,   0, 0.5],[   0, 0,   0,   0]],
[[-0.5,   0,   0, 0.5],[   0, 0,   0,   0]], # 8
[[   0,-0.5,   0, 0.5],[   0, 0,   0,   0]],
[[-0.5,   0,   0,-0.5],[   0, 0.5, 0.5, 0]], # 10
[[   0, 0.5, 0.5,   0],[   0, 0,   0,   0]],
[[-0.5,   0, 0.5,   0],[   0, 0,   0,   0]], # 12
[[   0,-0.5, 0.5,   0],[   0, 0,   0,   0]],
[[-0.5,   0,   0,-0.5],[   0, 0,   0,   0]], # 14
[[   0,   0,   0,   0],[   0, 0,   0,   0]],
);

sub marching_squares {
my (\$c, \$data, \$points) = @_;
my \$kernel = pdl q[4 8; 2 1];
my \$contcells = conv2d(\$data < \$c, \$kernel)->slice(':-2,:-2');
my \$segs = \$LOOKUP->slice([],[],\$contcells->flat)->clump(1..2);
my \$segsinds = \$segs->orover;
my \$contcoords = +(\$contcells->ndcoords->inflateN(1,2)->dupN(2) + 0.
+5)->clump(1,2);
my \$segscoords = (\$segs + \$contcoords)->whereND(\$segsmask);
\$segscoords->splitdim(0,4)->clump(1,2);
}

if (0) {
my \$win = pgswin(multi=>[4,4]);
my \$xrange = [-0.5,0.5]; my \$yrange = [-0.5,0.5];
my \$i = 0;
for my \$lines (\$LOOKUP->dog) {
\$win->plot(
(map +(with=>'lines', \$_->splitdim(0,2)->mv(0,-1)->dog), \$lines->d
+og),
{xrange=>\$xrange,yrange=>\$yrange,j=>1,title=>\$i++},
);
}
print "ret> "; <>;
exit;
}

my \$SIZE = 50;
my \$vals = rvals(\$SIZE,\$SIZE)->divide(\$SIZE/12.5)->sin;
my \$cntr_cnt = 9;
my @cntr_threshes = zeroes(\$cntr_cnt+2)->xlinvals(\$vals->minmax)->list
+;
@cntr_threshes = @cntr_threshes[1..\$#cntr_threshes-1];
my \$win = pgswin();
my \$xrange = [0,\$vals->dim(0)-1]; my \$yrange = [0,\$vals->dim(1)-1];
\$win->plot(with=>'image', \$vals, {xrange=>\$xrange,yrange=>\$yrange,j=>1
+},);
for my \$thresh (@cntr_threshes) {
my \$segscoords = marching_squares(\$thresh, \$vals);
\$win->oplot(
(map +(with=>'lines', \$_->splitdim(0,2)->mv(0,-1)->dog), \$segscoor
+ds->splitdim(0,4)->clump(1,2)->dog),
{xrange=>\$xrange,yrange=>\$yrange,j=>1},
);
}
print "ret> "; <>;
AI in Perl...
No replies — Read more | Post response
by The_Dj
on Apr 18, 2024 at 10:59
Nowadays AIs tend to use TensorFlow.
Sadly Perl's AI::TensorFlow module can't create new models. It can only load pre-trained models. (Well, it probably can if you know all the deepest magic of Tensorflow, C, MX and Libtensorflow.pm. I don't)

AI::MXNet was a perfectly good solution until cuda 12 broke the entire build- and tool chains and Apache retired the MXNet project.

So visit this node for a Dockerfile that builds and runs AI::MXNet and get Perl to create your next AI!

best of luck!
Runtime::Debugger New Release
No replies — Read more | Post response
by Timka
on Mar 30, 2024 at 15:44
"Terminal Velocity", a better Linux terminal graphics demo
4 direct replies — Read more / Contribute
by cavac
on Feb 18, 2024 at 07:36

Last week i released a simple graphics demo for the Linux terminal (Fun with terminal color).

The low framerate and the mostly static graphics bothered me a bit. So, i , uhm did it yet again. Another demo, this time using Inline::CPP and massaged versions of tinyraytracer and tinyraycaster to provide some actual graphical content. As a matter of fact, Inline::CPP didn't work for my borrowed(*) code, and my understanding of CPP is a 20 years out of date. So i override the Inline::CPP RecDescent module to ignore my bugs. Hey, it's not production code, just a demo...

As in the last demo, your Terminal needs to support full RGB colors and have a size of at least 270x60 in size (characters, not pixels). SDL is sort-of-optional this time; the demo will run without sound if it can't load SDL. And as said above, you'll need to install Inline::CPP as well.

Here's the mercurial repository: https://cavac.at/public/mercurial/demos/terminalvelocity/

And the YouTube video: https://www.youtube.com/watch?v=MWcuI2SXA-A. OBS and YT compression did munge the quality a bit, though. Probably my fault for not understanding the OBS settings...

(*) "but with every intention of giving it back"

PerlMonks XP is useless? Not anymore: XPD - Do more with your PerlMonks XP
Color die and warn messages
by Anonymous Monk
on Feb 15, 2024 at 18:50
This scratched an itch for me, no guarantees.
```use warnings::colored;
warn "warning";  # yellow
system "non-existant-command";  # red
say "test";  # none
eval { die "caught" };  # none
say \$@;  # none
die "died";  # red
And the implementation:
Fun with terminal color
2 direct replies — Read more / Contribute
by cavac
on Feb 09, 2024 at 18:10

Yesterday i thought i might fix some bugs in my imagecat routine (printing images to the terminal). But somehow i, uhm, improved things a little too far. If you're now thinking "Oh no, he did it again!", i'm afraid, yes, i did.

This time, i made a 3 minute animated demo with sound, running at (some) FPS in a Linux terminal.

You can find a download of the current version as a tarball or you could clone my public mercurial repo if you prefer that. (Edit: Link to mercurial has changed/updated)

The demo needs quite a few CPAN modules, i'm afraid, including the somewhat hard-to-install SDL bindings. (For SDL, you might have to change a checksum in the Alien::SDL Build.PL and ignore some test errors in SDL as well.) I'm using SDL for the sound output.

Also, your Terminal needs to support full RGB colors /see the Imagecat - show color images in a terminal thread) and have a size of at least 270x60 in size (characters, not pixels).

If you want to avoid the hassle of getting it to work on your system, you can watch the YouTube video instead.

PerlMonks XP is useless? Not anymore: XPD - Do more with your PerlMonks XP
by kikuchiyo
on Feb 08, 2024 at 10:51

\$subject came up at \$work.

The following minimal example appears to work:

```#!/usr/bin/perl

use Modern::Perl '2021';
use Net::Amazon::S3::Client;

# edit these
my \$aws_access_key_id = '...';
my \$aws_secret_access_key = '...';
my \$host = '...';
my \$bucket_name = '...';
my \$secure = 1;

my \$client = Net::Amazon::S3::Client->new (
host                  => \$host,
aws_access_key_id     => \$aws_access_key_id,
aws_secret_access_key => \$aws_secret_access_key,
secure                => \$secure,
retry                 => 1,
);

my \$bucket = \$client->bucket( name => \$bucket_name );

my \$object = \$bucket->object( key => \$ARGV[0] );

\$object->get_callback(sub {
my \$s = length(\$_[0]);
print STDERR "Got chunk size \$s\n";
# do something with \$_[0]
});

This is applicable if you want to serve a file from an S3 compatible storage via an async backend.

The get_callback method is not documented (it is mentioned in passing only in Net::Amazon::S3::Client::Object::Range), but in the end it works.

Shotgun.pl - Shoots Holes in Files
by BlueSquare23
on Jan 29, 2024 at 18:27

# Shotgun.pl

## Shoots Holes in Files

Cyber weapon! For home defense purposes only!

Have you ever had a file you just wanted to blast with a shotgun? Now you can!

Can play audio files via aplay or mpv (tested on Ubuntu). Or use -quiet to run with no sound effects.

Source on My Github Video of Script in Action
Acceleration ETA algorithm
3 direct replies — Read more / Contribute
by phizel
on Jan 27, 2024 at 12:49
Was looking for a decent algorithm for determining the ETA of a long-running process, but everything on CPAN uses simplistic and inaccurate algorithms. Found this great article Benchmarking I/O ETA algorithms and converted the Acceleration algorithm to perl. And yes, it would be better to extract the state components into an object.
```use Time::HiRes qw(time);
sub eta {
my (\$cur, \$total, \$time) = @_;
return unless \$cur and \$time;

state (\$last_progress, \$last_time, \$last_v, \$last_eta);
state (@v, @eta, \$window_size, \$window_idx);
state \$init = do {
(\$last_progress, \$last_time, \$last_v, \$last_eta) = (0, 0, 0, -
+1);
(\$window_size, \$window_idx) = (10, 0);
};
state \$sub_v_weight = sub { 1 + \$_[0] };
state \$sub_eta_weight = sub { \$_[0] ? 2 * \$_[1] : 1 };
state \$sub_weighted_avg = sub {
my (\$sub_weight, \$avg, \$total_weight, \$w) = (shift, 0, 0, 0);
for my \$i (0 .. \$#_) {
# first version messed up the index.
my \$j = (\$i + @_ - \$window_idx - 1) % @_;
\$w = \$sub_weight->(\$j, \$w);
\$avg += \$w * \$_[\$i];
\$total_weight += \$w;
}
return \$avg / \$total_weight;
};

my \$v = (\$cur - \$last_progress) / ((\$time - \$last_time) || 1);
\$v[\$window_idx] = \$v;
\$v = \$sub_weighted_avg->(\$sub_v_weight, @v);

if (\$v and \$last_v) {
my (\$min_v, \$max_v) = \$v < \$last_v ? (\$v, \$last_v) : (\$last_v,
+ \$v);
\$v = \$last_v + (\$v - \$last_v) * \$min_v / \$max_v;
}

my \$a = (\$v - \$last_v) / (\$last_time ? (\$time - \$last_time) : 1);
my \$r = \$total - \$cur;

my \$eta = \$last_eta;
if (\$a and 0 < (my \$d = (\$v * \$v + 2 * \$a * \$r))) {
\$eta = (sqrt(\$d) - \$v) / \$a;
}
elsif (\$v) { \$eta = \$r / \$v }

\$eta[\$window_idx] = \$eta;
\$eta = \$sub_weighted_avg->(\$sub_eta_weight, @eta);

(\$last_progress, \$last_time, \$last_v, \$last_eta, \$window_idx)
= (\$cur, \$time, \$v, \$eta, (\$window_idx + 1) % \$window_size);

return \$eta > 0 ? \$eta : 0;
}
Munging file name, to be safe- & usable enough on Unix-like OSen & FAT32 file system
2 direct replies — Read more / Contribute
by parv
on Nov 25, 2023 at 23:12

A program written in a hurry some time ago to munge file paths generally for file systems for Unix(-like) OSen & specifically for FAT32.

Learned the hard way that NTFS would allow file names to be written to FAT32 even if some characters are outside of FAT32 specification. Problematic characters seemed to be en- & em-dash, fancy quotes, pipe, Unicode "?", & possibly few others (web pages saved with title as the file name). Mounting FAT32 file system on FreeBSD with specific codepage(s), or "nowin95" or "shortnames" mount options did not help (mount_msdosfs(8)). Munging it was then🤷🏽‍♂️

uparse - Parse Unicode strings
6 direct replies — Read more / Contribute
by kcott
on Nov 18, 2023 at 03:53

Improvement: See "Re: Decoding @ARGV [Was: uparse - Parse Unicode strings]" for an improved version of the code; mostly thanks to ++jo37 and the subthread starting with "Re: uparse - Parse Unicode strings" and continued in "Decoding @ARGV [Was: uparse - Parse Unicode strings]".

In the last month or so, we've had a number of threads where emoji were discussed. Some notable examples: "Larger profile pic than 80KB?"; "Perl Secret Operator Emojis"; and "Emojis for Perl Monk names".

Many emoji have embedded characters which are difficult, or impossible, to see; for example, zero-width joiners, variation selectors, skin tone modifiers. In some cases, glyphs are so similar that it's difficult to tell them apart; e.g. 🧑 & 👨.

I wrote uparse to split emoji, strings containing emoji, and in fact any strings with Unicode characters, into their component characters.

```#!/usr/bin/env perl

BEGIN {
if (\$] < 5.007003) {
warn "\$0 requires Perl v5.7.3 or later.\n";
exit;
}

unless (@ARGV) {
warn "Usage: \$0 string [string ...]\n";
exit;
}
}

use 5.007003;
use strict;
use warnings;
use open IO => qw{:encoding(UTF-8) :std};
use constant {
SEP1 => '=' x 60 . "\n",
SEP2 => '-' x 60 . "\n",
FMT => "%s\tU+%-6X %s\n",
NO_PRINT => "\N{REPLACEMENT CHARACTER}",
};

use Encode 'decode';
use Unicode::UCD 'charinfo';

for my \$raw_str (@ARGV) {
my \$str = decode('UTF-8', \$raw_str);
print "\n", SEP1;
print "String: '\$str'\n";
print SEP1;

for my \$char (split //, \$str) {
my \$code_point = ord \$char;
my \$char_info = charinfo(\$code_point);

if (! defined \$char_info) {
\$char_info->{name} = "<unknown> Perl \$^V supports Unicode
+"
. Unicode::UCD::UnicodeVersion();
}

printf FMT, (\$char =~ /^\p{Print}\$/ ? \$char : NO_PRINT),
\$code_point, \$char_info->{name};
}

print SEP2;
}

Here's a number of example runs. All use <pre> blocks; a very few didn't need this but I chose to go with consistency.

Works with ASCII (aka Unicode: C0 Controls and Basic Latin)

```\$ uparse X XY "X        Z"

============================================================
String: 'X'
============================================================
X       U+58     LATIN CAPITAL LETTER X
------------------------------------------------------------

============================================================
String: 'XY'
============================================================
X       U+58     LATIN CAPITAL LETTER X
Y       U+59     LATIN CAPITAL LETTER Y
------------------------------------------------------------

============================================================
String: 'X      Z'
============================================================
X       U+58     LATIN CAPITAL LETTER X
�       U+9      <control>
Z       U+5A     LATIN CAPITAL LETTER Z
------------------------------------------------------------
```

The two similar emoji heads (mentioned above)

```\$ uparse 🧑 👨

============================================================
String: '🧑'
============================================================
------------------------------------------------------------

============================================================
String: '👨'
============================================================
👨      U+1F468  MAN
------------------------------------------------------------
```

A complex ZWJ sequence

```\$ uparse 👨🏽‍✈️

============================================================
String: '👨🏽‍✈️'
============================================================
👨      U+1F468  MAN
🏽      U+1F3FD  EMOJI MODIFIER FITZPATRICK TYPE-4
U+200D   ZERO WIDTH JOINER
✈       U+2708   AIRPLANE
U+FE0F   VARIATION SELECTOR-16
------------------------------------------------------------
```

Maps

```\$ uparse 🇨🇭

============================================================
String: '🇨🇭'
============================================================
🇨       U+1F1E8  REGIONAL INDICATOR SYMBOL LETTER C
🇭       U+1F1ED  REGIONAL INDICATOR SYMBOL LETTER H
------------------------------------------------------------
```

Handles codepoints not yet assigned; or not supported with certain Perl versions

```\$ uparse `perl -C -e 'print "X\x{1fa7c}X"'`

============================================================
String: 'X🩼X'
============================================================
X       U+58     LATIN CAPITAL LETTER X
🩼      U+1FA7C  CRUTCH
X       U+58     LATIN CAPITAL LETTER X
------------------------------------------------------------

\$ uparse `perl -C -e 'print "X\x{1fa7c}X"'`

============================================================
String: 'X🩼X'
============================================================
X       U+58     LATIN CAPITAL LETTER X
�       U+1FA7C  <unknown> Perl v5.30.0 supports Unicode 12.1.0
X       U+58     LATIN CAPITAL LETTER X
------------------------------------------------------------

\$ uparse `perl -C -e 'print "X\x{1fa7d}X"'`

============================================================
String: 'X🩽X'
============================================================
X       U+58     LATIN CAPITAL LETTER X
�       U+1FA7D  <unknown> Perl v5.39.3 supports Unicode 15.0.0
X       U+58     LATIN CAPITAL LETTER X
------------------------------------------------------------
```

Enjoy!

— Ken

Introducing the C Perl-Powered Pre-Processor
3 direct replies — Read more / Contribute
by NERDVANA
on Nov 09, 2023 at 02:03

For those developers who do both C and Perl, and frequently run into the upper limit of the C preprocessor, I have a treat for you!

It's still a little rough around the edges, and could use lots more features, but I think it's reached a point of usability where it's worth sharing.

Automate Outlook via Win32::OLE to extract PDFs from mails
by Corion
on Nov 02, 2023 at 04:46

This is my somewhat generic framework to process mails in specific folders in Outlook. The concrete use case here is to find and save PDFs that haven't been processed yet.

The script could also move mails or even reply to them, but the intention is to co-exist with human users of this shared mailbox, so the script scans several mail folders for files with an unknown name.

For more information on the object model (and especially the MailItem and Folder class), see the MS Outlook object model.

Fixing bad CSS in EPUB files
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.).

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