File Coverage

ColorPicker.pm

Criterion	Covered	Total	%
statement	12	59	20.3
branch	0	30	0.0
condition	0	3	0.0
subroutine	4	11	36.3
pod	4	5	80.0
total	20	108	18.5

#!/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.17 $ =~ /\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 Robintonloading, 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;
  $butabref = buttontext([optional array ref])
  $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

=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.

   </td>
</tr>

<tr>
<td  class="h" >
<a name="105">105</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   var colorhex = ''; </td>
</tr>

<tr>
<td  class="h" >
<a name="106">106</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   var w; </td>
</tr>

<tr>
<td  class="h" >
<a name="107">107</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   function pop() { </td>
</tr>

<tr>
<td  class="h" >
<a name="108">108</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">     if (document.forms.color.what.checked){w=180;}else{w=630;} </td>
</tr>

<tr>
<td  class="h" >
<a name="109">109</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">     var colorwin = open("","colorpicker", </td>
</tr>

<tr>
<td  class="h" >
<a name="110">110</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">     "width=" + w + ",height=440,status=no,directories=no," + </td>
</tr>

<tr>
<td  class="h" >
<a name="111">111</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">     "location=no,menubar=no,scrollbars=no,toolbar=no"); </td>
</tr>

<tr>
<td  class="h" >
<a name="112">112</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">     if (colorwin.opener == null) newin.opener = self;   </td>
</tr>

<tr>
<td  class="h" >
<a name="113">113</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">     colorwin.document.close(); </td>
</tr>

<tr>
<td  class="h" >
<a name="114">114</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">     colorwin.focus(); </td>
</tr>

<tr>
<td  class="h" >
<a name="115">115</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">     return true; </td>
</tr>

<tr>
<td  class="h" >
<a name="116">116</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   } </td>
</tr>

<tr>
<td  class="h" >
<a name="117">117</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">


   action="p_gen.cgi" target="colorpicker">

   web safe colors only



  See B and B
  Read INSTALL

NOTE: as of version 0.13 ColorPicker can be used in a captive frame to
dynamically update color values in the DOM.

  See B,
      B and
      B

=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$/;
  }
}

=item $but_table_ref = buttontext([optional ref]);

  Always return and optionally set the contents of cp216_ds button text.

    input:	optional reference to button table array
    returns:	reference to button table array

  Default contents:

  my $butable = [
    'Submit'   => 'javascript:void(0);" OnMouseDown="doSubmit();return false;',
    '','',
    'Restore'  => 'javascript:void(0);" OnClick="doRestore();return false;',
    '','',
    'Close'    => 'javascript:void (0);" OnClick="parent.close();return false;',
  ];

=cut

# use on click as workaround for buggy Opera browser.
my $_butab = [
#	'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;',
];

sub buttontext {
  if (@_) {
    $_butab = $_[0];	# set new button table values
  }
  $_butab;		# always return the reference
}

# 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__