our
$VERSION
=
'0.05'
;
sub
new {
my
(
$class
,
%params
) =
@_
;
my
$self
=
bless
{},
$class
;
eval
{
my
$cgi
= CGI->new();
$self
->cgi(
$cgi
);
my
$cgi_params
=
$self
->{cgi}->Vars;
$self
->cgi_params(
$cgi_params
);
my
$page_title
=
exists
$params
{page_title}
?
$params
{page_title}
:
"Geographical Display"
;
$self
->page_title(
$page_title
);
exists
$params
{base_sql_table}
or croak(
"A base_sql_table param is required!"
);
$self
->base_sql_table(
$params
{base_sql_table});
exists
$params
{base_sql_fields}
or croak(
"A base_sql_fields param is required!"
);
$self
->base_sql_fields(
$params
{base_sql_fields});
exists
$params
{base_output_headers}
or croak(
"A base_output_headers param is required!"
);
$self
->base_output_headers(
$params
{base_output_headers});
my
$param_fields
=
exists
$params
{param_fields} ?
$params
{param_fields} : {};
$self
->param_fields(
$param_fields
);
exists
$params
{gmap_key} or croak(
"A gmap_key param is required!"
);
$self
->gmap_key(
$params
{gmap_key});
exists
$params
{gmap_key} or croak(
"A gmap_key param is required!"
);
$self
->gmap_key(
$params
{gmap_key});
exists
$params
{temp_dir} or croak(
"A temp_dir param is required!"
);
$self
->temp_dir(
$params
{temp_dir});
exists
$params
{temp_dir_eq}
or croak(
"A temp_dir_eq param is required!"
);
$self
->temp_dir_eq(
$params
{temp_dir_eq});
my
$install_dir
=
exists
$params
{install_dir}
?
$params
{install_dir}
:
$self
->temp_dir;
$self
->install_dir(
$install_dir
);
my
$install_dir_eq
=
exists
$params
{install_dir_eq}
?
$params
{install_dir_eq}
:
$self
->temp_dir_eq;
$self
->install_dir_eq(
$install_dir_eq
);
HTML::GMap::Files->new(
temp_dir
=>
$self
->install_dir);
my
$session_id
=
$self
->cgi->param(
'session_id'
);
my
$session_dir
=
$self
->temp_dir .
'/sessions'
;
my
$session
=
CGI::Session->new(
'file'
,
$session_id
, {
Directory
=>
$session_dir
});
if
(
$session_id
&&
$session_id
ne
$session
->id) {
croak(
"Cannot create session!"
);
}
$self
->session_id(
$session
->id);
$self
->session(
$session
);
$self
->legend_field1(
$params
{legend_field1});
$self
->legend_field2(
$params
{legend_field2});
my
$max_hires_display
=
exists
$params
{max_hires_display}
?
$params
{max_hires_display}
: 100;
$self
->max_hires_display(
$max_hires_display
);
my
$center_latitude
=
exists
$params
{center_latitude}
?
$params
{center_latitude}
: 40.863233;
$self
->center_latitude(
$center_latitude
);
my
$center_longitude
=
exists
$params
{center_longitude}
?
$params
{center_longitude}
: -73.466566;
$self
->center_longitude(
$center_longitude
);
my
$center_zoom
=
exists
$params
{center_zoom}
?
$params
{center_zoom}
: 4;
$self
->center_zoom(
$center_zoom
);
$self
->messages(
$params
{messages});
$self
->header(
$params
{header});
$self
->footer(
$params
{footer});
$self
->hires_shape_keys(
$params
{hires_shape_keys});
$self
->hires_shape_values(
$params
{hires_shape_values});
$self
->hires_color_keys(
$params
{hires_color_keys});
$self
->hires_color_values(
$params
{hires_color_values});
my
$image_height_pix
=
exists
$params
{image_height_pix} ?
$params
{image_height_pix} : 600;
$self
->image_height_pix(
$image_height_pix
);
my
$image_width_pix
=
exists
$params
{image_width_pix} ?
$params
{image_width_pix} : 600;
$self
->image_width_pix(
$image_width_pix
);
my
$tile_width_pix
=
exists
$params
{tile_width_pix} ?
$params
{tile_width_pix} : 60;
$self
->tile_width_pix(
$tile_width_pix
);
my
$tile_height_pix
=
exists
$params
{tile_height_pix} ?
$params
{tile_height_pix} : 60;
$self
->tile_height_pix(
$tile_height_pix
);
my
$cluster_field
=
exists
$params
{cluster_field} ?
$params
{cluster_field} :
'_default'
;
$self
->cluster_field(
$cluster_field
);
my
$gmap_main_css_file
=
exists
$params
{gmap_main_css_file}
?
$params
{gmap_main_css_file}
:
'gmap-main.css'
;
$self
->gmap_main_css_file(
$gmap_main_css_file
);
my
$gmap_main_html_file
=
exists
$params
{gmap_main_html_file}
?
$params
{gmap_main_html_file}
:
'gmap-main.html'
;
$self
->gmap_main_html_file(
$gmap_main_html_file
);
my
$gmap_main_js_file
=
exists
$params
{gmap_main_js_file}
?
$params
{gmap_main_js_file}
:
'gmap-main.js'
;
$self
->gmap_main_js_file(
$gmap_main_js_file
);
my
$prototype_js_file
=
exists
$params
{prototype_js_file}
?
$params
{prototype_js_file}
:
'prototype.js'
;
$self
->prototype_js_file(
$prototype_js_file
);
my
$db_access_params
=
$params
{db_access_params};
if
(
$db_access_params
) {
if
(
ref
(
$db_access_params
)
and
ref
(
$db_access_params
) eq
'ARRAY'
) {
my
(
$datasource
,
$username
,
$password
) =
@$db_access_params
;
$db_access_params
= {
database
=> [{
alias
=>
'default'
,
datasource
=>
$datasource
,
username
=>
$username
,
password
=>
$password
,
}
]
}
}
$self
->db_access_params(
$db_access_params
);
my
$database
=
$self
->{cgi_params}->{database};
my
@available_databases
=
(
ref
(
$db_access_params
->{database})
and
ref
(
$db_access_params
->{database}) eq
'ARRAY'
)
? @{
$db_access_params
->{database}}
: (
$db_access_params
->{database});
unless
(
@available_databases
) {
croak(
"No database specified!"
);
}
if
(!
$database
) {
$database
=
$available_databases
[0]->{alias};
}
my
$selected_db
=
first {
$_
->{alias} eq
$database
}
@available_databases
;
if
(!
defined
(
$selected_db
)) {
croak(
"Cannot determine database ($database)!"
);
}
my
$dbh
= DBI->
connect
(
$selected_db
->{datasource},
$selected_db
->{username},
$selected_db
->{password},
{
PrintError
=> 1,
RaiseError
=> 1}
) || croak(
"Cannot connect to database!"
);
$self
->dbh(
$dbh
);
$self
->db_selected(
$database
);
$self
->db_display(
$selected_db
->{display});
}
my
$request_url_template
;
if
(
exists
$params
{request_url_template}) {
if
(
$params
{request_url_template} =~ /session_id=/) {
croak(
"request_url_template cannot contain a session_id, "
.
"session_id must be incorporated by this module!"
);
}
$request_url_template
=
$params
{request_url_template};
my
$session_id_param
=
'session-id='
.
$self
->session_id;
$request_url_template
=~
s/session_id=[^\;\&]+/session_id=
$session_id
/;
}
else
{
my
(
$default_request_url_template
) =
$self
->cgi->self_url =~ /^([^\?]+)/;
my
@additional_params
;
if
(
$self
->db_selected) {
push
@additional_params
,
'database='
.
$self
->db_selected;
}
exists
$params
{initial_format}
or croak(
"A initial_format param is required if "
.
"request_url_template is not specified!"
);
my
$initial_format
=
$params
{initial_format};
if
(
$initial_format
ne
'xml-piechart'
&&
$initial_format
ne
'xml-hires'
) {
croak(
"initial_format parameter can only be "
.
"xml-piechart or xml-hires!"
);
}
push
@additional_params
,
"format=$initial_format"
;
$self
->initial_format(
$initial_format
);
push
@additional_params
,
'session_id='
.
$self
->session_id;
$default_request_url_template
.=
'?'
.
join
(
';'
,
@additional_params
);
$request_url_template
=
$default_request_url_template
;
}
$self
->request_url_template(
$request_url_template
);
};
$self
->error($@)
if
$@;
return
$self
;
}
sub
display {
my
(
$self
) =
@_
;
$self
->_process_params;
my
$cgi
=
$self
->cgi;
my
$format
=
$cgi
->param(
"format"
);
if
(!
$format
) {
$self
->_display_js_page;
}
elsif
(
$format
eq
"js"
) {
$self
->_display_js_page;
}
elsif
(
$format
eq
"xml-hires"
) {
$self
->_serve_xml_data;
}
elsif
(
$format
eq
"xml-piechart"
) {
$self
->_serve_xml_data;
}
else
{
$self
->error(
"Invalid format parameter ($format)!"
);
}
return
1;
}
sub
error {
my
(
$self
,
$message
) =
@_
;
croak(
$message
);
}
sub
process_data_post_retrieve {
my
(
$self
,
$data_ref
) =
@_
;
return
1;
}
sub
process_markers_pre_filter {
my
(
$self
,
$markers_ref
) =
@_
;
return
1;
}
sub
process_markers_pre_cluster {
my
(
$self
,
$markers_ref
) =
@_
;
return
1;
}
sub
process_markers_post_cluster {
my
(
$self
,
$markers_ref
) =
@_
;
return
1;
}
sub
piechart_icon_size {
my
(
$self
,
$data_count
,
$max_data_count
,
$min_chart_size
,
$max_chart_size
) =
@_
;
my
$piechart_icon_size
=
$self
->_round(
$min_chart_size
+ (
(
$data_count
/
$max_data_count
) *
(
$max_chart_size
-
$min_chart_size
)
)
);
return
$piechart_icon_size
;
}
sub
generate_piechart_legend_html {
my
(
$self
,
$info_ref
) =
@_
;
my
@sorted_info
=
sort
{
if
( (
$a
->[1] eq
'Clustered'
||
$a
->[1] eq
'Other'
)
&& (
$b
->[1] eq
'Clustered'
||
$b
->[1] eq
'Other'
)) {
$a
cmp
$b
;
}
elsif
((
$a
->[1] eq
'Clustered'
||
$a
->[1] eq
'Other'
)
&& (
$b
->[1] ne
'Clustered'
&&
$b
->[1] ne
'Other'
)) {
1;
}
elsif
((
$a
->[1] ne
'Clustered'
&&
$a
->[1] ne
'Other'
)
&& (
$b
->[1] eq
'Clustered'
||
$b
->[1] eq
'Other'
)) {
-1;
}
else
{
$b
->[2] <=>
$a
->[2] }
}
@$info_ref
;
$info_ref
= \
@sorted_info
;
my
$html
;
$html
.=
qq[<table>\n]
;
$html
.=
qq[<tr>\n]
;
$html
.=
qq[<td colspan="2">
This section displays data points in current view and
is updated as the map is moved and/or filtering is applied.<br/>
</td>\n]
;
$html
.=
qq[</tr>\n]
;
foreach
my
$info
(@{
$info_ref
}) {
my
(
$icon_url
,
$label
,
$count
) =
@$info
;
$html
.=
qq[<tr>\n]
;
$html
.=
qq[<td align="left">
<img src="$icon_url"/> $label ($count points)
</td>\n]
;
$html
.=
qq[</tr>\n]
;
}
$html
.=
qq[</table>\n]
;
return
$html
;
}
sub
generate_hires_legend_html {
my
(
$self
,
$rows_ref
,
$type
) =
@_
;
my
$legend_field1
=
$self
->legend_field1;
my
$legend_field2
=
$self
->legend_field2;
my
$temp_dir_eq
=
$self
->temp_dir_eq;
my
$session_id
=
$self
->session_id;
my
$multiples_icon_url
=
"$temp_dir_eq/Multiple-icon-$session_id-0-0-0.png"
;
my
$legend_info
;
my
@legend_markers
;
if
(
$type
eq
'hires'
) {
$legend_info
=
qq[(The coordinates with overlapping data points
are displayed as <img src="$multiples_icon_url">.)]
;
my
%legend_markers
;
foreach
my
$key
(
keys
%$rows_ref
) {
foreach
my
$row_ref
(@{
$rows_ref
->{
$key
}->{rows}}) {
my
$icon_url
=
$row_ref
->{icon_url};
my
$legend_field1_value
=
$row_ref
->{
$legend_field1
};
my
$legend_field2_value
=
$row_ref
->{
$legend_field2
};
$legend_markers
{
$icon_url
}{count}++;
$legend_markers
{
$icon_url
}{text} =
join
(
'; '
,
map
{ s/^(.{5}).+/$1 .../;
$_
; }
$legend_field1_value
,
$legend_field2_value
);
}
}
foreach
my
$icon_url
(
sort
{
$legend_markers
{
$b
}{count} <=>
$legend_markers
{
$a
}{count} }
keys
%legend_markers
) {
my
$text
=
$legend_markers
{
$icon_url
}{text};
push
@legend_markers
,
{
icon_url
=>
$icon_url
,
icon_size
=> 11,
text
=>
$text
,
};
}
}
else
{
$legend_info
=
qq[]
;
@legend_markers
=
@$rows_ref
;
}
my
$html
;
$html
.=
qq[<table>\n]
;
$html
.=
qq[<tr>\n]
;
$html
.=
qq[<td colspan="2">
$legend_info<br/>
</td>\n]
;
$html
.=
qq[</tr>\n]
;
foreach
my
$legend_marker
(
@legend_markers
) {
my
$icon_url
=
$legend_marker
->{icon_url};
my
$icon_size
=
$legend_marker
->{icon_size};
my
$text
=
$legend_marker
->{text};
$html
.=
qq[<tr>\n]
;
$html
.=
qq[<td align="left">
<img height="$icon_size" src="$icon_url"/> $text
</td>\n]
;
$html
.=
qq[</tr>\n]
;
}
$html
.=
qq[</table>\n]
;
return
$html
;
}
sub
generate_piechart_details_html {
my
(
$self
,
$key_ref
) =
@_
;
my
$data_ref
=
$key_ref
->{cluster_set};
my
$session
=
$self
->session;
my
$color_table_ref
=
$session
->param(
'color_table'
);
my
$temp_dir_eq
=
$self
->temp_dir_eq;
my
$total_count
=
$key_ref
->{cluster_data_count};
my
$html
;
$html
.=
qq[<table>\n]
;
$html
.=
qq[<tr>\n]
;
$html
.=
qq[<th align="left" width="50%">
Total Count</th><th align="left">: $total_count
</th>\n]
;
$html
.=
qq[</tr>\n]
;
$html
.=
qq[</table>\n]
;
$html
.=
qq[<table>\n]
;
foreach
my
$label
(
sort
{
if
(
$b
eq
'Clustered'
||
$b
eq
'Other'
) { -1 }
else
{
$data_ref
->{
$b
} <=>
$data_ref
->{
$a
} }
}
keys
%{
$data_ref
}
) {
my
$count
=
$data_ref
->{
$label
};
my
$color
=
$color_table_ref
->{
$label
};
my
$icon_url
=
"$temp_dir_eq/Legend-icon-$color.png"
;
my
$rounded_percent
=
$self
->_round(
$count
/
$total_count
* 100);
$html
.=
qq[<tr>\n]
;
$html
.=
qq[<td align="left">
<img src="$icon_url"/> $label ($count points)
</td>\n]
;
$html
.=
qq[<td align="right"> $rounded_percent %</td>\n]
;
$html
.=
qq[</tr>\n]
;
}
$html
.=
qq[</table>\n]
;
return
$html
;
}
sub
generate_hires_details_html {
my
(
$self
,
$key_ref
) =
@_
;
my
$data_ref
=
$key_ref
->{rows};
my
$legend_field1
=
$self
->legend_field1;
my
$legend_field2
=
$self
->legend_field2;
my
$session
=
$self
->session;
my
$temp_dir_eq
=
$self
->temp_dir_eq;
my
%icon_urls
;
my
$total_count
= 0;
foreach
my
$row_ref
(
@$data_ref
) {
my
$icon_url
=
$row_ref
->{icon_url};
my
$legend_field1_value
=
$row_ref
->{
$legend_field1
};
my
$legend_field2_value
=
$row_ref
->{
$legend_field2
};
$icon_urls
{
$icon_url
}{count}++;
$icon_urls
{
$icon_url
}{text} =
join
(
'; '
,
map
{ s/^(.{5}).+/$1 .../;
$_
; }
$legend_field1_value
,
$legend_field2_value
);
$total_count
++;
}
my
$html
;
$html
.=
qq[<table>\n]
;
$html
.=
qq[<tr>\n]
;
$html
.=
qq[<th align="left" width="50%">Total Count</th>
<th align="left">: $total_count</th>\n]
;
$html
.=
qq[</tr>\n]
;
$html
.=
qq[</table>\n]
;
$html
.=
qq[<table>\n]
;
foreach
my
$icon_url
(
sort
{
$icon_urls
{
$b
}{count} <=>
$icon_urls
{
$a
}{count} }
keys
%icon_urls
) {
my
$count
=
$icon_urls
{
$icon_url
}{count};
my
$text
=
$icon_urls
{
$icon_url
}{text};
my
$rounded_percent
=
$self
->_round(
$count
/
$total_count
* 100);
$html
.=
qq[<tr>\n]
;
$html
.=
qq[<td align="left">
<img src="$icon_url"/> $text ($count points)
</td>\n]
;
$html
.=
qq[<td align="right"> $rounded_percent%</td>\n]
;
$html
.=
qq[</tr>\n]
;
}
$html
.=
qq[</table>\n]
;
return
$html
;
}
sub
base_output_headers {
my
(
$self
,
$value
) =
@_
;
$self
->{base_output_headers} =
$value
if
@_
> 1;
return
$self
->{base_output_headers};
}
sub
base_sql_fields {
my
(
$self
,
$value
) =
@_
;
$self
->{base_sql_fields} =
$value
if
@_
> 1;
return
$self
->{base_sql_fields};
}
sub
base_sql_table {
my
(
$self
,
$value
) =
@_
;
$self
->{base_sql_table} =
$value
if
@_
> 1;
return
$self
->{base_sql_table};
}
sub
center_latitude {
my
(
$self
,
$value
) =
@_
;
$self
->{center_latitude} =
$value
if
@_
> 1;
return
$self
->{center_latitude};
}
sub
center_longitude {
my
(
$self
,
$value
) =
@_
;
$self
->{center_longitude} =
$value
if
@_
> 1;
return
$self
->{center_longitude};
}
sub
center_zoom {
my
(
$self
,
$value
) =
@_
;
$self
->{center_zoom} =
$value
if
@_
> 1;
return
$self
->{center_zoom};
}
sub
cgi {
my
(
$self
,
$value
) =
@_
;
$self
->{cgi} =
$value
if
@_
> 1;
return
$self
->{cgi};
}
sub
cgi_params {
my
(
$self
,
$value
) =
@_
;
$self
->{cgi_params} =
$value
if
@_
> 1;
return
$self
->{cgi_params};
}
sub
cluster_field {
my
(
$self
,
$value
) =
@_
;
$self
->{cluster_field} =
$value
if
@_
> 1;
return
$self
->{cluster_field};
}
sub
db_access_params {
my
(
$self
,
$value
) =
@_
;
$self
->{db_access_params} =
$value
if
@_
> 1;
return
$self
->{db_access_params};
}
sub
db_display {
my
(
$self
,
$value
) =
@_
;
$self
->{db_display} =
$value
if
@_
> 1;
return
$self
->{db_display};
}
sub
db_selected {
my
(
$self
,
$value
) =
@_
;
$self
->{db_selected} =
$value
if
@_
> 1;
return
$self
->{db_selected};
}
sub
dbh {
my
(
$self
,
$value
) =
@_
;
$self
->{dbh} =
$value
if
@_
> 1;
return
$self
->{dbh};
}
sub
fields {
my
(
$self
,
$value
) =
@_
;
$self
->{fields} =
$value
if
@_
> 1;
return
$self
->{fields};
}
sub
footer {
my
(
$self
,
$value
) =
@_
;
$self
->{footer} =
$value
if
@_
> 1;
return
$self
->{footer};
}
sub
gmap_key {
my
(
$self
,
$value
) =
@_
;
$self
->{gmap_key} =
$value
if
@_
> 1;
return
$self
->{gmap_key};
}
sub
gmap_main_css_file {
my
(
$self
,
$value
) =
@_
;
$self
->{gmap_main_css_file} =
$value
if
@_
> 1;
return
$self
->{gmap_main_css_file};
}
sub
gmap_main_html_file {
my
(
$self
,
$value
) =
@_
;
$self
->{gmap_main_html_file} =
$value
if
@_
> 1;
return
$self
->{gmap_main_html_file};
}
sub
gmap_main_js_file {
my
(
$self
,
$value
) =
@_
;
$self
->{gmap_main_js_file} =
$value
if
@_
> 1;
return
$self
->{gmap_main_js_file};
}
sub
hires_shape_keys {
my
(
$self
,
$value
) =
@_
;
$self
->{hires_shape_keys} =
$value
if
@_
> 1;
return
$self
->{hires_shape_keys};
}
sub
hires_shape_values {
my
(
$self
,
$value
) =
@_
;
$self
->{hires_shape_values} =
$value
if
@_
> 1;
return
$self
->{hires_shape_values};
}
sub
hires_color_keys {
my
(
$self
,
$value
) =
@_
;
$self
->{hires_color_keys} =
$value
if
@_
> 1;
return
$self
->{hires_color_keys};
}
sub
hires_color_values {
my
(
$self
,
$value
) =
@_
;
$self
->{hires_color_values} =
$value
if
@_
> 1;
return
$self
->{hires_color_values};
}
sub
header {
my
(
$self
,
$value
) =
@_
;
$self
->{header} =
$value
if
@_
> 1;
return
$self
->{header};
}
sub
image_height_pix {
my
(
$self
,
$value
) =
@_
;
$self
->{image_height_pix} =
$value
if
@_
> 1;
return
$self
->{image_height_pix};
}
sub
image_width_pix {
my
(
$self
,
$value
) =
@_
;
$self
->{image_width_pix} =
$value
if
@_
> 1;
return
$self
->{image_width_pix};
}
sub
initial_format {
my
(
$self
,
$value
) =
@_
;
$self
->{initial_format} =
$value
if
@_
> 1;
return
$self
->{initial_format};
}
sub
install_dir {
my
(
$self
,
$value
) =
@_
;
$self
->{install_dir} =
$value
if
@_
> 1;
return
$self
->{install_dir};
}
sub
install_dir_eq {
my
(
$self
,
$value
) =
@_
;
$self
->{install_dir_eq} =
$value
if
@_
> 1;
return
$self
->{install_dir_eq};
}
sub
legend_field1 {
my
(
$self
,
$value
) =
@_
;
$self
->{legend_field1} =
$value
if
@_
> 1;
return
$self
->{legend_field1};
}
sub
legend_field2 {
my
(
$self
,
$value
) =
@_
;
$self
->{legend_field2} =
$value
if
@_
> 1;
return
$self
->{legend_field2};
}
sub
max_hires_display {
my
(
$self
,
$value
) =
@_
;
$self
->{max_hires_display} =
$value
if
@_
> 1;
return
$self
->{max_hires_display};
}
sub
messages {
my
(
$self
,
$value
) =
@_
;
$self
->{messages} =
$value
if
@_
> 1;
return
$self
->{messages};
}
sub
page_title {
my
(
$self
,
$value
) =
@_
;
$self
->{page_title} =
$value
if
@_
> 1;
return
$self
->{page_title};
}
sub
param_fields {
my
(
$self
,
$value
) =
@_
;
$self
->{param_fields} =
$value
if
@_
> 1;
return
$self
->{param_fields};
}
sub
prototype_js_file {
my
(
$self
,
$value
) =
@_
;
$self
->{prototype_js_file} =
$value
if
@_
> 1;
return
$self
->{prototype_js_file};
}
sub
request_url_template {
my
(
$self
,
$value
) =
@_
;
$self
->{request_url_template} =
$value
if
@_
> 1;
return
$self
->{request_url_template};
}
sub
session {
my
(
$self
,
$value
) =
@_
;
$self
->{session} =
$value
if
@_
> 1;
return
$self
->{session};
}
sub
session_id {
my
(
$self
,
$value
) =
@_
;
$self
->{session_id} =
$value
if
@_
> 1;
return
$self
->{session_id};
}
sub
temp_dir {
my
(
$self
,
$value
) =
@_
;
$self
->{temp_dir} =
$value
if
@_
> 1;
return
$self
->{temp_dir};
}
sub
temp_dir_eq {
my
(
$self
,
$value
) =
@_
;
$self
->{temp_dir_eq} =
$value
if
@_
> 1;
return
$self
->{temp_dir_eq};
}
sub
tile_height_pix {
my
(
$self
,
$value
) =
@_
;
$self
->{tile_height_pix} =
$value
if
@_
> 1;
return
$self
->{tile_height_pix};
}
sub
tile_width_pix {
my
(
$self
,
$value
) =
@_
;
$self
->{tile_width_pix} =
$value
if
@_
> 1;
return
$self
->{tile_width_pix};
}
sub
_display_js_page {
my
(
$self
) =
@_
;
my
$initial_format
=
$self
->initial_format;
my
@fields
= @{
$self
->fields};
my
@param_fields_with_values
;
foreach
my
$field
(
@fields
) {
if
(
$field
->{param}
&&
exists
$field
->{
values
}
&& @{
$field
->{
values
}} > 0) {
push
@param_fields_with_values
,
$field
;
}
}
my
$cgi_header
= CGI::header();
my
$center_latitude
=
defined
$self
->center_latitude
?
$self
->center_latitude
: 40.863233;
my
$center_longitude
=
defined
$self
->center_longitude
?
$self
->center_longitude
: -73.466566;
my
$center_zoom
=
defined
$self
->center_zoom
?
$self
->center_zoom
: 4;
my
$param_fields
=
join
(
", "
,
map
{
qq["]
.
$_
->{name} .
qq["]
}
@param_fields_with_values
);
my
$gmap_main_css_file_eq
=
$self
->install_dir_eq .
'/'
.
$self
->gmap_main_css_file;
my
$gmap_main_js_file_eq
=
$self
->install_dir_eq .
'/'
.
$self
->gmap_main_js_file;
my
$prototype_js_file_eq
=
$self
->install_dir_eq .
'/'
.
$self
->prototype_js_file;
my
%vars
= (
cgi_header
=>
$cgi_header
,
header
=>
$self
->_content(
$self
->header),
footer
=>
$self
->_content(
$self
->footer),
page_title
=>
$self
->page_title,
legend
=>
undef
,
param_fields_with_values
=> \
@param_fields_with_values
,
messages
=>
$self
->messages,
gmap_key
=>
$self
->gmap_key,
gmap_main_css_file_eq
=>
$gmap_main_css_file_eq
,
gmap_main_js_file_eq
=>
$gmap_main_js_file_eq
,
prototype_js_file_eq
=>
$prototype_js_file_eq
,
container_height_pix
=>
$self
->image_height_pix + 20,
container_width_pix
=>
$self
->image_width_pix + 450,
center_width_pix
=>
$self
->image_width_pix + 0,
display_cluster_slices
=>
$initial_format
eq
'xml-piechart'
? 1 : 0,
center_latitude
=>
$center_latitude
,
center_longitude
=>
$center_longitude
,
center_zoom
=>
$center_zoom
,
image_height_pix
=>
$self
->image_height_pix,
tile_height_pix
=>
$self
->tile_height_pix,
image_width_pix
=>
$self
->image_width_pix,
tile_width_pix
=>
$self
->tile_width_pix,
param_fields
=>
$param_fields
,
url_template
=>
$self
->request_url_template,
cluster_field
=>
$self
->cluster_field,
draw_grid
=>
$self
->initial_format eq
'xml-piechart'
? 1 : 0,
);
my
$template
= Template->new(
INCLUDE_PATH
=>
$self
->install_dir);
$template
->process(
$self
->gmap_main_html_file, \
%vars
)
or
$self
->error(
"Template process failed: "
.
$template
->error);
return
1;
}
sub
_serve_xml_data {
my
(
$self
) =
@_
;
$self
->_clean_temp_dir;
my
$dbh
=
$self
->dbh;
my
$cgi
=
$self
->cgi;
my
$base_sql_table
=
$self
->base_sql_table;
my
@base_sql_fields
= @{
$self
->base_sql_fields};
my
@base_output_headers
= @{
$self
->base_output_headers};
my
@fields
= @{
$self
->fields};
my
$format
=
$cgi
->param(
"format"
);
if
(
$format
ne
'xml-piechart'
&&
$format
ne
'xml-hires'
) {
$self
->error(
"Invalid format param($format)!"
);
}
my
$cluster_field
=
$self
->cluster_field;
my
@where_clauses
;
foreach
my
$field
(
@fields
) {
my
$name
=
$field
->{name};
my
$display
=
$field
->{display};
my
$values
=
$field
->{
values
};
next
if
(
$name
eq
$cluster_field
and
$format
eq
'xml-piechart'
);
my
$cgi_value
=
$cgi
->param(
$name
);
if
(
$cgi_value
and
$cgi_value
ne
'all'
) {
push
@where_clauses
,
qq[$name = ]
.
$dbh
->quote(
$cgi_value
);
}
}
push
@where_clauses
,
qq[latitude >= ]
.
$dbh
->quote(
$cgi
->param(
"latitude_south"
));
push
@where_clauses
,
qq[latitude <= ]
.
$dbh
->quote(
$cgi
->param(
"latitude_north"
));
if
(
$cgi
->param(
"longitude_west"
) <=
$cgi
->param(
"longitude_east"
)) {
push
@where_clauses
,
qq[longitude >= ]
.
$dbh
->quote(
$cgi
->param(
"longitude_west"
));
push
@where_clauses
,
qq[longitude <= ]
.
$dbh
->quote(
$cgi
->param(
"longitude_east"
));
}
else
{
push
@where_clauses
,
qq[((longitude >= ]
.
$dbh
->quote(
$cgi
->param(
"longitude_west"
))
.
qq[AND longitude <= 180)]
.
qq[ OR ]
.
qq[(longitude <= ]
.
$dbh
->quote(
$cgi
->param(
"longitude_east"
))
.
qq[AND longitude >= -180))]
;
}
my
$statement
=
"SELECT "
.
join
(
", "
,
@base_sql_fields
);
$statement
.=
" FROM "
.
$base_sql_table
;
$statement
.=
" WHERE "
.
join
(
" AND "
,
@where_clauses
)
if
@where_clauses
;
my
$data_ref
;
my
$sth
=
$dbh
->prepare(
$statement
);
$sth
->execute;
while
(
my
@row
=
$sth
->fetchrow_array) {
push
@{
$data_ref
}, \
@row
; }
$sth
->finish;
$self
->process_data_post_retrieve(
$data_ref
);
my
$clean_data_ref
;
foreach
(@{
$data_ref
}) {
push
@{
$clean_data_ref
},
$_
if
$_
;
}
$data_ref
=
$clean_data_ref
;
my
$xml_ref
;
if
(
$format
eq
"xml-hires"
) {
$xml_ref
=
$self
->_generate_hires_xml_data(
$data_ref
);
}
elsif
(
$format
eq
"xml-piechart"
) {
$xml_ref
=
$self
->_generate_piechart_xml_data(
$data_ref
);
}
else
{
$self
->error(
"Invalid XML data format ($format)!"
);
}
my
$formatted_data
= XMLout(
$xml_ref
);
print
CGI::header(
-type
=>
'text/plain'
);
print
$formatted_data
;
return
1;
}
sub
_generate_hires_xml_data {
my
(
$self
,
$data_ref
) =
@_
;
my
@base_sql_fields
= @{
$self
->base_sql_fields};
my
$legend_field1
=
$self
->legend_field1;
my
$legend_field2
=
$self
->legend_field2;
my
$session
=
$self
->session;
my
$temp_dir
=
$self
->temp_dir;
my
$temp_dir_eq
=
$self
->temp_dir_eq;
my
$session_id
=
$self
->session_id;
my
$max_hires_display
=
$self
->max_hires_display;
my
$markers_ref
= {};
my
$max_data_count
= 0;
foreach
my
$data
(@{
$data_ref
}) {
my
$row_ref
;
foreach
my
$i
(0 ..
$#base_sql_fields
) {
$row_ref
->{
$base_sql_fields
[
$i
]} =
$data
->[
$i
];
}
my
$latitude
=
$row_ref
->{latitude};
my
$longitude
=
$row_ref
->{longitude};
my
$key
=
join
(
':'
,
$latitude
,
$longitude
);
push
@{
$markers_ref
->{
$key
}->{rows}},
$row_ref
;
$markers_ref
->{
$key
}->{cluster_data_count}++;
if
(
$markers_ref
->{
$key
}->{cluster_data_count}
and
$markers_ref
->{
$key
}->{cluster_data_count} >
$max_data_count
)
{
$max_data_count
=
$markers_ref
->{
$key
}->{cluster_data_count};
}
}
my
$xml_ref
= {};
if
(
scalar
(
keys
%$markers_ref
) >
$max_hires_display
) {
(
$markers_ref
,
$max_data_count
) =
$self
->_cluster_data(
$data_ref
);
$self
->_add_hires_icon_urls(
$markers_ref
);
my
$lowres_legend_marker_count
= 5;
my
$density_icon_prefix
=
"Density-icon-$session_id"
;
my
$icon
= GD::Icons->new(
shape_keys
=> [
":default"
],
shape_values
=> [
"_large_square"
],
color_keys
=> [
":default"
],
color_values
=> [
"#0009ff"
],
sval_keys
=> [0 ..
$lowres_legend_marker_count
- 1],
icon_dir
=>
$temp_dir
,
icon_prefix
=>
$density_icon_prefix
,
);
$icon
->generate_icons;
my
@lowres_legend_markers
;
foreach
my
$i
(0 ..
$lowres_legend_marker_count
- 1) {
my
$icon_url
=
"$temp_dir_eq/$density_icon_prefix-0-0-$i.png"
;
my
$text
=
int
(
$i
*
$max_data_count
/
$lowres_legend_marker_count
) + 1
.
' to '
.
int
((
$i
+ 1) *
$max_data_count
/
$lowres_legend_marker_count
)
.
' points'
;
my
$icon_size
= 22;
push
@lowres_legend_markers
,
{
icon_url
=>
$icon_url
,
icon_size
=>
$icon_size
,
text
=>
$text
,
};
}
foreach
my
$key
(
keys
%{
$markers_ref
}) {
my
(
$latitude
,
$longitude
) =
split
(
':'
,
$key
);
my
$data_ref
=
$markers_ref
->{
$key
}->{rows};
my
$data_count
=
scalar
(
@$data_ref
);
my
$density_icon_index
=
int
((
$data_count
/
$max_data_count
) *
(
$lowres_legend_marker_count
- 1));
my
$icon_url
=
"$temp_dir_eq/$density_icon_prefix-0-0-$density_icon_index.png"
;
my
$icon_size
= 22;
my
$details_on_click
=
$self
->generate_hires_details_html(
$markers_ref
->{
$key
});
my
$row_ref
= {
latitude
=>
$latitude
,
longitude
=>
$longitude
,
icon_url
=>
$icon_url
,
icon_size
=>
$icon_size
,
details_on_click
=>
$details_on_click
,
messages_on_click
=>
''
,
legend_on_click
=>
''
,
};
push
(@{
$xml_ref
->{marker}},
$row_ref
);
}
my
$legend
=
$self
->generate_hires_legend_html(
\
@lowres_legend_markers
,
'lowres'
);
my
$meta_data_ref
= {
messages_by_default
=>
$self
->messages,
details_by_default
=>
'[Click an icon for details ...]'
,
legend_by_default
=>
$legend
,
};
push
(@{
$xml_ref
->{meta_data}},
$meta_data_ref
);
}
else
{
$self
->_add_hires_icon_urls(
$markers_ref
);
foreach
my
$key
(
keys
%{
$markers_ref
}) {
my
(
$latitude
,
$longitude
) =
split
(
':'
,
$key
);
my
$data_ref
=
$markers_ref
->{
$key
}->{rows};
my
$data_count
=
scalar
(
@$data_ref
);
my
$icon_size
=
$data_count
> 1 ? 14 : 11;
my
$multiples_icon_url
;
if
(
$data_count
> 1) {
my
$multiples_icon_prefix
=
"Multiple-icon-$data_count-$session_id"
;
my
$icon
= GD::Icons->new(
alpha
=> 30,
shape_keys
=> [
"Multiple:$data_count"
],
shape_values
=> [
"_number-flag"
],
color_keys
=> [
":default"
],
color_values
=> [
"#c1caff"
],
sval_keys
=> [
":default"
],
sval_values
=> [
":default"
],
icon_dir
=>
$temp_dir
,
icon_prefix
=>
$multiples_icon_prefix
,
);
$icon
->generate_icons;
$multiples_icon_url
=
"$temp_dir_eq/"
.
$icon
->icon(
"Multiple:$data_count"
,
':default'
,
':default'
);
}
my
$icon_url
=
$data_count
> 1
?
$multiples_icon_url
:
$data_ref
->[0]->{icon_url};
my
$details_on_click
=
$self
->generate_hires_details_html(
$markers_ref
->{
$key
});
my
$row_ref
= {
latitude
=>
$latitude
,
longitude
=>
$longitude
,
icon_url
=>
$icon_url
,
icon_size
=>
$icon_size
,
details_on_click
=>
$details_on_click
,
messages_on_click
=>
''
,
legend_on_click
=>
''
,
};
push
(@{
$xml_ref
->{marker}},
$row_ref
);
}
my
$legend
=
$self
->generate_hires_legend_html(
$markers_ref
,
'hires'
);
my
$meta_data_ref
= {
messages_by_default
=>
$self
->messages,
details_by_default
=>
'[Click icons for details ...]'
,
legend_by_default
=>
$legend
};
push
(@{
$xml_ref
->{meta_data}},
$meta_data_ref
);
}
return
$xml_ref
;
}
sub
_add_hires_icon_urls {
my
(
$self
,
$markers_ref
) =
@_
;
my
$legend_field1
=
$self
->legend_field1;
my
$legend_field2
=
$self
->legend_field2;
my
$session
=
$self
->session;
my
$hires_shape_keys
=
$self
->hires_shape_keys;
my
$hires_shape_values
=
$self
->hires_shape_values;
my
$hires_color_keys
=
$self
->hires_color_keys;
my
$hires_color_values
=
$self
->hires_color_values;
my
$temp_dir
=
$self
->temp_dir;
my
$temp_dir_eq
=
$self
->temp_dir_eq;
my
$session_id
=
$self
->session_id;
my
%legend_field1_values
;
my
%legend_field2_values
;
foreach
my
$key
(
keys
%{
$markers_ref
}) {
my
$data_ref
=
$markers_ref
->{
$key
}->{rows};
foreach
my
$row_ref
(
@$data_ref
) {
$legend_field1_values
{
$row_ref
->{
$legend_field1
}} = 1
if
exists
$row_ref
->{
$legend_field1
};
$legend_field2_values
{
$row_ref
->{
$legend_field2
}} = 1
if
exists
$row_ref
->{
$legend_field2
};
}
}
my
@legend_field1_values
=
sort
keys
%legend_field1_values
;
my
@legend_field2_values
=
sort
keys
%legend_field2_values
;
my
$small_icon_prefix
=
"Small-icon-$session_id"
;
my
$icon
= GD::Icons->new(
color_keys
=>
$hires_color_keys
?
$hires_color_keys
: \
@legend_field2_values
,
color_values
=>
$hires_color_values
,
shape_keys
=>
$hires_shape_keys
?
$hires_shape_keys
: \
@legend_field1_values
,
shape_values
=>
$hires_shape_values
,
sval_keys
=> [
":default"
],
icon_dir
=>
$temp_dir
,
icon_prefix
=>
$small_icon_prefix
,
);
$icon
->generate_icons;
foreach
my
$key
(
keys
%{
$markers_ref
}) {
my
$data_ref
=
$markers_ref
->{
$key
}->{rows};
foreach
my
$row_ref
(
@$data_ref
) {
$row_ref
->{icon_url} =
"$temp_dir_eq/"
.
$icon
->icon(
$row_ref
->{
$legend_field1
},
$row_ref
->{
$legend_field2
},
':default'
);
}
}
return
1;
}
sub
_generate_piechart_xml_data {
my
(
$self
,
$data_ref
) =
@_
;
my
$cgi
=
$self
->cgi;
my
$cluster_field
=
$self
->cluster_field;
my
$session
=
$self
->session;
my
$cluster_filter_value
;
if
(
$cgi
->param(
$cluster_field
) &&
$cgi
->param(
$cluster_field
) ne
'all'
) {
$cluster_filter_value
=
$cgi
->param(
$cluster_field
);
}
my
(
$markers_ref
,
$max_data_count
) =
$self
->_cluster_data(
$data_ref
);
$self
->process_markers_pre_filter(
$markers_ref
);
if
(
$cluster_filter_value
) {
foreach
my
$key
(
keys
%{
$markers_ref
}) {
my
$data
=
$markers_ref
->{
$key
}->{cluster_set};
my
$cluster_data_count
=
$markers_ref
->{
$key
}->{cluster_data_count};
my
$blank_value
= 0;
foreach
my
$cluster_value
(
keys
%$data
) {
if
(
$cluster_value
eq
$cluster_filter_value
) {
next
;
}
else
{
$blank_value
+=
$data
->{
$cluster_value
};
delete
$data
->{
$cluster_value
};
}
}
$data
->{Other} =
$blank_value
;
}
}
$self
->process_markers_pre_cluster(
$markers_ref
);
my
$cluster_slices
=
$cgi
->param(
'cluster_slices'
);
my
$cluster_slices_by
=
$cgi
->param(
'cluster_slices_by'
);
my
$cluster_slices_value
=
$cgi
->param(
'cluster_slices_value'
);
if
(
$cluster_slices
&&
$cluster_slices
ne
'off'
&&
$cluster_slices
ne
'false'
&&
$cluster_slices_value
> 0) {
foreach
my
$key
(
keys
%{
$markers_ref
}) {
my
$data
=
$markers_ref
->{
$key
}->{cluster_set};
my
$other_value
= 0;
foreach
my
$cluster_value
(
keys
%$data
) {
my
$cluster_count
=
$data
->{
$cluster_value
};
my
$cluster_percent
=
$data
->{
$cluster_value
} /
$markers_ref
->{
$key
}->{cluster_data_count} * 100;
if
(
$cluster_slices_by
eq
'count'
) {
if
(
$cluster_count
<
$cluster_slices_value
) {
$other_value
+=
$cluster_count
;
delete
$data
->{
$cluster_value
};
}
}
elsif
(
$cluster_slices_by
eq
'percent'
) {
if
(
$cluster_percent
<
$cluster_slices_value
) {
$other_value
+=
$cluster_count
;
delete
$data
->{
$cluster_value
};
}
}
else
{
$self
->error(
"Invalid cluster_slices_type value ($cluster_slices_by)!"
);
}
}
$data
->{Clustered} =
$other_value
;
}
}
$self
->process_markers_post_cluster(
$markers_ref
);
my
%all_cluster_values
;
foreach
my
$key
(
keys
%{
$markers_ref
}) {
my
$data
=
$markers_ref
->{
$key
}->{cluster_set};
foreach
my
$cluster_value
(
keys
%$data
) {
$all_cluster_values
{
$cluster_value
} +=
$data
->{
$cluster_value
};
}
}
my
$color_table_ref
=
$session
->param(
'color_table'
) || {};
my
$last_color_index
=
$session
->param(
'last_color_index'
) || 0;
my
@colors
= @{
$self
->_colors};
my
@all_cluster_values
=
sort
{
$all_cluster_values
{
$b
} <=>
$all_cluster_values
{
$a
} }
keys
%all_cluster_values
;
my
$color_index
;
foreach
my
$i
(0 ..
$#all_cluster_values
) {
my
$cluster_value
=
$all_cluster_values
[
$i
];
next
if
$color_table_ref
->{
$cluster_value
};
$color_index
= (
$i
+
$last_color_index
+ 1) %
@colors
;
$color_table_ref
->{
$cluster_value
} =
$colors
[
$color_index
];
}
$color_table_ref
->{Other} =
'white'
;
$color_table_ref
->{Clustered} =
'purple'
;
$session
->param(
'color_table'
,
$color_table_ref
);
$session
->param(
'last_color_index'
,
$color_index
);
my
$xml_ref
= {};
foreach
my
$key
(
keys
%{
$markers_ref
}) {
my
(
$latitude
,
$longitude
) =
split
(
':'
,
$key
);
my
$data_ref
=
$markers_ref
->{
$key
}->{cluster_set};
my
@piechart_labels
;
my
@piechart_values
;
my
@piechart_colors
;
foreach
my
$label
(
sort
{
$data_ref
->{
$b
} <=>
$data_ref
->{
$a
} }
keys
%{
$data_ref
}
) {
push
@piechart_labels
,
$label
;
push
@piechart_values
,
$data_ref
->{
$label
};
push
@piechart_colors
,
$color_table_ref
->{
$label
};
}
my
(
$icon_url
,
$icon_size
) =
$self
->_make_piechart_icon(
[\
@piechart_labels
, \
@piechart_values
],
\
@piechart_colors
,
$max_data_count
);
my
$details_on_click
=
$self
->generate_piechart_details_html(
$markers_ref
->{
$key
});
my
$row_ref
= {
latitude
=>
$latitude
,
longitude
=>
$longitude
,
icon_url
=>
$icon_url
,
icon_size
=>
$icon_size
,
details_on_click
=>
$details_on_click
,
messages_on_click
=>
''
,
legend_on_click
=>
''
,
};
push
(@{
$xml_ref
->{marker}},
$row_ref
);
}
my
$legend_info
=
$self
->_generate_piechart_legend_info(\
%all_cluster_values
);
my
$legend
=
$self
->generate_piechart_legend_html(
$legend_info
);
my
$meta_data_ref
= {
messages_by_default
=>
$self
->messages,
details_by_default
=>
'[Click a pie chart for details ...]'
,
legend_by_default
=>
$legend
};
push
(@{
$xml_ref
->{meta_data}},
$meta_data_ref
);
return
$xml_ref
;
}
sub
_cluster_data {
my
(
$self
,
$data_ref
) =
@_
;
my
$cgi
=
$self
->cgi;
my
@base_sql_fields
= @{
$self
->base_sql_fields};
my
$cluster_field
=
$self
->cluster_field;
my
$image_height_pix
=
$self
->image_height_pix;
my
$tile_height_pix
=
$self
->tile_height_pix;
my
$image_width_pix
=
$self
->image_width_pix;
my
$tile_width_pix
=
$self
->tile_width_pix;
my
$latitude_south
=
$cgi
->param(
"latitude_south"
);
my
$latitude_north
=
$cgi
->param(
"latitude_north"
);
my
$longitude_east
=
$cgi
->param(
"longitude_east"
);
my
$longitude_west
=
$cgi
->param(
"longitude_west"
);
my
$latitude_delta
=
$latitude_north
-
$latitude_south
;
my
$longitude_delta
=
(
$longitude_west
<
$longitude_east
)
? (
$longitude_east
-
$longitude_west
)
: ((
$longitude_east
- (-180)) + (180 -
$longitude_west
));
my
$number_of_vertical_tiles
=
$image_height_pix
/
$tile_height_pix
;
my
$number_of_horizontal_tiles
=
$image_width_pix
/
$tile_width_pix
;
my
%markers
,
my
$max_data_count
= 0;
foreach
my
$data
(@{
$data_ref
}) {
my
$row_ref
;
foreach
my
$i
(0 ..
$#base_sql_fields
) {
$row_ref
->{
$base_sql_fields
[
$i
]} =
$data
->[
$i
];
}
my
$latitude
=
$row_ref
->{latitude};
my
$latitude_from_origin
=
$latitude
-
$latitude_south
;
my
$longitude
=
$row_ref
->{longitude};
my
$longitude_from_origin
=
(
$longitude_west
<
$longitude
)
? (
$longitude
-
$longitude_west
)
: ((
$longitude
- (-180)) + (180 -
$longitude_west
));
my
$rounded_latitude
=
$number_of_vertical_tiles
*
$latitude_from_origin
/
$latitude_delta
;
my
$lowres_latitude
=
$latitude_south
+ (
int
(
$rounded_latitude
) + 0.5) *
(
$latitude_delta
/
$number_of_vertical_tiles
);
my
$rounded_longitude
=
$number_of_horizontal_tiles
*
$longitude_from_origin
/
$longitude_delta
;
my
$lowres_longitude
=
$longitude_west
+ (
int
(
$rounded_longitude
) + 0.5) *
(
$longitude_delta
/
$number_of_horizontal_tiles
);
if
(
$lowres_longitude
> 180) {
$lowres_longitude
= -180 + (
$lowres_longitude
- 180);
}
my
$key
=
join
(
':'
,
$lowres_latitude
,
$lowres_longitude
);
my
$cluster_value
=
$row_ref
->{
$cluster_field
} ||
'_default'
;
push
@{
$markers
{
$key
}{rows}},
$row_ref
;
$markers
{
$key
}{cluster_set}{
$cluster_value
}++;
$markers
{
$key
}{cluster_data_count}++;
if
(
$markers
{
$key
}{cluster_data_count}
and
$markers
{
$key
}{cluster_data_count} >
$max_data_count
) {
$max_data_count
=
$markers
{
$key
}{cluster_data_count};
}
}
return
(\
%markers
,
$max_data_count
);
}
sub
_generate_piechart_legend_info {
my
(
$self
,
$data_ref
) =
@_
;
my
$session
=
$self
->session;
my
$color_table_ref
=
$session
->param(
'color_table'
);
my
$temp_dir
=
$self
->temp_dir;
my
$temp_dir_eq
=
$self
->temp_dir_eq;
my
@legend_data
;
foreach
my
$label
(
sort
{
$data_ref
->{
$b
} <=>
$data_ref
->{
$a
} }
keys
%{
$data_ref
}
) {
my
$count
=
$data_ref
->{
$label
};
my
$color
=
$color_table_ref
->{
$label
};
my
$icon_file
=
"$temp_dir/Legend-icon-$color.png"
;
my
$icon_url
=
"$temp_dir_eq/Legend-icon-$color.png"
;
if
(!-e
$icon_file
) {
my
@icon_data
= (
[
$label
,
'empty'
],
[75, 25],
);
my
$graph
= GD::Graph::pie->new(15, 15)
or croak(
"Cannot create an GD::Graph object!"
);
$graph
->set(
'3d'
=> 0,
'labelclr'
=> 0,
'axislabelclr'
=> 0,
'legendclr'
=> 0,
'valuesclr'
=> 0,
'textclr'
=> 0,
'start_angle'
=> 180,
'accentclr'
=>
'dgray'
,
'dclrs'
=> [
$color
,
'white'
],
) or croak(
$graph
->error);
my
$icon
=
$graph
->plot(\
@icon_data
)
or croak(
$graph
->error);
open
(IMG,
">$icon_file"
)
or croak(
"Cannot write file ($icon_file): $!"
);
binmode
IMG;
print
IMG
$icon
->png;
close
IMG;
}
push
@legend_data
, [
$icon_url
,
$label
,
$count
];
}
return
\
@legend_data
;
}
sub
_make_piechart_icon {
my
(
$self
,
$data_ref
,
$color_ref
,
$max_data_count
) =
@_
;
my
$temp_dir
=
$self
->temp_dir;
my
$temp_dir_eq
=
$self
->temp_dir_eq;
my
$session_id
=
$self
->session_id;
unless
(
$data_ref
&&
ref
$data_ref
&&
ref
$data_ref
eq
'ARRAY'
&&
$data_ref
->[0]
&&
ref
$data_ref
->[0]
&&
ref
$data_ref
->[0] eq
'ARRAY'
&&
$data_ref
->[1]
&&
ref
$data_ref
->[1]
&&
ref
$data_ref
->[1] eq
'ARRAY'
&&
scalar
(@{
$data_ref
->[0]}) ==
scalar
(@{
$data_ref
->[1]})) {
$self
->error(
"Invalid data param (an array ref of two "
.
"equal-length arrays is needed)!"
);
}
my
$data_count
=
$self
->_total(@{
$data_ref
->[1]});
my
$max_chart_size
= 50;
my
$min_chart_size
= 20;
my
$piechart_icon_size
=
$self
->piechart_icon_size(
$data_count
,
$max_data_count
,
$min_chart_size
,
$max_chart_size
);
my
$graph
= GD::Graph::pie->new(
$piechart_icon_size
,
$piechart_icon_size
)
or
$self
->error(
"Cannot create an GD::Graph object!"
);
$graph
->set(
'3d'
=> 0,
'labelclr'
=> 0,
'axislabelclr'
=> 0,
'legendclr'
=> 0,
'valuesclr'
=> 0,
'textclr'
=> 0,
'start_angle'
=> 180,
'accentclr'
=>
'dgray'
,
'dclrs'
=>
$color_ref
,
) or
$self
->error(
$graph
->error);
my
$graph_as_gd
=
$graph
->plot(
$data_ref
) or
$self
->error(
$graph
->error);
my
$file_temp
= File::Temp->new(
TEMPLATE
=>
"PieChart-icon-$session_id-XXXXX"
,
DIR
=>
$temp_dir
,
SUFFIX
=>
'.png'
,
UNLINK
=> 0,
);
my
$icon_file
=
$file_temp
->filename;
open
(IMG,
">$icon_file"
)
or
$self
->error(
"Cannot write file ($icon_file): $!"
);
binmode
IMG;
print
IMG
$graph_as_gd
->png;
close
IMG;
my
(
$icon_file_name
) =
$icon_file
=~ /([^\/]+)$/;
my
$icon_url
=
"$temp_dir_eq/$icon_file_name"
;
return
(
$icon_url
,
$piechart_icon_size
);
}
sub
_process_params {
my
(
$self
) =
@_
;
my
$base_sql_fields
=
$self
->base_sql_fields;
my
$base_output_headers
=
$self
->base_output_headers;
my
$param_fields
=
$self
->param_fields;
if
(@{
$base_sql_fields
} != @{
$base_output_headers
}) {
croak(
"Count of base_sql_fields and base_output_headers do not match!"
);
}
my
@fields
;
foreach
my
$i
(0 .. @{
$base_sql_fields
} - 1) {
my
$name
=
$base_sql_fields
->[
$i
];
my
$display
=
$base_output_headers
->[
$i
];
my
$values
=
$param_fields
->{
$name
} || [];
my
$param
= (any {
$_
eq
$name
} (
keys
%$param_fields
)) ? 1 : 0;
foreach
(
@$values
) {
my
(
$param
,
$display
) =
split
(
':'
,
$_
);
if
(!
defined
$display
) {
$display
=
$param
}
$_
= {
param
=>
$param
,
display
=>
$display
};
}
push
@fields
,
{
name
=>
$name
,
display
=>
$display
,
values
=>
$values
,
param
=>
$param
,
};
}
$self
->fields(\
@fields
);
return
1;
}
sub
_url_encode {
my
(
$self
,
$string
) =
@_
;
$string
=~ s/([^A-Za-z0-9])/
sprintf
(
"%%%02X"
,
ord
($1))/seg;
return
$string
;
}
sub
_url_decode {
my
(
$self
,
$string
) =
@_
;
$string
=~ s/\%([A-Fa-f0-9]{2})/
pack
(
'C'
,
hex
($1))/seg;
return
$string
;
}
sub
_content {
my
(
$self
,
$container
) =
@_
;
return
' '
unless
$container
;
my
$content
=
$container
;
if
(
$container
=~ s/^(FILE|EXEC|GET)://) {
my
$type
= $1;
if
(
$type
eq
'GET'
) {
$content
= get(
$container
)
or croak(
"Cannor get container ($container)!"
);
}
elsif
(
$type
eq
'EXEC'
) {
open
(EXEC,
"$container|"
)
or croak(
"Cannot exec container ($container)! - $!"
);
{
local
$/;
$content
= <EXEC>; }
close
EXEC;
}
elsif
(
$type
eq
'FILE'
) {
open
(FILE,
"<$container"
)
or croak(
"Cannot open container ($container)! - $!"
);
{
local
$/;
$content
= <FILE>; }
close
FILE;
}
}
return
$content
;
}
sub
_round {
my
(
$self
,
$number
) =
@_
;
return
int
(
$number
+ 0.5);
}
sub
_total {
my
(
$self
,
@values
) =
@_
;
my
$total
;
foreach
my
$value
(
@values
) {
$total
+=
$value
;
}
return
$total
;
}
sub
_colors {
my
(
$self
) =
@_
;
my
@colors
=
qw(
lyellow
lblue
lorange
lgreen
cyan
red
gold
lred
pink
dpurple
lgray
yellow
lbrown
orange
dpink
marine
gray
dyellow
dgreen
dbrown
dred
blue
dblue
green
)
;
return
\
@colors
;
}
sub
_clean_temp_dir {
my
(
$self
) =
@_
;
my
$temp_dir
=
$self
->temp_dir;
my
@cmds
= (
"find $temp_dir -name \'Legend-icon-*\' -cmin +20 -exec rm -f {} \\;"
,
"find $temp_dir -name \'PieChart-icon-*\' -cmin +2 -exec rm -f {} \\;"
,
"find $temp_dir -name \'Density-icon-*\' -cmin +2 -exec rm -f {} \\;"
,
"find $temp_dir -name \'Small-icon-*\' -cmin +2 -exec rm -f {} \\;"
,
"find $temp_dir/sessions -name \'cgisess_*\' -cmin +20 -exec rm -f {} \\;"
,
);
foreach
my
$cmd
(
@cmds
) {
system
(
$cmd
);
}
return
1;
}
1;
Hide Show 220 lines of Pod