loncom/xml/lonplot.pm - view

File: [LON-CAPA] / loncom / xml / lonplot.pm
Revision 1.4: download - view: text, annotated - select for diffs
Tue Dec 18 20:34:58 2001 UTC (22 years, 4 months ago) by matthew
Branches: MAIN
CVS tags: HEAD

More misc changes.

# The LearningOnline Network with CAPA # Dynamic plot # # $Id: lonplot.pm,v 1.4 2001/12/18 20:34:58 matthew Exp $ # # Copyright Michigan State University Board of Trustees # # This file is part of the LearningOnline Network with CAPA (LON-CAPA). # # LON-CAPA is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # LON-CAPA 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 the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with LON-CAPA; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA # # /home/httpd/html/adm/gpl.txt # # http://www.lon-capa.org/ # # 12/15/01 Matthew # 12/18 Matthew package Apache::lonplot; use strict; use Apache::response; use Apache::lonxml; use Digest::MD5 qw(md5 md5_hex md5_base64); sub BEGIN { &Apache::lonxml::register('Apache::lonplot',('plot')); } ## ## Tests used in checking the validitity of input ## my $int_test = sub {$_[0]=~/^\d+$/}; my $real_test = sub {$_[0]=~/^[+-]?\d*\.?\d*$/}; my $color_test = sub {$_[0]=~/^x[\da-f]{6}$/}; my $onoff_test = sub {$_[0]=~/^(on|off)$/}; my $key_pos_test = sub {$_[0]=~/^(top|bottom|right|left|outside|below)+$/}; my $sml_test = sub {$_[0]=~/^(small|medium|large)$/}; my $linestyle_test = sub {$_[0]=~/^(lines|linespoints|dots|points|steps)$/}; ## ## Default values for attributes of elements ## my %plot_defaults = ( height => {default => 200, test => $int_test }, width => {default => 200, test => $int_test }, bgcolor => {default => "xffffff", test => $color_test}, fgcolor => {default => "x000000", test => $color_test}, transparent => {default => "off", test => $onoff_test}, grid => {default => "off", test => $onoff_test}, border => {default => "on" , test => $onoff_test}, font => {default => "medium", test => $sml_test } ); my %key_defaults = ( title => { default => "on" , test => $onoff_test }, box => { default => "off" , test => $onoff_test }, pos => { default => "top right" , test => $key_pos_test} ); my %label_defaults = ( xpos => {default => 0, test => $real_test }, ypos => {default => 0, test => $real_test }, color => {default => "x000000", test => $color_test }, justify => {default => "left", test => sub {$_[0]=~/^(left|right|center)$/}} ); my %axis_defaults = ( color => {default => "x000000", test => $color_test}, thickness => {default => 1, test => $int_test }, xmin => {default => -10.0, test => $real_test }, xmax => {default => 10.0, test => $real_test }, ymin => {default => -10.0, test => $real_test }, ymax => {default => 10.0, test => $real_test } ); my %curve_defaults = ( color => {default => "x000000", test => $color_test }, name => {default => "x000000", test => sub {$_[0]=~/^[\w ]*$/} }, linestyle => {default => "lines", test => $linestyle_test } ); ## ## End of defaults ## my (%plot,%key,%axis,$title,$xlabel,$ylabel,@labels,@curves); sub start_plot { %plot = ''; %key=''; %axis=''; $title=''; $xlabel=''; $ylabel=''; @labels = ''; @curves=''; my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result=''; &Apache::lonxml::register('Apache::plot', ('title','xlabel','ylabel','key','axis','label','curve')); push (@Apache::lonxml::namespace,'plot'); ## Always evaluate the insides of the <plot></plot> tags my $inside = &Apache::lonxml::get_all_text("/plot",$$parser[-1]); $inside=&Apache::run::evaluate($inside,$safeeval,$$parstack[-1]); &Apache::lonxml::newparser($parser,\$inside); ##------------------------------------------------------- &get_attributes(\%plot,\%plot_defaults,$parstack,$safeeval,'plot'); if ($target eq 'web') { } return ''; } sub end_plot { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; pop @Apache::lonxml::namespace; &Apache::lonxml::deregister('Apache::lonplot', ('title','xlabel','ylabel','key','axis','label','curve')); my $result = ''; if ($target eq 'web') { ## Determine filename -- may need a better way later my $tmpdir = '/home/httpd/perl/tmp/'; my $filename = $tmpdir.$ENV{'user.name'}.'_'.$ENV{'user.domain'}. '_plot.data'; my $usersees=md5_base64($filename.'_'.$ENV{'REMOTE_ADDR'}); ## Write the plot description to the file my $fh=&Apache::File->new('/home/httpd/perl/tmp/'.$realname); # write plot values # write title, xlabel, ylabel # write key values # write axis values # write label values # write curve values ## Ack! ## return image tag for the plot $result = '<img src=\"/cgi-bin/plot.cgi?'.$usersees.'"'; } return $result; } ##----------------------------------------------------------------- key sub start_key { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result=''; &get_attributes(\%key,\%key_defaults,$parstack,$safeeval,$tagstack); if ($target eq 'web') { # This routine should never return anything. } return $result; } sub end_key { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result = ''; if ($target eq 'web') { # This routine should never return anything. } return $result; } ##------------------------------------------------------------------- title sub start_title { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; $title = &Apache::lonxml::get_all_text("/title",$$parser[-1]); my $result=''; if ($target eq 'web') { # This routine should never return anything. } return $result; } sub end_title { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result = ''; if ($target eq 'web') { # This routine should never return anything. } return $result; } ##------------------------------------------------------------------- xlabel sub start_xlabel { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result=''; $xlabel = &Apache::lonxml::get_all_text("/xlabel",$$parser[-1]); if ($target eq 'web') { # This routine should never return anything. } return $result; } sub end_xlabel { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result = ''; if ($target eq 'web') { # This routine should never return anything. } return $result; } ##------------------------------------------------------------------- ylabel sub start_ylabel { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result=''; $ylabel = &Apache::lonxml::get_all_text("/ylabel",$$parser[-1]); if ($target eq 'web') { # This routine should never return anything. } return $result; } sub end_ylabel { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result = ''; if ($target eq 'web') { # This routine should never return anything. } return $result; } ##------------------------------------------------------------------- label sub start_label { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result=''; my %label; &get_attributes($label,\%label_defaults,$parstack,$safeeval,$tagstack); $label->{'text'} = &Apache::lonxml::get_all_text("/label",$$parser[-1]); push(@labels,\%label); if ($target eq 'web') { # This routine should never return anything. } return $result; } sub end_label { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result = ''; if ($target eq 'web') { # This routine should never return anything. } return $result; } ##------------------------------------------------------------------- curve sub start_curve { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result=''; my %curve; &get_attributes($curve,\%curve_defaults,$parstack,$safeeval,$tagstack); push (@curves,$curve); &Apache::lonxml::register('Apache::lonplot',('function','data')); push (@Apache::lonxml::namespace,'curve'); if ($target eq 'web') { # This routine should never return anything. } return $result; } sub end_curve { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result = ''; pop @Apache::lonxml::namespace; &Apache::lonxml::deregister('Apache::lonplot',('function','data')); if ($target eq 'web') { # This routine should never return anything. } return $result; } ##------------------------------------------------------------ curve function sub start_function { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result=''; if (exists($curves[-1]->{'data'}) { &Apache::lonxml::warning('Use of <function> precludes use of <data>. The <data> will be omitted in favor of the <function> declaration.'); delete($curves[-1]->{'data'}); } $curves[-1]->{'function'} = &Apache::lonxml::get_all_text("/function",$$parser[-1]); if ($target eq 'web') { # This routine should never return anything. } return $result; } sub end_function { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result = ''; if ($target eq 'web') { # This routine should never return anything. } return $result; } ##------------------------------------------------------------ curve data sub start_data { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result=''; if (exists($curves[-1]->{'function'})) { &Apache::lonxml::warning('Use of <data> precludes use of <function>. The <function> will be omitted in favor of the <data> declaration.'); delete($curves[-1]->{'function'}); } my $datatext = &Apache::lonxml::get_all_text("/data",$$parser[-1]); $datatext =~ s/(\s+$|^\s+)//g; $datatext =~ s/\s+/ /g; if ($datatext !~ /^(([+-]?\d*\.?\d*)[, ]?)+$/) { &Apache::lonxml::warning('Malformed data: '.$datatext); $datatext = ''; } push( @{$curves[-1]->{'data'}},$datatext; if ($target eq 'web') { # This routine should never return anything. } return $result; } sub end_data { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result = ''; if ($target eq 'web') { # This routine should never return anything. } return $result; } ##------------------------------------------------------------------- axis sub start_axis { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result=''; &get_attributes(\%axis,\%label_defaults,$parstack,$safeeval,$tagstack); if ($target eq 'web') { # This routine should never return anything. } return $result; } sub end_axis { my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_; my $result = ''; if ($target eq 'web') { # This routine should never return anything. } return $result; } ##------------------------------------------------------------------- misc sub get_attributes{ %values = %{shift}; %defaults = %{shift}; $parstack = shift; $safeeval = shift; $tag = shift; my $attr; foreach $attr (keys %defaults) { $values{$attr} = &Apache::lonxml::get_param($attr,$parstack,$safeeval); my $test = $defaults{$attr}->{'test'}; if (! &$test($values{$attr})) { &Apache::lonxml::warning($tag.':'.$attr.': Bad value. Replacing your value with : '.$defaults{$attr}); $values{$attr} = $defaults{$attr}; } return ; } 1; __END__