Annotation of loncom/xml/lonplot.pm, revision 1.4

1.1       matthew     1: # The LearningOnline Network with CAPA
                      2: # Dynamic plot
                      3: #
1.4     ! matthew     4: # $Id: lonplot.pm,v 1.3 2001/12/18 16:06:01 matthew Exp $
1.1       matthew     5: #
                      6: # Copyright Michigan State University Board of Trustees
                      7: #
                      8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
                      9: #
                     10: # LON-CAPA is free software; you can redistribute it and/or modify
                     11: # it under the terms of the GNU General Public License as published by
                     12: # the Free Software Foundation; either version 2 of the License, or
                     13: # (at your option) any later version.
                     14: #
                     15: # LON-CAPA is distributed in the hope that it will be useful,
                     16: # but WITHOUT ANY WARRANTY; without even the implied warranty of
                     17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     18: # GNU General Public License for more details.
                     19: #
                     20: # You should have received a copy of the GNU General Public License
                     21: # along with LON-CAPA; if not, write to the Free Software
                     22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
                     23: #
                     24: # /home/httpd/html/adm/gpl.txt
                     25: #
                     26: # http://www.lon-capa.org/
                     27: #
1.3       matthew    28: # 12/15/01 Matthew
                     29: # 12/18 Matthew
1.1       matthew    30: package Apache::lonplot;
                     31: use strict;
                     32: use Apache::response;
1.2       matthew    33: use Apache::lonxml;
                     34: use Digest::MD5  qw(md5 md5_hex md5_base64);
1.1       matthew    35: 
                     36: sub BEGIN {
                     37:   &Apache::lonxml::register('Apache::lonplot',('plot'));
                     38: }
                     39: 
                     40: 
                     41: ##
                     42: ## Tests used in checking the validitity of input
                     43: ##
                     44: my $int_test       = sub {$_[0]=~/^\d+$/};
                     45: my $real_test      = sub {$_[0]=~/^[+-]?\d*\.?\d*$/};
                     46: my $color_test     = sub {$_[0]=~/^x[\da-f]{6}$/};
                     47: my $onoff_test     = sub {$_[0]=~/^(on|off)$/};
                     48: my $key_pos_test   = sub {$_[0]=~/^(top|bottom|right|left|outside|below)+$/};
                     49: my $sml_test       = sub {$_[0]=~/^(small|medium|large)$/};
                     50: my $linestyle_test = sub {$_[0]=~/^(lines|linespoints|dots|points|steps)$/};
                     51: 
                     52: ##
                     53: ## Default values for attributes of elements
                     54: ##
                     55: my %plot_defaults = 
                     56:     (
                     57:      height       => {default => 200,       test => $int_test  },
                     58:      width        => {default => 200,       test => $int_test  },
                     59:      bgcolor      => {default => "xffffff", test => $color_test},
                     60:      fgcolor      => {default => "x000000", test => $color_test},
                     61:      transparent  => {default => "off",     test => $onoff_test},
                     62:      grid         => {default => "off",     test => $onoff_test},
                     63:      border       => {default => "on" ,     test => $onoff_test},
                     64:      font         => {default => "medium",  test => $sml_test  }
                     65:      );
                     66: 
                     67: my %key_defaults = 
                     68:     (
                     69:      title => { default => "on" ,        test => $onoff_test  },
                     70:      box   => { default => "off" ,       test => $onoff_test  },
                     71:      pos   => { default => "top right" , test => $key_pos_test}
                     72:      );
                     73: 
                     74: my %label_defaults = 
                     75:     (
                     76:      xpos    => {default => 0,         test => $real_test                   },
                     77:      ypos    => {default => 0,         test => $real_test                   },
                     78:      color   => {default => "x000000", test => $color_test                  },
                     79:      justify => {default => "left",    
                     80:                  test => sub {$_[0]=~/^(left|right|center)$/}}
                     81:      );
                     82: 
                     83: my %axis_defaults = 
                     84:     (
                     85:      color     => {default => "x000000", test => $color_test},
                     86:      thickness => {default => 1,         test => $int_test  },
                     87:      xmin      => {default => -10.0,     test => $real_test },
                     88:      xmax      => {default =>  10.0,     test => $real_test },
                     89:      ymin      => {default => -10.0,     test => $real_test },
                     90:      ymax      => {default =>  10.0,     test => $real_test }
                     91:      );
                     92: 
                     93: my %curve_defaults = 
                     94:     (
                     95:      color     => {default => "x000000", test => $color_test      },
                     96:      name      => {default => "x000000", test => sub {$_[0]=~/^[\w ]*$/} },
                     97:      linestyle => {default => "lines",   test => $linestyle_test  }
                     98:      );
                     99: 
                    100: ##
                    101: ## End of defaults
                    102: ##
                    103: my (%plot,%key,%axis,$title,$xlabel,$ylabel,@labels,@curves);
                    104: 
                    105: sub start_plot {
                    106:     %plot = '';   %key='';    %axis=''; 
                    107:     $title='';    $xlabel=''; $ylabel='';
                    108:     @labels = ''; @curves='';
1.2       matthew   109: 
1.1       matthew   110:     my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
                    111:     my $result='';
                    112:     &Apache::lonxml::register('Apache::plot',
                    113: 	     ('title','xlabel','ylabel','key','axis','label','curve'));
                    114:     push (@Apache::lonxml::namespace,'plot');
1.4     ! matthew   115:     ## Always evaluate the insides of the <plot></plot> tags
1.2       matthew   116:     my $inside = &Apache::lonxml::get_all_text("/plot",$$parser[-1]);
1.4     ! matthew   117:     $inside=&Apache::run::evaluate($inside,$safeeval,$$parstack[-1]);
        !           118:     &Apache::lonxml::newparser($parser,\$inside);
1.2       matthew   119:     ##-------------------------------------------------------
                    120:     &get_attributes(\%plot,\%plot_defaults,$parstack,$safeeval,'plot');
1.4     ! matthew   121:     if ($target eq 'web') {
        !           122:     }
1.1       matthew   123:     return '';
                    124: }
                    125: 
                    126: sub end_plot {
                    127:     my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
                    128:     pop @Apache::lonxml::namespace;
1.4     ! matthew   129:     &Apache::lonxml::deregister('Apache::lonplot',
        !           130: 	('title','xlabel','ylabel','key','axis','label','curve'));
        !           131:     my $result = '';
        !           132:     if ($target eq 'web') {
        !           133: 	## Determine filename -- may need a better way later
        !           134: 	my $tmpdir = '/home/httpd/perl/tmp/';
        !           135: 	my $filename = $tmpdir.$ENV{'user.name'}.'_'.$ENV{'user.domain'}.
        !           136: 	    '_plot.data';
        !           137: 	my $usersees=md5_base64($filename.'_'.$ENV{'REMOTE_ADDR'});
        !           138: 	
        !           139: 	## Write the plot description to the file
        !           140: 	my $fh=&Apache::File->new('/home/httpd/perl/tmp/'.$realname);
        !           141: 	# write plot values
        !           142: 	# write title, xlabel, ylabel
        !           143: 	# write key values
        !           144: 	# write axis values
        !           145: 	# write label values
        !           146: 	# write curve values
        !           147: 	## Ack! 
        !           148: 	## return image tag for the plot
        !           149: 	$result = '<img src=\"/cgi-bin/plot.cgi?'.$usersees.'"';
        !           150:     }
1.1       matthew   151:     return $result;
                    152: }
1.2       matthew   153: 
1.1       matthew   154: ##----------------------------------------------------------------- key
                    155: sub start_key {
                    156:     my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
                    157:     my $result='';
1.3       matthew   158:     &get_attributes(\%key,\%key_defaults,$parstack,$safeeval,$tagstack);
1.4     ! matthew   159:     if ($target eq 'web') {
        !           160: 	# This routine should never return anything.
        !           161:     }
1.1       matthew   162:     return $result;
                    163: }
                    164: 
                    165: sub end_key {
                    166:     my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
                    167:     my $result = '';
1.4     ! matthew   168:     if ($target eq 'web') {
        !           169: 	# This routine should never return anything.
        !           170:     }
1.1       matthew   171:     return $result;
                    172: }
                    173: ##------------------------------------------------------------------- title
                    174: sub start_title {
                    175:     my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
                    176:     $title = &Apache::lonxml::get_all_text("/title",$$parser[-1]);
                    177:     my $result='';
1.4     ! matthew   178:     if ($target eq 'web') {
        !           179: 	# This routine should never return anything.
        !           180:     }
1.1       matthew   181:     return $result;
                    182: }
                    183: 
                    184: sub end_title {
                    185:     my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
                    186:     my $result = '';
1.4     ! matthew   187:     if ($target eq 'web') {
        !           188: 	# This routine should never return anything.
        !           189:     }
1.1       matthew   190:     return $result;
                    191: }
                    192: ##------------------------------------------------------------------- xlabel
                    193: sub start_xlabel {
                    194:     my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
                    195:     my $result='';
                    196:     $xlabel = &Apache::lonxml::get_all_text("/xlabel",$$parser[-1]);
1.4     ! matthew   197:     if ($target eq 'web') {
        !           198: 	# This routine should never return anything.
        !           199:     }
1.1       matthew   200:     return $result;
                    201: }
                    202: 
                    203: sub end_xlabel {
                    204:     my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
                    205:     my $result = '';
1.4     ! matthew   206:     if ($target eq 'web') {
        !           207: 	# This routine should never return anything.
        !           208:     }
1.1       matthew   209:     return $result;
                    210: }
                    211: ##------------------------------------------------------------------- ylabel
                    212: sub start_ylabel {
                    213:     my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
                    214:     my $result='';
                    215:     $ylabel = &Apache::lonxml::get_all_text("/ylabel",$$parser[-1]);
1.4     ! matthew   216:     if ($target eq 'web') {
        !           217: 	# This routine should never return anything.
        !           218:     }
1.1       matthew   219:     return $result;
                    220: }
                    221: 
                    222: sub end_ylabel {
                    223:     my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
                    224:     my $result = '';
1.4     ! matthew   225:     if ($target eq 'web') {
        !           226: 	# This routine should never return anything.
        !           227:     }
1.1       matthew   228:     return $result;
                    229: }
                    230: ##------------------------------------------------------------------- label
                    231: sub start_label {
                    232:     my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
                    233:     my $result='';
1.3       matthew   234:     my %label;
                    235:     &get_attributes($label,\%label_defaults,$parstack,$safeeval,$tagstack);
1.1       matthew   236:     $label->{'text'} = &Apache::lonxml::get_all_text("/label",$$parser[-1]);
1.3       matthew   237:     push(@labels,\%label);
1.4     ! matthew   238:     if ($target eq 'web') {
        !           239: 	# This routine should never return anything.
        !           240:     }
1.1       matthew   241:     return $result;
                    242: }
                    243: 
                    244: sub end_label {
                    245:     my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
                    246:     my $result = '';
1.4     ! matthew   247:     if ($target eq 'web') {
        !           248: 	# This routine should never return anything.
        !           249:     }
1.1       matthew   250:     return $result;
                    251: }
                    252: 
                    253: ##------------------------------------------------------------------- curve
                    254: sub start_curve {
                    255:     my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
                    256:     my $result='';
1.3       matthew   257:     my %curve;
                    258:     &get_attributes($curve,\%curve_defaults,$parstack,$safeeval,$tagstack);
1.1       matthew   259:     push (@curves,$curve);
1.4     ! matthew   260:     &Apache::lonxml::register('Apache::lonplot',('function','data'));
1.1       matthew   261:     push (@Apache::lonxml::namespace,'curve');
1.4     ! matthew   262:     if ($target eq 'web') {
        !           263: 	# This routine should never return anything.
        !           264:     }
1.1       matthew   265:     return $result;
                    266: }
                    267: 
                    268: sub end_curve {
                    269:     my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
                    270:     my $result = '';
1.4     ! matthew   271:     pop @Apache::lonxml::namespace;
        !           272:     &Apache::lonxml::deregister('Apache::lonplot',('function','data'));
        !           273:     if ($target eq 'web') {
        !           274: 	# This routine should never return anything.
        !           275:     }
1.1       matthew   276:     return $result;
                    277: }
                    278: 
                    279: ##------------------------------------------------------------ curve function
                    280: sub start_function {
                    281:     my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
                    282:     my $result='';
1.4     ! matthew   283:     if (exists($curves[-1]->{'data'}) {
        !           284: 	&Apache::lonxml::warning('Use of <function> precludes use of <data>.  The <data> will be omitted in favor of the <function> declaration.');
        !           285: 	delete($curves[-1]->{'data'});
        !           286:     }
1.1       matthew   287:     $curves[-1]->{'function'} = 
                    288: 	&Apache::lonxml::get_all_text("/function",$$parser[-1]);
1.4     ! matthew   289:     if ($target eq 'web') {
        !           290: 	# This routine should never return anything.
        !           291:     }
1.1       matthew   292:     return $result;
                    293: }
                    294: 
                    295: sub end_function {
                    296:     my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
                    297:     my $result = '';
1.4     ! matthew   298:     if ($target eq 'web') {
        !           299: 	# This routine should never return anything.
        !           300:     }
1.1       matthew   301:     return $result;
                    302: }
                    303: 
                    304: ##------------------------------------------------------------ curve  data
                    305: sub start_data {
                    306:     my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
                    307:     my $result='';
1.4     ! matthew   308:     if (exists($curves[-1]->{'function'})) {
        !           309: 	&Apache::lonxml::warning('Use of <data> precludes use of <function>.  The <function> will be omitted in favor of the <data> declaration.');
        !           310: 	delete($curves[-1]->{'function'});
        !           311:     }
        !           312:     my $datatext = &Apache::lonxml::get_all_text("/data",$$parser[-1]);
        !           313:     $datatext =~ s/(\s+$|^\s+)//g;
        !           314:     $datatext =~ s/\s+/ /g;
        !           315:     if ($datatext !~ /^(([+-]?\d*\.?\d*)[, ]?)+$/) {
        !           316: 	&Apache::lonxml::warning('Malformed data: '.$datatext);
        !           317: 	$datatext = '';
        !           318:     }
        !           319:     push( @{$curves[-1]->{'data'}},$datatext;
        !           320:     if ($target eq 'web') {
        !           321: 	# This routine should never return anything.
        !           322:     }
1.1       matthew   323:     return $result;
                    324: }
                    325: 
                    326: sub end_data {
                    327:     my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
                    328:     my $result = '';
1.4     ! matthew   329:     if ($target eq 'web') {
        !           330: 	# This routine should never return anything.
        !           331:     }
1.1       matthew   332:     return $result;
                    333: }
                    334: 
                    335: ##------------------------------------------------------------------- axis
                    336: sub start_axis {
                    337:     my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
                    338:     my $result='';
1.3       matthew   339:     &get_attributes(\%axis,\%label_defaults,$parstack,$safeeval,$tagstack);
1.4     ! matthew   340:     if ($target eq 'web') {
        !           341: 	# This routine should never return anything.
        !           342:     }
1.1       matthew   343:     return $result;
                    344: }
                    345: 
                    346: sub end_axis {
                    347:     my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
                    348:     my $result = '';
1.4     ! matthew   349:     if ($target eq 'web') {
        !           350: 	# This routine should never return anything.
        !           351:     }
1.1       matthew   352:     return $result;
                    353: }
                    354: 
                    355: ##------------------------------------------------------------------- misc
1.2       matthew   356: sub get_attributes{
                    357:     %values   = %{shift};
                    358:     %defaults = %{shift};
                    359:     $parstack = shift;
                    360:     $safeeval = shift;
                    361:     $tag      = shift;
                    362:     my $attr;
                    363:     foreach $attr (keys %defaults) {
                    364: 	$values{$attr} = &Apache::lonxml::get_param($attr,$parstack,$safeeval);
                    365: 	my $test = $defaults{$attr}->{'test'};
                    366: 	if (! &$test($values{$attr})) {
                    367: 	    &Apache::lonxml::warning($tag.':'.$attr.': Bad value.  Replacing your value with : '.$defaults{$attr});
                    368: 	    $values{$attr} = $defaults{$attr};
                    369:     }
                    370:     return ;
                    371: }
1.1       matthew   372: 
                    373: 1;
                    374: __END__
1.4     ! matthew   375: 
        !           376: 
        !           377: 
        !           378: 
        !           379: 

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>