#!/usr/bin/perl package Graphics::ColorPicker; use strict; #use diagnostics; use lib qw(./blib/lib); use vars qw($VERSION $msie_frame $colwidth $leftwidth $force_msie $obfuscate $server_only $use_mdown $image); use AutoLoader 'AUTOLOAD'; $VERSION = do { my @r = (q$Revision: 0.11 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; ################################################ # set some things, should not need to be changed ################################################ # NOTE: set var c24flip in sub picker for the initial dark or light palette $server_only = 0; # overides $obfuscate, $force_msie, $use_mdown, $p_gen::jsl # normally set to one for external client based xy resolution $obfuscate = 1; # overides force_msie, and frames(parameter) # forces jslib to be loaded by copyright page #### THIS SHOULD ALWAYS BE SET TO ONE !!! # the new xy resolution methods work for all clients $use_mdown = 1; # use new onMouseDown routines, overides client side $force_msie $force_msie = 0; # normally 0 set 1 to use msie stuff in netscape for debug $colwidth = 85; # width of columns, right side is 2X this $leftwidth = 450; # color picker width $image = 1; # starting picker image, 0=dark, 1=light ################################################ my $greyimg = 'grey.jpg'; my $darkimg = 'darkb409.jpg'; my $liteimg = 'liteb409.jpg'; my $size = 409; my $button = 38; ################################################ $_ = $colwidth << 1; $msie_frame = '
ColorPicker
© 2002-'. ((localtime())[5] + 1900). ' Michael Robinton
loading, please wait
'; if ($server_only) { $obfuscate = 0; $force_msie = 1; $use_mdown = 0; } $force_msie = 0 if ($use_mdown); # helper # return useable (force_msie, use_mdown) # sub _force_mdown { # only needed for Gecko unless ($server_only) { return (0,1) if $ENV{HTTP_USER_AGENT} =~ /GECKO/i; } return ($force_msie,$use_mdown); } =head1 NAME Graphics::ColorPicker : A perl module for WYSIWYG web applications that allow selection of HEX color numbers =head1 SYNOPSIS use Graphics::ColorPicker; or require Graphics::ColorPicker; make_page($path_to_images); send_page(\$html_txt,$type); $time_string = http_date($time); $name = script_name; $html_text=frames($websafe); $html_text = msie_frame; $html_text=picker($darkimg,$liteimg,$size,$bsize,greyimg); $html_text=no_picker; $html_text=cp216_ds($clrdot,$border,$square) $javascript_text = jslib; $html=make_buttons(\%look_n_feel,$url,$active,\@buttons,$xtra); $html_text=pluck($color); $html_text=hex_update($hex_color); =head1 SAMPLE WEBSITE - 24 million color picker =head2 L =head1 DESCRIPTION This module generates a set of palettes to select a HEX or DECIMAL color number via a web browser. B can be called by C from your web page and will set the HEX value in a variable in the calling page and scope. The selector page can be created for 24 million or web safe colors only.

web safe colors only
See B and B Read INSTALL =over 4 =item make_page($path_to_images); Generate Color Picker Pages This is the only routine that really needs to be called externally. You could roll your own from the following calls for a special purpose, but it's really not necessary. i.e. Graphics::ColorPicker::make_page('./'); will generate the picker pages as required =cut sub make_page { my ($dir) = @_; my ($x,$y,$html,$scale,$type); if ( $ENV{QUERY_STRING} =~ /what=picker/) { # color picker page $html = &picker($dir.$darkimg,$dir.$liteimg,$size,$button,$dir.$greyimg); } elsif ($ENV{QUERY_STRING} =~ /what=no_picker/) { # blank minimum color picker page $html = &no_picker; } elsif ($ENV{QUERY_STRING} =~ /what=digits/) { # digits page $html = &cp216_ds($dir.'cleardot.gif'); } # accomodate dumb browsers that don't understand all of javascript1.1 # or use server base XY resolution elsif ($ENV{QUERY_STRING} =~ /what=(msie)/) { $html = &msie_frame; } # need for MSIE workaround, mostly browser side update # preferred method elsif ($ENV{QUERY_STRING} =~ /what=(color)/ || $ENV{QUERY_STRING} =~ /what=(grey)/) { $html = &pluck($1,$size,$button); } elsif ($ENV{QUERY_STRING} =~ /what=init/) { $_ = ($ENV{QUERY_STRING} =~ /hex=[\#]*([0-9a-fA-F]{6})/) ? $1 : '000000'; $html = &hex_update($_); } elsif ($ENV{QUERY_STRING} =~ /what=jslib/) { $html = &jslib; $type = 'application/x-javascript'; } elsif ($ENV{QUERY_STRING} =~ /what=wo/) { # frames for web safe colors only $html = &frames(1); } else { # call frames for browser based xy resolution, 24 megacolors $html = &frames(0); } &send_page(\$html,$type); } =item send_page(\$html_txt,$type); Sends a page of html text to browser. Uses Apache mod_perl if available input: \$html text, $type, # text/html, text/plain, etc... =cut ################################################# # send a page to the browser, use mod_perl if available # # input: pointer to text, content-type [optional] # sends: text to server # # default content type = text/html # if not specified # sub send_page { my ($hp,$type) = @_; $type = 'text/html' unless $type; my $size = length($$hp); my $now = time; my $r; eval { require Apache; $r = Apache->request; }; unless ($@) { # unless error, it's Apache $r->status(200); $r->content_type($type); $r->header_out("Content-length","$size"); $r->header_out("Last-modified",http_date($now)); $r->header_out("Expires",http_date($now)); $r->send_http_header; $r->print ($$hp); return 200; # HTTP_OK } else { # sigh... no mod_perl print q |Content-type: |, $type, q| Content-length: |, $size, q| Last-modified: |, http_date($now), q| Connection: close Expires: |, http_date($now), qq| |, $$hp } } =item $time_string = http_date($time); Returns time string in HTTP date format, same as... Apache::Util::ht_time(time, "%a, %d %b %Y %T %Z",1)); i.e. Sat, 13 Apr 2002 17:36:42 GMT =cut sub http_date { my($time) = @_; my($sec,$min,$hr,$mday,$mon,$yr,$wday) = gmtime($time); return (qw(Sun Mon Tue Wed Thu Fri Sat))[$wday] . ', ' . # "%a, " sprintf("%02d ",$mday) . # "%d " (qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec))[$mon] . ' ' . # "%b " ($yr + 1900) . ' ' . # "%Y " sprintf("%02d:%02d:%02d ",$hr,$min,$sec) . # "%T " 'GMT'; # "%Z" } =item $name = script_name; Returns the subroutine name of the calling script external to this library =cut ############################################### # MUST NOT BE AUTOLOADED ############################################### # return the name of the script that called this library # # input: none # returns: script name # sub script_name { for (my $i=1;$i<4;$i++) { # find script name, fail after a few tries @_ = split('/',(caller($i))[1]); my $rv = pop @_; return $rv unless __FILE__ =~ /$rv$/; } } # define autoload subroutines sub frames; sub msie_frame; sub picker; sub no_picker; sub cp216_ds; sub jslib; sub j2s; sub make_buttons; sub pluck; sub env_dumb_browser; sub hex_update; sub DESTROY {}; 1; __END__ =item $html_text=frames($websafe); Returns the frame text for top window. input: true = 24 million colors false = web safe colors only return: html text for page =cut ################################################ # return new frames page # # input: false = 24 million colors, true = web safe # returns: top window html frames text # sub frames { my ($websafe) = @_; my $jsl = ($server_only) ? '' : '&jsl=1'; my $hex = ($ENV{QUERY_STRING} =~ /hex=[\#]*([0-9a-fA-F]{6})/) ? "?what=init&hex=$1" : '?what=init'; my $head = q| Color Picker - www.bizsystems.com |; my ($fmie,$umd) = &_force_mdown; my $gen_name = script_name; $_ = ( $obfuscate || $fmie || &env_dumb_browser ) ? $gen_name . '?what=msie' : 'javascript:\"' . $msie_frame . '\"'; $head .= q| | if $jsl && ! $obfuscate; my $what = 'picker'; if ( $websafe ) { $what = 'no_picker'; $leftwidth = 0; } my $sc = 'no'; # scrolling -- normally no, yes for debug return $head . q| |; } =item $html_text = msie_frame; Return the text for the copyright notice (sample frame) for browsers that can't do "javascript:xxx()" from within a frame like brain dead MSIE browsers. =cut ################################################ # return MSIE frame contents # only used by brain dead MSIE that does not # recognize javascript1.2 stuff in frames, sigh.... # # input: none # returns: html text for sample frame # sub msie_frame { return $msie_frame unless $obfuscate; my $jsl = &jslib; &j2s(\$jsl); my $n = ''; foreach (0..200) { $n .="\n"; # bunch of endlines } return q| | . $msie_frame . $n .q| |; } =item $html_text=picker($darkimg,$liteimg,$size,$bsize,greyimg); Return frame text for color picker input: $darkimg, # path to dark image $liteimg, # path to light image $size, # pixel size of image $bsize, # button pixel size $greyimg # path to grey image returns: html text =cut ################################################# # return color picker page # # input: darkimage, # dark image path/file # liteimage, # lite image path/file # $size, # image size (pixels) # $bsize, # button size (pixels) # greyimage # grey stripe path/file # # returns: html text for color picker page # sub picker { my ($drkimg,$litimg,$size,$bsize,$gryimg) = @_; my $cx = 10; # offset of color image my $cy = 10; my $gx = 430; # offset of grey image my $gy = 90; my $gen_name = script_name; my $img = $image ? $litimg : $drkimg; my ($fmie,$umd) = &_force_mdown; my $head = q| |; my ($cref,$gref); if ($umd) { $cref = q|"javascript:void('');//" onMouseDown="return(cpxy(event));"|; $gref = q|"javascript:void('');//" onMouseDown="return(gpxy(event));"|; } elsif ($fmie || &env_dumb_browser || $ENV{QUERY_STRING} !~ /jsl=1/i) { $cref = q|"javascript:void('');//" onMouseDown="return(msie_wa(event,'color'));"|; $gref = $gen_name . q|?what=grey|; } else { $cref = q|'javascript:""//'|; $gref = q|'javascript:""//'|; } my $c24m = q|
|; my $cgrey = q|
|; return $head . q|  
|. $c24m . q| |. $cgrey . q|
|; } # end picker page =item $html_text=no_picker; Returns minimum contents for a blank 24 million color page when only "Web Only" colors are called =cut sub no_picker { return q | This frame is empty |; } =item $html_text=cp216_ds($clrdot,$border,$square) Returns 216 color & digits page input: clrdot, # path to clear dot image border, # border of color square square, # square size returns: html text =cut ################################################ # return 216 color page and digits # # input: clear dot image, # border [default 0] # square size [default 9] # returns: html text for 216 color page & digits # sub cp216_ds { my ($clrimg,$border,$size) = @_; $clrimg =~ m|([^/]+)$|; my $updimg = $` . 'updown.gif'; $border = 0 unless $border; $size = 9 unless $size; $size -= $border; my $head .= q| |; ##################################### my $num = 0; my $digitbox = q|
web colors
RED
  
GREEN
  
BLUE
  
hex color
|; ########################################## my $colortab = q|
|; my @forward = ('00','33','66','99','CC','FF'); my @reverse = reverse @forward; my $c = 0; my ($r,$g,$b); my $line = sub { my ($r,$g,$b,$n) = @_; return qq| \n|; }; foreach $b (@forward) { foreach $g (@forward) { foreach $r (@reverse) { # next if $separate && $r eq $b && $r eq $g; if ( ++$c > 6 ) { $colortab .= qq|\n\n|; $c = 1; } $colortab .= &$line($r,$g,$b,$num++); } } } #unless ( $separate ) { $colortab .= "\n\n"; foreach (@reverse) { $colortab .= &$line($_,$_,$_,$num++) } #} $colortab .= q|
$r$g$b
|; # use on click as workaround for buggy Opera browser. my $butable = [ # 'Submit' => 'javascript:void doSubmit();', 'Submit' => 'javascript:void(0);" OnMouseDown="doSubmit();return false;', '','', # 'Restore' => 'javascript:void doRestore();', 'Restore' => 'javascript:void(0);" OnClick="doRestore();return false;', '','', 'Close' => 'javascript:void (0);" OnClick="parent.close();return false;', ]; return $head . q|
|. $colortab . q| |. $digitbox . &make_buttons('#0000cc',60,$butable) . qq| $VERSION
|; } =item $javascript_text = jslib; Return contents of javascript library input: none =cut ################################################ # javascript xy resolver library # # input: none # return: library text # sub jslib { return '' if ($obfuscate && (caller(1))[3] !~ /::msie_frame/); return q| // copyright 2002 // Michael A. Robinton, michael@bizsystems.com var r; var g; var b; colorpluck = function() { pluckXY(arguments[0]); if ( px > blim && py > blim ) return(window._digits.flipc24m()); px -= mv; py = mv - py; r = color_R(px,py); if (r > 255) return true; // have to return something if (color_GB(px,py)) return true; // ditto if (window._picker.c24flip != 0) { r = 255 - r; g = 255 - g; b = 255 - b; } setcolor(r,g,b); return true; } var con = 2.236067977; color_R = function(x,y) { if (x < 0) x = -x; r = y + (x/2); if (r < 0) return 0; r = (con * r * sf) + 1; r >>= 1; if (r == 256) return 255; return r; } color_GB = function(x,y) { y = -y * sf; x *= sf; b = y + x/2; g = y - x/2; if (b < 0) b = 0; if (g < 0) g = 0; if (x < 0) { g = b - x; } else { b = g + x; } b = (con*b + 1) >>1; g = (con*g + 1) >>1; if (g > 256) return g; if (b > 256) return b; if (g > 255) g = 255; if (b > 255) b = 255; return 0; } greypluck = function() { pluckXY(arguments[0]); if (py > 255) py = 255; py = 255 - py; setcolor(py,py,py); return true; } pluckXY = function(skip) { if ( ! skip ) { var xy = window._data.document.location.search; var qloc = xy.lastIndexOf('?') + 1; var cloc = xy.lastIndexOf(','); px = bound(xy.substring(qloc,cloc)); py = bound(xy.substring(cloc+1,xy.length)); } } bound = function(n) { n = 0 + n; if (isNaN(n)) return 0; if (n < 0) n = 0; return n; } setcolor = function(r,g,b) { with (window._digits) { rgb[0] = r; rgb[1] = g; rgb[2] = b; setrgb(); sethex(); } return true; } |; } ######################################### # replace problematic characters in js lib # sub j2s { my ($tp) = @_; # sub operation $$tp =~ s/%/%j/g; $$tp =~ s/\\/%a/g; $$tp =~ s/'/%v/g; $$tp =~ s/\$/%s/g; $$tp =~ s/"/%c/g; $$tp =~ s/\@/%r/g; # $$tp =~ s//%i/g; $$tp =~ s/\r/%p/g; $$tp =~ s/\n/%t/g; 1; } =item $html=make_buttons(\%look_n_feel,$url,$active,\@buttons,$xtra); Called internally Return the html text for a button bar input: button_color, width, \@buttons @buttons is a list of the form = ( # text command 'BUTT1' => 'command1', 'BUTT2' => 'command2', '' => '', # empty ); If the button text is false, a spacer is inserted in the button bar returns: html for button bar NOTE: class NU must be defined example: =cut sub make_buttons { my ($bc,$width,$but) = @_; my $butbar = qq| |; for (my $i=0; $i<= $#{$but}; $i+=2) { if ($but->[$i+1]) { $butbar .= q||; } else { $butbar .= q||; } $butbar .= qq|\n\n|; } $butbar .= qq|
$but->[$i]
 
\n|; } =item $html_text=pluck($color, ...); Return x,y coordinates for browsers that do not recognize "javascript:xxx" from within frames like braindead MSIE input: color, 'grey' or 'color' ...server_update args (if used); =cut ################################################ # return xy plucker page, generally only used by MSIE # # input: start of subroutine name # i.e. 'color', 'grey' # colorpluck or greypluck # returns: html text with x,y stuff from 'ismap' # sub pluck { if ($server_only) { require Graphics::CPickServer; goto &Graphics::CPickServer::server_update; } my ($subhead) = @_; return q| |; } =item $html_text=hex_update($hex_color); Return the command and color number to the 'data' frame to force an update of the 'sample' frame and 'digits' input: hex color # i.e. 6699CC =cut ################################################ # return hex update page to server # used for init and by grey_update and rgb_update # though it can be used directly if fed the parameters # # input: hex number # returns: html text # sub hex_update { my ($hex) = @_; $_ = $hex; $hex = '000000' unless $hex =~ /^[a-fA-F0-9]{6}$/; return q| |; } =item $rv = env_dumb_browser; Return true if $ENV{HTTP_USER_AGENT} contains a dumb browser =back =cut sub env_dumb_browser { return 1 if $ENV{HTTP_USER_AGENT} =~ /MSIE/i; # return 1 if $ENV{HTTP_USER_AGENT} =~ /GECKO/i; return 0; } =head1 EXPORT None by default. =head1 AUTHOR Michael Robinton, michael@bizsystems.com =head1 COPYRIGHT and LICENSE Copyright 2002 - 2008 Michael Robinton, BizSystems. This module is free software; you can redistribute it and/or modify it under the terms of either: a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" which comes with this module. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the GNU General Public License or the Artistic License for more details. You should have received a copy of the Artistic License with this module, in the file ARTISTIC. If not, I'll be glad to provide one. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA =cut 1;