version 1.10, 2001/12/20 19:20:43
|
version 1.12, 2001/12/20 22:36:35
|
Line 34 use Apache::File;
|
Line 34 use Apache::File;
|
use Apache::response; |
use Apache::response; |
use Apache::lonxml; |
use Apache::lonxml; |
|
|
use Digest::MD5 qw(md5 md5_hex md5_base64); |
use Digest::MD5 qw(md5_base64); |
|
|
sub BEGIN { |
sub BEGIN { |
&Apache::lonxml::register('Apache::lonplot',('plot')); |
&Apache::lonxml::register('Apache::lonplot',('plot')); |
Line 67 sub BEGIN {
|
Line 67 sub BEGIN {
|
## |
## |
## Tests used in checking the validitity of input |
## Tests used in checking the validitity of input |
## |
## |
my $int_test = sub {$_[0]=~/^\d+$/}; |
my $int_test = sub {$_[0]=~s/\s+//g;$_[0]=~/^\d+$/}; |
my $real_test = sub {$_[0]=~/^[+-]?\d*\.?\d*$/}; |
my $real_test = sub {$_[0]=~s/\s+//g;$_[0]=~/^[+-]?\d*\.?\d*$/}; |
my $color_test = sub {$_[0]=~/^x[\da-f]{6}$/}; |
my $color_test = sub {$_[0]=~s/\s+//g;$_[0]=~/^x[\da-f]{6}$/}; |
my $onoff_test = sub {$_[0]=~/^(on|off)$/}; |
my $onoff_test = sub {$_[0]=~/^(on|off)$/}; |
my $key_pos_test = sub {$_[0]=~/^(top|bottom|right|left|outside|below)+$/}; |
my $key_pos_test = sub {$_[0]=~/^(top|bottom|right|left|outside|below)+$/}; |
my $sml_test = sub {$_[0]=~/^(small|medium|large)$/}; |
my $sml_test = sub {$_[0]=~/^(small|medium|large)$/}; |
my $linestyle_test = sub {$_[0]=~/^(lines|linespoints|dots|points|steps)$/}; |
my $linestyle_test = sub {$_[0]=~/^(lines|linespoints|dots|points|steps)$/}; |
my $words_test = sub {$_[0]=~/^(\w+ *)+$/}; |
my $words_test = sub {$_[0]=~s/\s+/ /g;$_[0]=~/^(\w+ ?)+$/}; |
## |
## |
## Default values for attributes of elements |
## Default values for attributes of elements |
## |
## |
Line 108 my %label_defaults =
|
Line 108 my %label_defaults =
|
my %axis_defaults = |
my %axis_defaults = |
( |
( |
color => {default => 'x000000', test => $color_test}, |
color => {default => 'x000000', test => $color_test}, |
xmin => {default => -10.0, test => $real_test }, |
xmin => {default => '-10.0', test => $real_test }, |
xmax => {default => 10.0, test => $real_test }, |
xmax => {default => ' 10.0', test => $real_test }, |
ymin => {default => -10.0, test => $real_test }, |
ymin => {default => '-10.0', test => $real_test }, |
ymax => {default => 10.0, test => $real_test } |
ymax => {default => ' 10.0', test => $real_test } |
); |
); |
|
|
my %curve_defaults = |
my %curve_defaults = |
( |
( |
color => {default => 'x000000', test => $color_test }, |
color => {default => 'x000000', test => $color_test }, |
name => {default => 'x000000', test => sub {$_[0]=~/^[\w ]*$/} }, |
name => {default => 'x000000', test => sub {1} },#sub {$_[0]=~/^[\w ]*$/} }, |
linestyle => {default => 'lines', test => $linestyle_test } |
linestyle => {default => 'lines', test => $linestyle_test } |
); |
); |
|
|
Line 141 sub start_plot {
|
Line 141 sub start_plot {
|
$inside=&Apache::run::evaluate($inside,$safeeval,$$parstack[-1]); |
$inside=&Apache::run::evaluate($inside,$safeeval,$$parstack[-1]); |
&Apache::lonxml::newparser($parser,\$inside); |
&Apache::lonxml::newparser($parser,\$inside); |
##------------------------------------------------------- |
##------------------------------------------------------- |
&get_attributes(\%plot,\%plot_defaults,$parstack,$safeeval,$tagstack); |
&get_attributes(\%plot,\%plot_defaults,$parstack,$safeeval, |
|
$tagstack->[-1]); |
if ($target eq 'web') { |
if ($target eq 'web') { |
} |
} |
return ''; |
return ''; |
Line 157 sub end_plot {
|
Line 158 sub end_plot {
|
## Determine filename -- Need to use the 'id' thingy that Gerd |
## Determine filename -- Need to use the 'id' thingy that Gerd |
## mentioned. |
## mentioned. |
my $tmpdir = '/home/httpd/perl/tmp/'; |
my $tmpdir = '/home/httpd/perl/tmp/'; |
my $filename = $tmpdir.$ENV{'user.name'}.'_'.$ENV{'user.domain'}. |
my $filename = $ENV{'user.name'}.'_'.$ENV{'user.domain'}. |
'_plot.data'; |
'_plot.data'; |
my $usersees=md5_base64($filename.'_'.$ENV{'REMOTE_ADDR'}); |
|
# my $usersees=$filename.'_'.$ENV{'REMOTE_ADDR'}; |
|
|
|
## Write the plot description to the file |
## Write the plot description to the file |
my $fh=Apache::File->new('/home/httpd/perl/tmp/'.$filename); |
my $fh=Apache::File->new(">$tmpdir$filename"); |
$result .= '<pre>'; |
$result .= '<pre>'; |
$result .= &write_gnuplot_file($fh); |
$result .= $filename.$/; |
$result .= '</pre>'; |
print $fh &write_gnuplot_file(); |
|
$result .= '</pre>'.$/; |
## return image tag for the plot |
## return image tag for the plot |
# $result = '<img src=\"/cgi-bin/plot.cgi?'.$usersees.'"'; |
$result .= <<"ENDIMAGE"; |
|
<img src = "/cgi-bin/plot.gif?$filename" |
|
alt = "/cgi-bin/plot.gif?$filename" /> |
|
ENDIMAGE |
} |
} |
return $result; |
return $result; |
} |
} |
Line 177 sub end_plot {
|
Line 179 sub end_plot {
|
sub start_key { |
sub start_key { |
my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; |
my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; |
my $result=''; |
my $result=''; |
&get_attributes(\%key,\%key_defaults,$parstack,$safeeval,$tagstack); |
&get_attributes(\%key,\%key_defaults,$parstack,$safeeval, |
|
$tagstack->[-1]); |
if ($target eq 'web') { |
if ($target eq 'web') { |
# This routine should never return anything. |
# This routine should never return anything. |
} |
} |
Line 254 sub start_label {
|
Line 257 sub start_label {
|
my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; |
my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; |
my $result=''; |
my $result=''; |
my %label; |
my %label; |
&get_attributes(\%label,\%label_defaults,$parstack,$safeeval,$tagstack); |
&get_attributes(\%label,\%label_defaults,$parstack,$safeeval, |
|
$tagstack->[-1]); |
$label{'text'} = &Apache::lonxml::get_all_text("/label",$$parser[-1]); |
$label{'text'} = &Apache::lonxml::get_all_text("/label",$$parser[-1]); |
if (! &$words_test($label{'text'})) { |
if (! &$words_test($label{'text'})) { |
# I should probably warn about it, too. |
# I should probably warn about it, too. |
Line 281 sub start_curve {
|
Line 285 sub start_curve {
|
my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; |
my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; |
my $result=''; |
my $result=''; |
my %curve; |
my %curve; |
&get_attributes(\%curve,\%curve_defaults,$parstack,$safeeval,$tagstack); |
&get_attributes(\%curve,\%curve_defaults,$parstack,$safeeval, |
|
$tagstack->[-1]); |
push (@curves,\%curve); |
push (@curves,\%curve); |
&Apache::lonxml::register('Apache::lonplot',('function','data')); |
&Apache::lonxml::register('Apache::lonplot',('function','data')); |
push (@Apache::lonxml::namespace,'curve'); |
push (@Apache::lonxml::namespace,'curve'); |
Line 372 sub end_data {
|
Line 377 sub end_data {
|
sub start_axis { |
sub start_axis { |
my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; |
my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; |
my $result=''; |
my $result=''; |
&get_attributes(\%axis,\%label_defaults,$parstack,$safeeval,$tagstack); |
&get_attributes(\%axis,\%axis_defaults,$parstack,$safeeval, |
|
$tagstack->[-1]); |
if ($target eq 'web') { |
if ($target eq 'web') { |
# This routine should never return anything. |
# This routine should never return anything. |
} |
} |
Line 400 sub get_attributes{
|
Line 406 sub get_attributes{
|
$values->{$attr} = |
$values->{$attr} = |
&Apache::lonxml::get_param($attr,$parstack,$safeeval); |
&Apache::lonxml::get_param($attr,$parstack,$safeeval); |
if ($values->{$attr} eq '' | !defined($values->{$attr})) { |
if ($values->{$attr} eq '' | !defined($values->{$attr})) { |
$values->{$attr} = $defaults->{$attr}; |
$values->{$attr} = $defaults->{$attr}->{'default'}; |
next; |
next; |
} |
} |
my $test = $defaults->{$attr}->{'test'}; |
my $test = $defaults->{$attr}->{'test'}; |
if (! &$test($values->{$attr})) { |
if (! &$test($values->{$attr})) { |
&Apache::lonxml::warning |
&Apache::lonxml::warning |
($tag.':'.$attr.': Bad value.'.'Replacing your value with : ' |
($tag.':'.$attr.': Bad value.'.'Replacing your value with : ' |
.$defaults->{$attr} ); |
.$defaults->{$attr}->{'default'} ); |
$values->{$attr} = $defaults->{$attr}; |
$values->{$attr} = $defaults->{$attr}->{'default'}; |
} |
} |
return ; |
|
} |
} |
|
return ; |
} |
} |
|
|
sub write_gnuplot_file { |
sub write_gnuplot_file { |
my $fh = shift; |
|
my $gnuplot_input = ''; |
my $gnuplot_input = ''; |
my $curve; |
my $curve; |
# Collect all the colors |
# Collect all the colors |
Line 443 sub write_gnuplot_file {
|
Line 448 sub write_gnuplot_file {
|
'set noborder'.$/ ); # title, xlabel, ylabel |
'set noborder'.$/ ); # title, xlabel, ylabel |
{ |
{ |
$gnuplot_input .= <<"ENDLABELS"; |
$gnuplot_input .= <<"ENDLABELS"; |
set output "-" |
set output |
set title "$title" |
set title "$title" |
set xlabel "$xlabel" |
set xlabel "$xlabel" |
set ylabel "$ylabel" |
set ylabel "$ylabel" |
Line 454 ENDLABELS
|
Line 459 ENDLABELS
|
# Key |
# Key |
if (defined($key{'pos'})) { |
if (defined($key{'pos'})) { |
$gnuplot_input .= 'set key '.$key{'pos'}.' '; |
$gnuplot_input .= 'set key '.$key{'pos'}.' '; |
$gnuplot_input .= ($key{'box'} eq 'on' ? 'box ' : 'nobox '); |
|
if ($key{'title'} ne '') { |
if ($key{'title'} ne '') { |
$gnuplot_input .= 'title "'.$key{'title'}.'"'.$/; |
$gnuplot_input .= 'title "'.$key{'title'}.'" '; |
} else { |
} |
$gnuplot_input .= $/; |
$gnuplot_input .= ($key{'box'} eq 'on' ? 'box ' : 'nobox ').$/; |
} |
|
} else { |
} else { |
$gnuplot_input .= 'set nokey'.$/; |
$gnuplot_input .= 'set nokey'.$/; |
} |
} |
Line 498 ENDLABELS
|
Line 501 ENDLABELS
|
} |
} |
$gnuplot_input .= $/.$datatext; |
$gnuplot_input .= $/.$datatext; |
return $gnuplot_input; |
return $gnuplot_input; |
# print $fh $gnuplot_input; |
|
} |
} |
|
|
1; |
1; |