[BACK]Return to loncommon.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / interface

Diff for /loncom/interface/loncommon.pm between versions 1.19 and 1.38

version 1.19, 2001/12/21 17:06:56 version 1.38, 2002/06/24 19:06:05
Line 29 Line 29
 # 2/13-12/7 Guy Albertelli  # 2/13-12/7 Guy Albertelli
 # 12/11,12/12,12/17 Scott Harrison  # 12/11,12/12,12/17 Scott Harrison
 # 12/21 Gerd Kortemeyer  # 12/21 Gerd Kortemeyer
   # 12/21 Scott Harrison
   # 12/25,12/28 Gerd Kortemeyer
   # YEAR=2002
   # 1/4 Gerd Kortemeyer
   
 # Makes a table out of the previous attempts  # Makes a table out of the previous attempts
 # Inputs result_from_symbread, user, domain, course_id  # Inputs result_from_symbread, user, domain, course_id
 # Reads in non-network-related .tab files  # Reads in non-network-related .tab files
   
   # POD header:
   
   =head1 NAME
   
   Apache::loncommon - pile of common routines
   
   =head1 SYNOPSIS
   
   Referenced by other mod_perl Apache modules.
   
   Invocation:
    &Apache::loncommon::SUBROUTINENAME(ARGUMENTS);
   
   =head1 INTRODUCTION
   
   Common collection of used subroutines.  This collection helps remove
   redundancy from other modules and increase efficiency of memory usage.
   
   Current things done:
   
    Makes a table out of the previous homework attempts
    Inputs result_from_symbread, user, domain, course_id
    Reads in non-network-related .tab files
   
   This is part of the LearningOnline Network with CAPA project
   described at http://www.lon-capa.org.
   
   =head2 General Subroutines
   
   =over 4
   
   =cut 
   
   # End of POD header
 package Apache::loncommon;  package Apache::loncommon;
   
 use strict;  use strict;
   use Apache::lonnet();
 use POSIX qw(strftime);  use POSIX qw(strftime);
 use Apache::Constants qw(:common);  use Apache::Constants qw(:common);
 use Apache::lonmsg();  use Apache::lonmsg();
   my $readit;
   
   # ----------------------------------------------- Filetypes/Languages/Copyright
 my %language;  my %language;
 my %cprtag;  my %cprtag;
 my %fe; my %fd;  my %fe; my %fd;
 my %fc;  my %fc;
   
   # -------------------------------------------------------------- Thesaurus data
   my @therelated;
   my @theword;
   my @thecount;
   my %theindex;
   my $thetotalcount;
   my $thefuzzy=2;
   my $thethreshold=0.1/$thefuzzy;
   my $theavecount;
   
 # ----------------------------------------------------------------------- BEGIN  # ----------------------------------------------------------------------- BEGIN
   
   =pod
   
   =item BEGIN() 
   
   Initialize values from language.tab, copyright.tab, filetypes.tab,
   and filecategories.tab.
   
   =cut
   # ----------------------------------------------------------------------- BEGIN
   
 BEGIN {  BEGIN {
   
       unless ($readit) {
 # ------------------------------------------------------------------- languages  # ------------------------------------------------------------------- languages
     {      {
  my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.   my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
Line 104  BEGIN { Line 167  BEGIN {
     }      }
  }   }
     }      }
   # -------------------------------------------------------------- Thesaurus data
       {
    my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
          '/thesaurus.dat');
    if ($fh) {
               while (<$fh>) {
                  my ($tword,$tindex,$tcount,$trelated)=split(/\@/,$_);
                  $theindex{$tword}=$tindex;
                  $theword[$tindex]=$tword;
                  $thecount[$tindex]=$tcount;
                  $thetotalcount+=$tcount;
                  $therelated[$tindex]=$trelated;
      }
           }
           $theavecount=$thetotalcount/$#thecount;
       }
       &Apache::lonnet::logthis(
                 "<font color=yellow>INFO: Read file types and thesaurus</font>");
       $readit=1;
   }
       
   }
   # ============================================================= END BEGIN BLOCK
   
   =item linked_select_forms(...)
   
   linked_select_forms returns a string containing a <script></script> block
   and html for two <select> menus.  The select menus will be linked in that
   changing the value of the first menu will result in new values being placed
   in the second menu.  The values in the select menu will appear in alphabetical
   order.
   
   linked_select_forms takes the following ordered inputs:
   
   =over 4
   
   =item $formname, the name of the <form> tag
   
   =item $middletext, the text which appears between the <select> tags
   
   =item $firstdefault, the default value for the first menu
   
   =item $firstselectname, the name of the first <select> tag
   
   =item $secondselectname, the name of the second <select> tag
   
   =item $hashref, a reference to a hash containing the data for the menus.
   
   Below is an example of such a hash.  Only the 'text', 'default', and 
   'select2' keys must appear as stated.  keys(%menu) are the possible 
   values for the first select menu.  The text that coincides with the 
   first menu values is given in $menu{$choice1}->{'text'}.  The values 
   and text for the second menu are given in the hash pointed to by 
   $menu{$choice1}->{'select2'}.  
   
    my %menu = ( A1 => { text =>"Choice A1" ,
                         default => "B3",
                         select2 => { 
                             B1 => "Choice B1",
                             B2 => "Choice B2",
                             B3 => "Choice B3",
                             B4 => "Choice B4"
                             }
                     },
                 A2 => { text =>"Choice A2" ,
                         default => "C2",
                         select2 => { 
                             C1 => "Choice C1",
                             C2 => "Choice C2",
                             C3 => "Choice C3"
                             }
                     },
                 A3 => { text =>"Choice A3" ,
                         default => "D6",
                         select2 => { 
                             D1 => "Choice D1",
                             D2 => "Choice D2",
                             D3 => "Choice D3",
                             D4 => "Choice D4",
                             D5 => "Choice D5",
                             D6 => "Choice D6",
                             D7 => "Choice D7"
                             }
                     }
                 );
   
   =back
   
   =cut
   
   # ------------------------------------------------
   
   sub linked_select_forms {
       my ($formname,
           $middletext,
           $firstdefault,
           $firstselectname,
           $secondselectname, 
           $hashref
           ) = @_;
       my $second = "document.$formname.$secondselectname";
       my $first = "document.$formname.$firstselectname";
       # output the javascript to do the changing
       my $result = '';
       $result.="<script>\n";
       $result.="var select2data = new Object();\n";
       $" = '","';
       my $debug = '';
       foreach my $s1 (sort(keys(%$hashref))) {
           $result.="select2data.d_$s1 = new Object();\n";        
           $result.="select2data.d_$s1.def = new String('".
               $hashref->{$s1}->{'default'}."');\n";
           $result.="select2data.d_$s1.values = new Array(";        
           my @s2values = sort(keys( %{ $hashref->{$s1}->{'select2'} } ));
           $result.="\"@s2values\");\n";
           $result.="select2data.d_$s1.texts = new Array(";        
           my @s2texts;
           foreach my $value (@s2values) {
               push @s2texts, $hashref->{$s1}->{'select2'}->{$value};
           }
           $result.="\"@s2texts\");\n";
       }
       $"=' ';
       $result.= <<"END";
   
   function select1_changed() {
       // Determine new choice
       var newvalue = "d_" + $first.value;
       // update select2
       var values     = select2data[newvalue].values;
       var texts      = select2data[newvalue].texts;
       var select2def = select2data[newvalue].def;
       var i;
       // out with the old
       for (i = 0; i < $second.options.length; i++) {
           $second.options[i] = null;
       }
       // in with the nuclear
       for (i=0;i<values.length; i++) {
           $second.options[i] = new Option(values[i]);
           $second.options[i].text = texts[i];
           if (values[i] == select2def) {
               $second.options[i].selected = true;
           }
       }
   }
   </script>
   END
       # output the initial values for the selection lists
       $result .= "<select size=\"1\" name=\"$firstselectname\" onchange=\"select1_changed()\">\n";
       foreach my $value (sort(keys(%$hashref))) {
           $result.="    <option value=\"$value\" ";
           $result.=" selected=\"true\" " if ($value eq $firstdefault);
           $result.=">$hashref->{$value}->{'text'}</option>\n";
       }
       $result .= "</select>\n";
       my %select2 = %{$hashref->{$firstdefault}->{'select2'}};
       $result .= $middletext;
       $result .= "<select size=\"1\" name=\"$secondselectname\">\n";
       my $seconddefault = $hashref->{$firstdefault}->{'default'};
       foreach my $value (sort(keys(%select2))) {
           $result.="    <option value=\"$value\" ";        
           $result.=" selected=\"true\" " if ($value eq $seconddefault);
           $result.=">$select2{$value}</option>\n";
       }
       $result .= "</select>\n";
       #    return $debug;
       return $result;
   }   #  end of sub linked_select_forms {
   
   ###############################################################
   
   =item csv_translate($text) 
   
   Translate $text to allow it to be output as a 'comma seperated values' 
   format.
   
   =cut
   
   sub csv_translate {
       my $text = shift;
       $text =~ s/\"/\"\"/g;
       $text =~ s/\n//g;
       return $text;
   }
   
   ###############################################################
   
   ###############################################################
   ##        Home server <option> list generating code          ##
   ###############################################################
   #-------------------------------------------
   
   =item get_domains()
   
   Returns an array containing each of the domains listed in the hosts.tab
   file.
   
   =cut
   
   #-------------------------------------------
   sub get_domains {
       # The code below was stolen from "The Perl Cookbook", p 102, 1st ed.
       my @domains;
       my %seen;
       foreach (sort values(%Apache::lonnet::hostdom)) {
           push (@domains,$_) unless $seen{$_}++;
       }
       return @domains;
   }
   
   #-------------------------------------------
   
   =item select_dom_form($defdom,$name)
   
   Returns a string containing a <select name='$name' size='1'> form to 
   allow a user to select the domain to preform an operation in.  
   See loncreateuser.pm for an example invocation and use.
   
   =cut
   
   #-------------------------------------------
   sub select_dom_form {
       my ($defdom,$name) = @_;
       my @domains = get_domains();
       my $selectdomain = "<select name=\"$name\" size=\"1\">\n";
       foreach (@domains) {
           $selectdomain.="<option value=\"$_\" ".
               ($_ eq $defdom ? 'selected' : '').
                   ">$_</option>\n";
       }
       $selectdomain.="</select>";
       return $selectdomain;
   }
   
   #-------------------------------------------
   
   =item get_home_servers($domain)
   
   Returns a hash which contains keys like '103l3' and values like 
   'kirk.lite.msu.edu'.  All of the keys will be for machines in the
   given $domain.
   
   =cut
   
   #-------------------------------------------
   sub get_home_servers {
       my $domain = shift;
       my %home_servers;
       foreach (keys(%Apache::lonnet::libserv)) {
           if ($Apache::lonnet::hostdom{$_} eq $domain) {
               $home_servers{$_} = $Apache::lonnet::hostname{$_};
           }
       }
       return %home_servers;
   }
   
   #-------------------------------------------
   
   =item home_server_option_list($domain)
   
   returns a string which contains an <option> list to be used in a 
   <select> form input.  See loncreateuser.pm for an example.
   
   =cut
   
   #-------------------------------------------
   sub home_server_option_list {
       my $domain = shift;
       my %servers = &get_home_servers($domain);
       my $result = '';
       foreach (sort keys(%servers)) {
           $result.=
               '<option value="'.$_.'">'.$_.' '.$servers{$_}."</option>\n";
       }
       return $result;
   }
   ###############################################################
   ##    End of home server <option> list generating code       ##
   ###############################################################
   
   ###############################################################
   ##    Authentication changing form generation subroutines    ##
   ###############################################################
   ##
   ## All of the authform_xxxxxxx subroutines take their inputs in a
   ## hash, and have reasonable default values.
   ##
   ##    formname = the name given in the <form> tag.
   #-------------------------------------------
   
   =item authform_xxxxxx
   
   The authform_xxxxxx subroutines provide javascript and html forms which 
   handle some of the conveniences required for authentication forms.  
   This is not an optimal method, but it works.  
   
   See loncreateuser.pm for invocation and use examples.
   
   =over 4
   
   =item authform_header
   
   =item authform_authorwarning
   
   =item authform_nochange
   
   =item authform_kerberos
   
   =item authform_internal
   
   =item authform_filesystem
   
   =back
   
   =cut
   
   #-------------------------------------------
   sub authform_header{  
       my %in = (
           formname => 'cu',
           kerb_def_dom => 'MSU.EDU',
           @_,
       );
       $in{'formname'} = 'document.' . $in{'formname'};
       my $result='';
       $result.=<<"END";
   var current = new Object();
   current.radiovalue = 'nochange';
   current.argfield = null;
   
   function changed_radio(choice,currentform) {
       var choicearg = choice + 'arg';
       // If a radio button in changed, we need to change the argfield
       if (current.radiovalue != choice) {
           current.radiovalue = choice;
           if (current.argfield != null) {
               currentform.elements[current.argfield].value = '';
           }
           if (choice == 'nochange') {
               current.argfield = null;
           } else {
               current.argfield = choicearg;
               switch(choice) {
                   case 'krb': 
                       currentform.elements[current.argfield].value = 
                           "$in{'kerb_def_dom'}";
                   break;
                 default:
                   break;
               }
           }
       }
       return;
   }
   
   function changed_text(choice,currentform) {
       var choicearg = choice + 'arg';
       if (currentform.elements[choicearg].value !='') {
           switch (choice) {
               case 'krb': currentform.elements[choicearg].value =
                   currentform.elements[choicearg].value.toUpperCase();
                   break;
               default:
           }
           // clear old field
           if ((current.argfield != choicearg) && (current.argfield != null)) {
               currentform.elements[current.argfield].value = '';
           }
           current.argfield = choicearg;
       }
       set_auth_radio_buttons(choice,currentform);
       return;
   }
   
   function set_auth_radio_buttons(newvalue,currentform) {
       var i=0;
       while (i < currentform.login.length) {
           if (currentform.login[i].value == newvalue) { break; }
           i++;
       }
       if (i == currentform.login.length) {
           return;
       }
       current.radiovalue = newvalue;
       currentform.login[i].checked = true;
       return;
   }
   END
       return $result;
   }
   
   sub authform_authorwarning{
       my $result='';
       $result=<<"END";
   <i>As a general rule, only authors or co-authors should be filesystem
   authenticated (which allows access to the server filesystem).</i>
   END
       return $result;
   }
   
   sub authform_nochange{  
       my %in = (
                 formname => 'document.cu',
                 kerb_def_dom => 'MSU.EDU',
                 @_,
             );
       my $result='';
       $result.=<<"END";
   <input type="radio" name="login" value="nochange" checked="checked"
          onclick="javascript:changed_radio('nochange',$in{'formname'});">
   Do not change login data
   END
       return $result;
   }
   
   sub authform_kerberos{  
       my %in = (
                 formname => 'document.cu',
                 kerb_def_dom => 'MSU.EDU',
                 @_,
                 );
       my $result='';
       $result.=<<"END";
   <input type="radio" name="login" value="krb" 
          onclick="javascript:changed_radio('krb',$in{'formname'});"
          onchange="javascript:changed_radio('krb',$in{'formname'});">
   Kerberos authenticated with domain
   <input type="text" size="10" name="krbarg" value=""
          onchange="javascript:changed_text('krb',$in{'formname'});">
   END
       return $result;
   }
   
   sub authform_internal{  
       my %args = (
                   formname => 'document.cu',
                   kerb_def_dom => 'MSU.EDU',
                   @_,
                   );
       my $result='';
       $result.=<<"END";
   <input type="radio" name="login" value="int"
          onchange="javascript:changed_radio('int',$args{'formname'});"
          onclick="javascript:changed_radio('int',$args{'formname'});">
   Internally authenticated (with initial password 
   <input type="text" size="10" name="intarg" value=""
          onchange="javascript:changed_text('int',$args{'formname'});">
   END
       return $result;
   }
   
   sub authform_local{  
       my %in = (
                 formname => 'document.cu',
                 kerb_def_dom => 'MSU.EDU',
                 @_,
                 );
       my $result='';
       $result.=<<"END";
   <input type="radio" name="login" value="loc"
          onchange="javascript:changed_radio('loc',$in{'formname'});"
          onclick="javascript:changed_radio('loc',$in{'formname'});"> 
   Local Authentication with argument
   <input type="text" size="10" name="locarg" value=""
          onchange="javascript:changed_text('loc',$in{'formname'});">
   END
       return $result;
   }
   
   sub authform_filesystem{  
       my %in = (
                 formname => 'document.cu',
                 kerb_def_dom => 'MSU.EDU',
                 @_,
                 );
       my $result='';
       $result.=<<"END";
   <input type="radio" name="login" value="fsys" 
          onchange="javascript:changed_radio('fsys',$in{'formname'});"
          onclick="javascript:changed_radio('fsys',$in{'formname'});"> 
   Filesystem authenticated (with initial password 
   <input type="text" size="10" name="fsysarg" value=""
          onchange="javascript:changed_text('fsys',$in{'formname'});">
   END
       return $result;
   }
   
   ###############################################################
   ##   End Authentication changing form generation functions   ##
   ###############################################################
   
   
   
   # ---------------------------------------------------------- Is this a keyword?
   
   sub keyword {
       my $newword=shift;
       $newword=~s/\W//g;
       $newword=~tr/A-Z/a-z/;
       my $tindex=$theindex{$newword};
       if ($tindex) {
           if ($thecount[$tindex]>$theavecount) {
              return 1;
           }
       }
       return 0;
   }
   # -------------------------------------------------------- Return related words
   
   sub related {
       my $newword=shift;
       $newword=~s/\W//g;
       $newword=~tr/A-Z/a-z/;
       my $tindex=$theindex{$newword};
       if ($tindex) {
           my %found=();
           foreach (split(/\,/,$therelated[$tindex])) {
   # - Related word found
               my ($ridx,$rcount)=split(/\:/,$_);
   # - Direct relation index
               my $directrel=$rcount/$thecount[$tindex];
               if ($directrel>$thethreshold) {
                  foreach (split(/\,/,$therelated[$ridx])) {
                     my ($rridx,$rrcount)=split(/\:/,$_);
                     if ($rridx==$tindex) {
   # - Determine reverse relation index
                        my $revrel=$rrcount/$thecount[$ridx];
   # - Calculate full index
                        $found{$ridx}=$directrel*$revrel;
                        if ($found{$ridx}>$thethreshold) {
                           foreach (split(/\,/,$therelated[$ridx])) {
                               my ($rrridx,$rrrcount)=split(/\:/,$_);
                               unless ($found{$rrridx}) {
                                  my $revrevrel=$rrrcount/$thecount[$ridx];
                                  if (
                             $directrel*$revrel*$revrevrel>$thethreshold
                                  ) {
                                     $found{$rrridx}=
                                          $directrel*$revrel*$revrevrel;
                                  }
                               }
                           }
                        }
                     }
                  }
               }
           }
       }
       return ();
 }  }
   
 # ---------------------------------------------------------------- Language IDs  # ---------------------------------------------------------------- Language IDs
Line 173  sub get_previous_attempt { Line 786  sub get_previous_attempt {
       }        }
       $prevattempts='<table border=2></tr><th>History</th>';        $prevattempts='<table border=2></tr><th>History</th>';
       foreach (sort(keys %lasthash)) {        foreach (sort(keys %lasthash)) {
         $prevattempts.='<th>'.$_.'</th>';   my ($ign,@parts) = split(/\./,$_);
    if ($#parts > 0) {
     my $data=$parts[-1];
     pop(@parts);
     $prevattempts.='<th>Part '.join('.',@parts).'<br />'.$data.'</th>';
    } else {
     if ($#parts == 0) {
       $prevattempts.='<th>'.$parts[0].'</th>';
     } else {
       $prevattempts.='<th>'.$ign.'</th>';
     }
    }
       }        }
       for ($version=1;$version<=$returnhash{'version'};$version++) {        for ($version=1;$version<=$returnhash{'version'};$version++) {
         $prevattempts.='</tr><tr><th>Attempt '.$version.'</th>';          $prevattempts.='</tr><tr><th>Attempt '.$version.'</th>';
Line 247  sub get_student_answers { Line 871  sub get_student_answers {
   foreach my $element (@elements) {    foreach my $element (@elements) {
     $ENV{'form.grade_'.$element}=$old{$element};      $ENV{'form.grade_'.$element}=$old{$element};
   }    }
   $userview=~s/\<body[^\>]*\>//gi;  
   $userview=~s/\<\/body\>//gi;  
   $userview=~s/\<html\>//gi;  
   $userview=~s/\<\/html\>//gi;  
   $userview=~s/\<head\>//gi;  
   $userview=~s/\<\/head\>//gi;  
   $userview=~s/action\s*\=/would_be_action\=/gi;  
   return $userview;    return $userview;
 }  }
   
   ###############################################
   
   ###############################################
   
 sub get_unprocessed_cgi {  sub get_unprocessed_cgi {
   my ($query)= @_;    my ($query,$possible_names)= @_;
     # $Apache::lonxml::debug=1;
   foreach (split(/&/,$query)) {    foreach (split(/&/,$query)) {
     my ($name, $value) = split(/=/,$_);      my ($name, $value) = split(/=/,$_);
     $value =~ tr/+/ /;      $name = &Apache::lonnet::unescape($name);
     $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;      if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) {
     if (!defined($ENV{'form.'.$name})) { $ENV{'form.'.$name}=$value; }        $value =~ tr/+/ /;
         $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
         &Apache::lonxml::debug("Seting :$name: to :$value:");
         unless (defined($ENV{'form.'.$name})) { &add_to_env('form.'.$name,$value) };
       }
   }    }
 }  }
   
 sub cacheheader {  sub cacheheader {
     unless ($ENV{'request.method'} eq 'GET') { return ''; }
   my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);    my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
   my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" />    my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" />
                 <meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" />                  <meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" />
Line 277  sub cacheheader { Line 904  sub cacheheader {
   
 sub no_cache {  sub no_cache {
   my ($r) = @_;    my ($r) = @_;
   my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);    unless ($ENV{'request.method'} eq 'GET') { return ''; }
     #my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
   $r->no_cache(1);    $r->no_cache(1);
   $r->header_out("Pragma" => "no-cache");    $r->header_out("Pragma" => "no-cache");
   $r->header_out("Expires" => $date);    #$r->header_out("Expires" => $date);
 }  }
 1;  
 __END__;  
   
   sub add_to_env {
     my ($name,$value)=@_;
     if (defined($ENV{$name})) {
       if (ref($ENV{$name})) {
         #already have multiple values
         push(@{ $ENV{$name} },$value);
       } else {
         #first time seeing multiple values, convert hash entry to an arrayref
         my $first=$ENV{$name};
         undef($ENV{$name});
         push(@{ $ENV{$name} },$first,$value);
       }
     } else {
       $ENV{$name}=$value;
     }
   }
   
 =head1 NAME  =pod
   
 Apache::loncommon - pile of common routines  =back
   
 =head1 SYNOPSIS  =head2 CSV Upload/Handling functions
   
 Referenced by other mod_perl Apache modules.  =over 4
   
 Invocation:  =item  upfile_store($r)
  &Apache::loncommon::SUBROUTINENAME(ARGUMENTS);  
   
 =head1 INTRODUCTION  Store uploaded file, $r should be the HTTP Request object,
   needs $ENV{'form.upfile'}
   returns $datatoken to be put into hidden field
   
   =cut
   
   sub upfile_store {
       my $r=shift;
       $ENV{'form.upfile'}=~s/\r/\n/gs;
       $ENV{'form.upfile'}=~s/\f/\n/gs;
       $ENV{'form.upfile'}=~s/\n+/\n/gs;
       $ENV{'form.upfile'}=~s/\n+$//gs;
   
 Common collection of used subroutines.  This collection helps remove      my $datatoken=$ENV{'user.name'}.'_'.$ENV{'user.domain'}.
 redundancy from other modules and increase efficiency of memory usage.   '_enroll_'.$ENV{'request.course.id'}.'_'.time.'_'.$$;
       {
    my $fh=Apache::File->new('>'.$r->dir_config('lonDaemons').
    '/tmp/'.$datatoken.'.tmp');
    print $fh $ENV{'form.upfile'};
       }
       return $datatoken;
   }
   
 Current things done:  =item load_tmp_file($r)
   
  Makes a table out of the previous homework attempts  Load uploaded file from tmp, $r should be the HTTP Request object,
  Inputs result_from_symbread, user, domain, course_id  needs $ENV{'form.datatoken'},
  Reads in non-network-related .tab files  sets $ENV{'form.upfile'} to the contents of the file
   
 This is part of the LearningOnline Network with CAPA project  =cut
 described at http://www.lon-capa.org.  
   sub load_tmp_file {
       my $r=shift;
       my @studentdata=();
       {
    my $fh;
    if ($fh=Apache::File->new($r->dir_config('lonDaemons').
     '/tmp/'.$ENV{'form.datatoken'}.'.tmp')) {
       @studentdata=<$fh>;
    }
       }
       $ENV{'form.upfile'}=join('',@studentdata);
   }
   
 =head1 HANDLER SUBROUTINE  =item upfile_record_sep()
   
 There is no handler subroutine.  Separate uploaded file into records
   returns array of records,
   needs $ENV{'form.upfile'} and $ENV{'form.upfiletype'}
   
 =head1 OTHER SUBROUTINES  =cut
   
 =over 4  sub upfile_record_sep {
       if ($ENV{'form.upfiletype'} eq 'xml') {
       } else {
    return split(/\n/,$ENV{'form.upfile'});
       }
   }
   
 =item *  =item record_sep($record)
   
 BEGIN() : initialize values from language.tab, copyright.tab, filetypes.tab,  Separate a record into fields $record should be an item from the upfile_record_sep(), needs $ENV{'form.upfiletype'}
 and filecategories.tab.  
   
 =item *  =cut
   
   sub record_sep {
       my $record=shift;
       my %components=();
       if ($ENV{'form.upfiletype'} eq 'xml') {
       } elsif ($ENV{'form.upfiletype'} eq 'space') {
           my $i=0;
           foreach (split(/\s+/,$record)) {
               my $field=$_;
               $field=~s/^(\"|\')//;
               $field=~s/(\"|\')$//;
               $components{$i}=$field;
               $i++;
           }
       } elsif ($ENV{'form.upfiletype'} eq 'tab') {
           my $i=0;
           foreach (split(/\t+/,$record)) {
               my $field=$_;
               $field=~s/^(\"|\')//;
               $field=~s/(\"|\')$//;
               $components{$i}=$field;
               $i++;
           }
       } else {
           my @allfields=split(/\,/,$record);
           my $i=0;
           my $j;
           for ($j=0;$j<=$#allfields;$j++) {
               my $field=$allfields[$j];
               if ($field=~/^\s*(\"|\')/) {
    my $delimiter=$1;
                   while (($field!~/$delimiter$/) && ($j<$#allfields)) {
       $j++;
       $field.=','.$allfields[$j];
    }
                   $field=~s/^\s*$delimiter//;
                   $field=~s/$delimiter\s*$//;
               }
               $components{$i}=$field;
       $i++;
           }
       }
       return %components;
   }
   
 languageids() : returns list of all language ids  =item upfile_select_html()
   
 =item *  return HTML code to select file and specify its type
   
 languagedescription() : returns description of a specified language id  =cut
   
 =item *  sub upfile_select_html {
       return (<<'ENDUPFORM');
   <input type="file" name="upfile" size="50">
   <br />Type: <select name="upfiletype">
   <option value="csv">CSV (comma separated values, spreadsheet)</option>
   <option value="space">Space separated</option>
   <option value="tab">Tabulator separated</option>
   <option value="xml">HTML/XML</option>
   </select>
   ENDUPFORM
   }
   
 copyrightids() : returns list of all copyrights  =item csv_print_samples($r,$records)
   
 =item *  Prints a table of sample values from each column uploaded $r is an
   Apache Request ref, $records is an arrayref from
   &Apache::loncommon::upfile_record_sep
   
   =cut
   
   sub csv_print_samples {
       my ($r,$records) = @_;
       my (%sone,%stwo,%sthree);
       %sone=&record_sep($$records[0]);
       if (defined($$records[1])) {%stwo=&record_sep($$records[1]);}
       if (defined($$records[2])) {%sthree=&record_sep($$records[2]);}
   
       $r->print('Samples<br /><table border="2"><tr>');
       foreach (sort({$a <=> $b} keys(%sone))) { $r->print('<th>Column&nbsp;'.($_+1).'</th>'); }
       $r->print('</tr>');
       foreach my $hash (\%sone,\%stwo,\%sthree) {
    $r->print('<tr>');
    foreach (sort({$a <=> $b} keys(%sone))) {
       $r->print('<td>');
       if (defined($$hash{$_})) { $r->print($$hash{$_}); }
       $r->print('</td>');
    }
    $r->print('</tr>');
       }
       $r->print('</tr></table><br />'."\n");
   }
   
 copyrightdescription() : returns description of a specified copyright id  =item csv_print_select_table($r,$records,$d)
   
 =item *  Prints a table to create associations between values and table columns.
   $r is an Apache Request ref,
   $records is an arrayref from &Apache::loncommon::upfile_record_sep,
   $d is an array of 2 element arrays (internal name, displayed name)
   
   =cut
   
   sub csv_print_select_table {
       my ($r,$records,$d) = @_;
       my $i=0;my %sone;
       %sone=&record_sep($$records[0]);
       $r->print('Associate columns with student attributes.'."\n".
        '<table border="2"><tr><th>Attribute</th><th>Column</th></tr>'."\n");
       foreach (@$d) {
    my ($value,$display)=@{ $_ };
    $r->print('<tr><td>'.$display.'</td>');
   
    $r->print('<td><select name=f'.$i.
     ' onchange="javascript:flip(this.form,'.$i.');">');
    $r->print('<option value="none"></option>');
    foreach (sort({$a <=> $b} keys(%sone))) {
       $r->print('<option value="'.$_.'">Column '.($_+1).'</option>');
    }
    $r->print('</select></td></tr>'."\n");
    $i++;
       }
       $i--;
       return $i;
   }
   
 filecategories() : returns list of all file categories  =item csv_samples_select_table($r,$records,$d)
   
 =item *  Prints a table of sample values from the upload and can make associate samples to internal names.
   
 filecategorytypes() : returns list of file types belonging to a given file  $r is an Apache Request ref,
   $records is an arrayref from &Apache::loncommon::upfile_record_sep,
   $d is an array of 2 element arrays (internal name, displayed name)
   
   =cut
   
   sub csv_samples_select_table {
       my ($r,$records,$d) = @_;
       my %sone; my %stwo; my %sthree;
       my $i=0;
   
       $r->print('<table border=2><tr><th>Field</th><th>Samples</th></tr>');
       %sone=&record_sep($$records[0]);
       if (defined($$records[1])) {%stwo=&record_sep($$records[1]);}
       if (defined($$records[2])) {%sthree=&record_sep($$records[2]);}
   
       foreach (sort keys %sone) {
    $r->print('<tr><td><select name=f'.$i.
     ' onchange="javascript:flip(this.form,'.$i.');">');
    foreach (@$d) {
       my ($value,$display)=@{ $_ };
       $r->print('<option value='.$value.'>'.$display.'</option>');
    }
    $r->print('</select></td><td>');
    if (defined($sone{$_})) { $r->print($sone{$_}."</br>\n"); }
    if (defined($stwo{$_})) { $r->print($stwo{$_}."</br>\n"); }
    if (defined($sthree{$_})) { $r->print($sthree{$_}."</br>\n"); }
    $r->print('</td></tr>');
    $i++;
       }
       $i--;
       return($i);
   }
   1;
   __END__;
   
   =pod
   
   =back
   
   =head2 Access .tab File Data
   
   =over 4
   
   =item languageids() 
   
   returns list of all language ids
   
   =item languagedescription() 
   
   returns description of a specified language id
   
   =item copyrightids() 
   
   returns list of all copyrights
   
   =item copyrightdescription() 
   
   returns description of a specified copyright id
   
   =item filecategories() 
   
   returns list of all file categories
   
   =item filecategorytypes() 
   
   returns list of file types belonging to a given file
 category  category
   
 =item *  =item fileembstyle() 
   
 fileembstyle() : returns embedding style for a specified file type  returns embedding style for a specified file type
   
 =item *  =item filedescription() 
   
 filedescription() : returns description for a specified file type  returns description for a specified file type
   
 =item *  =item filedescriptionex() 
   
 filedescriptionex() : returns description for a specified file type with  returns description for a specified file type with
 extra formatting  extra formatting
   
 =item *  =back
   
   =head2 Alternate Problem Views
   
   =over 4
   
   =item get_previous_attempt() 
   
   return string with previous attempt on problem
   
 get_previous_attempt() : return string with previous attempt on problem  =item get_student_view() 
   
 =item *  show a snapshot of what student was looking at
   
   =item get_student_answers() 
   
   show a snapshot of how student was answering problem
   
   =back
   
   =head2 HTTP Helper
   
   =over 4
   
 get_student_view() : show a snapshot of what student was looking at  =item get_unprocessed_cgi($query,$possible_names)
   
 =item *  Modify the %ENV hash to contain unprocessed CGI form parameters held in
   $query.  The parameters listed in $possible_names (an array reference),
   will be set in $ENV{'form.name'} if they do not already exist.
   
 get_student_answers() : show a snapshot of how student was answering problem  Typically called with $ENV{'QUERY_STRING'} as the first parameter.  
   $possible_names is an ref to an array of form element names.  As an example:
   get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']);
   will result in $ENV{'form.uname'} and $ENV{'form.udom'} being set.
   
 =item *  =item cacheheader() 
   
 get_unprocessed_cgi() : get unparsed CGI parameters  returns cache-controlling header code
   
 =item *  =item nocache() 
   
 cacheheader() : returns cache-controlling header code  specifies header code to not have cache
   
 =item *  =item add_to_env($name,$value) 
   
 nocache() : specifies header code to not have cache  adds $name to the %ENV hash with value
   $value, if $name already exists, the entry is converted to an array
   reference and $value is added to the array.
   
 =back  =back
   
Removed from v.1.19  
changed lines
  Added in v.1.38

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