Prossibly use Imager; it has methods like getcolorcount or getcolorusage where you could maybe look and see how used your watermark color is.

Edit: rough sample finding a single color. You'd need to walk the color histogram hash and maybe look and find how many pixels are using below whatever threshold of "too dark" pixel.

my $img = Imager->new->open( file => q{myfile.jpg} );
my $colors = $img->getcolorusagehash();
my $color_black = pack( q{CCC}, 0, 0, 0 );
say qq{True black used }, $colors->{$color_black}, qq{ times.}
[download]

Edit again: More thinking about it what I'd do (vague handwaving, but I offer a link!) is use the histogram hash and sort the keys (they're packed RGB values so when you sort them asciibetically it should do the right thing). You can compute a luminance value you consider "too dark" and then figure out what percentage of the image pixels are less than that value; if it's over whatever threshold, swap to your backup light color. Theoretically you could even copy out the subsection of your image where you're contemplating putting the watermark and just get the color usage for that subsection.

Another thought: Actually looking at your second sample image another option rather than changing the watermark color might be if it's too dark then just write it first 2 pixels larger in a lighter color and then write the dark version on top (so it'd be outlined).

Prossibly use Image

Nice thought and it looks like a very useful module...

But it's not an option as installation requires access to the compiler which I don't have on the shared hosting. So I have to use what's there or pure Perl modules.

Another thought: Actually looking at your second sample image another option rather than changing the watermark color might be if it's too dark then just write it first 2 pixels larger in a lighter color and then write the dark version on top (so it'd be outlined).

WoW! That's some selection of possible solutions from you Fletch. Thank you, it is certainly giving me some ideas to try out.

The idea of an outline by printing the text twice in different colours certainly has plenty of merit. Potentially it would eliminate the need to sample the background at all. If there's a dark outer part to the text and a lighter inner then one or other should contrast with the background sufficiently.

I may have to find two suitable TTF sources or find one and make a copy with slightly narrower font strokes so one sits inside the other. That shouldn't be a big problem.

... or use a font that is in itself an outline.

Some outline fonts.

G'day Bod,

In the documentation for stringFT() you'll see:

...stringFT($fgcolor, ...)
[download]

and a little after that:

fgcolor    Color index to draw the string in
[download]

In "GD: Color Control", you'll see how the create such an index.

I tried using a string with a colour name in multiple methods requiring a colour index (stringFT(), rectangle(), fill(), and others) and all gave the warning:

Argument "<colour name>" isn't numeric in subroutine entry at ...
[download]

If I don't use the warnings pragma, I don't see those warnings. Are you using warnings? If so, have you checked in your web server's error log?

So, instead of the string 'silver', you want the return value of colorAllocate(192,192,192). If you're unfamiliar with that RGB format, take a look at "RGB Colour Code". You'll want to make similar changes for other named colours.

A few of other points regarding your code:

• You have used Indirect Object Syntax in the code you posted. Please follow that link, read the emboldened discouragement at the start of that section; then read on for the reasons to avoid it.
• There are variables used that are (presumably) defined elsewhere (I noted %file and %data). This means that other code might also be using, and possibly modifying, them: there may be side-effects. Aim to pass needed data to subroutines as arguments and keep a tight rein on what's used and where.
• As far as I can tell, $file{'joolzimage', 'file'} is a "Multi-dimensional array emulation". This is ancient code, used in Perl4, before references became available in Perl5. Aim to use "real" multidimensional arrays; e.g. $file{joolzimage}{file}.

Thanks kcott. This is all very helpful.

I shall have a good look at the colour points later today. No, I am not using warnings. I'm a relatively new convert to use strict; as you will see from Backdating strict posted just 2 months ago. As always, that was good advice from the Monastery!

• There are variables used that are (presumably) defined elsewhere (I noted %file and %data). This means that other code might also be using, and possibly modifying, them: there may be side-effects. Aim to pass needed data to subroutines as arguments and keep a tight rein on what's used and where.
• As far as I can tell, $file{'joolzimage', 'file'} is a "Multi-dimensional array emulation". This is ancient code, used in Perl4, before references became available in Perl5. Aim to use "real" multidimensional arrays; e.g. $file{joolzimage}{file}.

Back in the 1990's I sort of learnt Perl by looking at other people's code which was in a CGI environment. I get the feeling the code I was looking at wasn't very well written to start with and I was trying to get things to work using that as a guide and no formal background in programming or computer science. I look back occasionally at code from those days and wonder how I ever got it working and amazement that some of it is still working today!

The code that generates %data and %file sits in a require file on all my websites except this latest one. Here I have taken the advice of the Monastery and not only used Template, but also extracted the require *.pl; into a use *; module instead.

package Site::Common;

use strict;

use DBI;
use DBD::mysql;
use Exporter;
use Template;
use Site::Variables;

our @ISA = qw(Exporter);
our @EXPORT = qw(%data %file $template);

my %cookie = ($ENV{'HTTP_COOKIE'}.';') =~ /(\S+)=(\S+);/g;

# Some subs removed...

our (%data, %file);
if ($ENV{'GATEWAY_INTERFACE'}) {
    my $query_string;
    $query_string = $ENV{'QUERY_STRING'} if $ENV{'QUERY_STRING'};
    if ($ENV{'REQUEST_METHOD'} eq 'POST') {
        if ($ENV{'CONTENT_TYPE'} =~ /^multipart\/form-data/i) {
            my ($key, $name);
            my $boundary = <STDIN>;
            chomp $boundary;
            binmode STDIN;
            local $/;
            my @parts = split /$boundary?/, <STDIN>;
            foreach my $p(@parts) {
                if ( $p =~ /^\s*Content-Disposition: +form-data; +name
+=\"(\w+)?\"(; +filename=\"(.+)?\")?\r\n/i ) {
                    $key  = $1;
                    $name = $3;
                    if ( $p =~ /Content-Type: +(\w+\/\w+)?\r\n/i ) {
                        $file{$key, 'type'} = $1;
                        $file{$key, 'name'} = $name;
                        (undef, $file{$key, 'file'}) = split /\r\n\r\n
+/, $p, 2;
                        $data{$key} = 'FILE';
                    } else {
                        (undef, $data{$key}) = split /\r\n\r\n/, $p, 2
+;
                        $data{$key} =~ s/(\r|\n)+$//g;
                    }
                }
            }
        } else {
            $query_string .= '&' if $query_string;
            $query_string .= <STDIN>;
        }
    }
    if ($query_string) {
        my @pairs = split /&/, $query_string;
        foreach my $p(@pairs) {
            $p =~ tr/+/ /;
            $p =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
            my ($key, $val) = split /=/, $p, 2;
            $data{$key} = $val;
        }
    }
    chomp %data;
}


1;
[download]

This is code I wrote a long time ago to deal with form uploads from websites. It followed much frustration with CGI. Essentially it puts all the upload parameters as key/value pairs into %data and any file uploads into %file with the first dimension of the hash being the web form's input name and the second being either 'file' for the actual binary file content or 'name' for the filename.

So, no - this doesn't get changed by other code.

With the knowledge I have gained in the past couple of months from the Monastery, I plan to refactor this code but in a way that it still exports those two variables so it doesn't break all the existing web scripts. At the same time I will add better methods to access the same data. Being extracted to a module should pave the way for it to be refactored.

There is a lot of what can only be called legacy code on my webserver...refactoring it without breaking anything is going to be a challenge!

Edit - corrected typo...thanks AnomalousMonk for pointing it out

Another approach is to create your watermark on a transparent image of the same size (for simplicity) as the original. Ending with 2 images. Then you overlay those images using an appropriate blending mode which GD maybe has it built-in or create your own (warning: this example uses PHP's GD API which I am not sure is the same as that provided for Perl). To experiment with blending modes use gimp or photoshop if you own one and check layer modes

Another way similar to Fletch's is to sample a neighbourhood of original image's pixels around each of the watermark's non-transparent pixels. And pick the watermark pixel color (so no borders) to stand out using the color-wheel, there's a lot of theory about that and some simple equations to get "opposite" colors.

bw, bliako

Thank you Monks for your suggestions...
I now have the code working which I share in case anyone else needs to do something similar.

######################
# Upload artwork image
sub XHRupload {
    no strict 'subs';
    my $full;
    my $image = Image::Resize->new(GD::Image->new($file{'joolzimage', 
+'file'}));
    if ($image->width() > 1800) {
        $full = $image->resize(1800, 99999);
    } else {
        $full = $image->gd();
    }
    
    my $year    = (localtime)[5] + 1900;
    my $watermark    = 'Artwork by Joolz';
    my $copyright    = "copyright $year";

    # Centre text components on image
    my $colour    = $full->colorAllocate(0, 0, 0);
    my @bounds    = new GD::Image->stringFT($colour, "$ENV{'DOCUMENT_R
+OOT'}/cgi-bin/Image/outline.ttf", 90, 0.18, 0, 0, $watermark); 
    my $left       = ($full->width() / 2) - (($bounds[2] - $bounds[0])
+ / 2) + 5;
    my $top        = ($full->height() / 2) - ($bounds[7] - $bounds[1])
+ / 2;
    
    # Select colour
    my ($rd, $gn, $bl) = (0, 0, 0);
    for (my $x = $left; $x < $left + ($bounds[2] - $bounds[0]); $x += 
+20) {
        for (my $y = $top - 450; $y < $top + 130; $y += 20) {
            my ($r, $g, $b) = $full->getPixel($x, $y);
            $bl = 255 - $r if 255 - $r > $rd;
            $rd = 255 - $g if 255 - $g > $gn;
            $gn = 255 - $b if 255 - $b > $bl;
        }
    }
    $rd = 120 if $rd > 120;
    $gn = 120 if $gn > 120;
    $bl = 120 if $bl > 120;
    $colour        = $full->colorAllocate($rd, $gn, $bl);

    $full->stringFT($colour, "$ENV{'DOCUMENT_ROOT'}/cgi-bin/Image/outl
+ine.ttf", 90, 0.18, $left, $top, $watermark); 
    @bounds        = new GD::Image->stringFT($colour, "$ENV{'DOCUMENT_
+ROOT'}/cgi-bin/Image/watermark.ttf", 95, 0.18, 0, 0, $copyright); 
    $left       = ($full->width() / 2) - (($bounds[2] - $bounds[0]) / 
+2) + 5;
    $full->stringFT($colour, "$ENV{'DOCUMENT_ROOT'}/cgi-bin/Image/wate
+rmark.ttf", 95, 0.18, $left, $top + 160, $copyright); 

    open my $fh, '>', "$ENV{'DOCUMENT_ROOT'}/artwork/full/$data{'id'}.
+jpg";
    print $fh $full->jpeg(100);
    close $fh;
    
    my $thumb = $image->resize(300, 1000);
    open $fh, '>', "$ENV{'DOCUMENT_ROOT'}/artwork/thumbs/$data{'id'}.j
+pg";
    print $fh $thumb->jpeg(32);
    close $fh;
    
    print "Content-type: text/plain\n\n";
    print $data{'id'};
    exit 0;
}
[download]

I still have to change from Indirect Object Syntax as pointed out by kcott and there are some other parts that need tidying. Plus, the watermark code is not as clever as it could be. The text colour starts as black - RGB 0, 0, 0. The code samples the portion of the image where the text will be going and increases the RGB values as higher value pixels are found but the colours are staggered so greater RED increases the BLUE value. Finally these are capped at 120 so that the text cannot get too light as there will always be a white picture mount.

Result one
Result one

To check the code was sampling in the correct place, I used setPixel($x, $y, $colour); so that I could see a grid of small black dots covering the area to be sampled. Once happy it was in the right place, I changed it to getPixel($x, $y)