http://qs321.pair.com?node_id=45624
Category: CGI Programming
Author/Contact Info David "cogent" Hand
Description:

CGI to create a random "noise" PNG as a background image. Fully configurable through CGI parameters. As an example, see the background image at my own Web site. (Netscape 4 totally screws up my CSS, but that doesn't impact the background image. And Non-CSS-enabled browsers probably can't see it at all. Check out the raw image, instead.)

There are three parameters:

  • height: The height of the image (in a background image, set high enough so that the repeat doesn't look too bad).
  • widths: The widths of the left gutter, the left border, the primary "noise" section, the right border, and the right gutter, in that order, separated by commas.
  • colors: The colors available for each section. Each color within a section is separated by commas; each section is separated by underscores.

Colors are specified as hex triples, HTML-style.


#! /usr/local/bin/perl

# davidhand.com
# noise background
# images/noise3.cgi
#
#        Created: 2000-1107-1502  David Hand  <mailto:davidhand@davidh
+and.com>
#      Commented: 2000-1207-1519  David Hand  <mailto:davidhand@davidh
+and.com>
#      De-Sucked: 2001-0701-2058  David Hand  <mailto:davidhand@davidh
+and.com>
#
# Copyright (c) 2000, 2001 David Hand

use strict;
use warnings;

use CGI;
use GD;
use List::Util qw(sum);

#=====================================================================
+========
# Get Parameters
#---------------------------------------------------------------------
+--------
my $request = CGI->new();

my $DELIM_OUT   = '_';
my $DELIM_IN    = ',';

my $NUMBER_REGEX        = "((?:\\d+$DELIM_IN?)+)";
my $HEX_TRIPLE_REGEX    = "((?:(?:(?:0x|#)?[A-Fa-f0-9]{6}(?:\\(\\d+\%?
+\\))?$DELIM_IN?)*$DELIM_OUT?)*)";

my $DEFAULT_WIDTHS      = "0${DELIM_IN}0${DELIM_IN}100${DELIM_IN}0${DE
+LIM_IN}0";
my $DEFAULT_COLORS      = "#FFFFFF${DELIM_OUT}#000000${DELIM_OUT}#FFFF
+FF${DELIM_IN}#000000${DELIM_OUT}#000000${DELIM_OUT}#FFFFFF";
my $DEFAULT_HEIGHT      = "100";

my @widths = split (/$DELIM_IN/, &detaint('widths', $request,
                                          $DEFAULT_WIDTHS, $NUMBER_REG
+EX));
my @colors = map ({ [ split /$DELIM_IN/ ]; }
                  split (/$DELIM_OUT/,
                         &detaint('colors', $request,
                                  $DEFAULT_COLORS, $HEX_TRIPLE_REGEX
                                 )
                        )
                 );
# height parameter
my $height = &detaint('height', $request,
                      $DEFAULT_HEIGHT, $NUMBER_REGEX);

#=====================================================================
+========
# Process Image
#---------------------------------------------------------------------
+--------
my $image = GD::Image->new( sum(@widths), $height);

foreach my $colorlist (@colors) {
        &allocate_colors($image, $colorlist);
}

my $currleft = 0;
my $currright = $widths[1] - 1;
for (my $i = 0; $i < @colors; ++$i) {
        $currright += $widths[$i];
        &paint_rect($image,
                    $currleft, 0,
                    $currright, $height-1,
                    $colors[$i],
                   );
        $currleft += $widths[$i];
}

# Aww, hell.  We've gone to all this work.  Might as well spit out the
+ PNG.
binmode STDOUT;
print $request->header(-type=>'image/png');
print $image->png;

#=====================================================================
+========
# Helper Functions
#---------------------------------------------------------------------
+--------

# Get & detaint a CGI param, complete with a default if it's not defin
+ed.
sub detaint
{
        my $param = shift;
        my $request = shift;
        my $default = scalar (@_) ? shift : "";
        my $regex = scalar (@_) ? shift : "";

        my $return = "";

        if (defined ($return = $request->param($param))) {
                ($return) = $return =~ /$regex/;
                return $return;
        } else {
                return $default;
        }
}

# It's important to register your colors, in an indexed color format.
# The trick here is that we don't want to register a color that's
#   already been registered.
sub allocate_colors
{
        my ($image, $colors_ref) = @_;
        my $candidate;

        foreach my $hex (@{$colors_ref}) {
                if (($candidate = $image->colorExact(&hex2rgb($hex))) 
+== -1) {
                        $hex = $image->colorAllocate(&hex2rgb($hex));
                } else {
                        $hex = $candidate;
                }
        }

        return;
}

# Paint a rectangle.  If we're painting with a single color, don't go
#   to the extra effort of calculating a random number, or of painting
#   pixel-by-pixel.
sub paint_rect
{
        my $image = shift;
        my $x1 = shift; my $y1 = shift;
        my $x2 = shift; my $y2 = shift;
        my $colors_ref = shift;
        my $colorcount = scalar @{$colors_ref};

        return if $x2 <= $x1;  # refuse to create a zero- or negative-
+size box
        return if $y2 <= $y1;

        if ($colorcount == 1) {
                $image->filledRectangle($x1, $y1, $x2, $y2, $colors_re
+f->[0]);
        } else {
                for (my $x = $x1; $x <= $x2; $x++) {
                        for (my $y = $y1; $y <= $y2; $y++) {
                                $image->setPixel(
                                         $x, $y,
                                         $colors_ref->[int(rand($color
+count))]
                                );
                        }
                }
        }

        return;
}

# convert an HTML-style hexidecimal to a decimal triplet
sub hex2rgb
{
        my $hex = shift;

        $hex =~ s/^(0x|#)//;

        my $temp = pack('H6', $hex);    # pack the hex into raw binary
        my @rgb = unpack('C3', $temp);  # unpack the binary into a tri
+ple

        if (wantarray) {
                # if we want an array, do what this program was
                # originally intended to do
                return @rgb;
        } else {
                # if the user asks for a scalar, give her something
                # useful, rather than a constant 3 (the length of the
                # above array, in all situations).

                # luminance calculation from _Grokking the GIMP_, p. 1
+52
                my $luminance = $rgb[0]*0.3 + $rgb[1]*0.59 + $rgb[2]*0
+.11;
                return $luminance;
        }
}

# convert a decimal triplet to an HTML-style hexidecimal
# YEAH, I KNOW:  this isn't called anywhere.  I just figured I'd put i
+t
#   in, since I'd put in the inverse function.  Don't know where to pu
+t
#   them, permanently, so this'll do for now.
sub rgb2hex
{
        my @rgb = @_[0..2];

        my $temp = pack('CCC', @rgb);   # pack the triple into raw bin
+ary
        my $hex = unpack('H6', $temp);  # unpack the binary into hex f
+ormat

        return $hex;
}