#! /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;
}

[download]

In reply to random noise background generator by cogent

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post, it's "PerlMonks-approved HTML":


  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.