--- loncom/interface/loncommon.pm 2001/12/21 17:03:17 1.18 +++ loncom/interface/loncommon.pm 2002/04/22 15:26:46 1.32 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # a pile of common routines # -# $Id: loncommon.pm,v 1.18 2001/12/21 17:03:17 www Exp $ +# $Id: loncommon.pm,v 1.32 2002/04/22 15:26:46 matthew Exp $ # # Copyright Michigan State University Board of Trustees # @@ -29,6 +29,10 @@ # 2/13-12/7 Guy Albertelli # 12/11,12/12,12/17 Scott Harrison # 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 # Inputs result_from_symbread, user, domain, course_id @@ -37,18 +41,33 @@ package Apache::loncommon; use strict; +use Apache::lonnet(); use POSIX qw(strftime); use Apache::Constants qw(:common); use Apache::lonmsg(); +my $readit; +# ----------------------------------------------- Filetypes/Languages/Copyright my %language; my %cprtag; my %fe; my %fd; 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 { + + unless ($readit) { # ------------------------------------------------------------------- languages { my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. @@ -104,6 +123,270 @@ 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( + "INFO: Read file types and thesaurus"); + $readit=1; +} + +} +# ============================================================= END BEGIN BLOCK + +############################################################### +## 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
tag. +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"; +As a general rule, only authors or co-authors should be filesystem +authenticated (which allows access to the server filesystem). +END + return $result; +} + +sub authform_nochange{ + my %in = ( + formname => 'document.cu', + kerb_def_dom => 'MSU.EDU', + @_, + ); + my $result=''; + $result.=<<"END"; + +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"; + +Kerberos authenticated with domain + +END + return $result; +} + +sub authform_internal{ + my %args = ( + formname => 'document.cu', + kerb_def_dom => 'MSU.EDU', + @_, + ); + my $result=''; + $result.=<<"END"; + +Internally authenticated (with initial password + +END + return $result; +} + +sub authform_local{ + my %in = ( + formname => 'document.cu', + kerb_def_dom => 'MSU.EDU', + @_, + ); + my $result=''; + $result.=<<"END"; + +Local Authentication with argument + +END + return $result; +} + +sub authform_filesystem{ + my %in = ( + formname => 'document.cu', + kerb_def_dom => 'MSU.EDU', + @_, + ); + my $result=''; + $result.=<<"END"; + +Filesystem authenticated (with initial password + +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 @@ -167,13 +450,20 @@ sub get_previous_attempt { my %lasthash=(); my $version; for ($version=1;$version<=$returnhash{'version'};$version++) { - map { + foreach (sort(split(/\:/,$returnhash{$version.':keys'}))) { $lasthash{$_}=$returnhash{$version.':'.$_}; - } sort(split(/\:/,$returnhash{$version.':keys'})); + } } $prevattempts=''; foreach (sort(keys %lasthash)) { - $prevattempts.=''; + my ($ign,@parts) = split(/\./,$_); + if (@parts) { + my $data=$parts[-1]; + pop(@parts); + $prevattempts.=''; + } else { + $prevattempts.=''; + } } for ($version=1;$version<=$returnhash{'version'};$version++) { $prevattempts.=''; @@ -258,16 +548,22 @@ sub get_student_answers { } sub get_unprocessed_cgi { - my ($query)= @_; + my ($query,$possible_names)= @_; + # $Apache::lonxml::debug=1; foreach (split(/&/,$query)) { my ($name, $value) = split(/=/,$_); - $value =~ tr/+/ /; - $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; - if (!defined($ENV{'form.'.$name})) { $ENV{'form.'.$name}=$value; } + $name = &Apache::lonnet::unescape($name); + if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) { + $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 { + unless ($ENV{'request.method'} eq 'GET') { return ''; } my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime); my $output .=' @@ -277,10 +573,225 @@ sub cacheheader { sub no_cache { 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->header_out("Pragma" => "no-cache"); - $r->header_out("Expires" => $date); + #$r->header_out("Expires" => $date); +} + +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; + } +} + +#---CSV Upload/Handling functions + +# ========================================================= Store uploaded file +# needs $ENV{'form.upfile'} +# return $datatoken to be put into hidden field + +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; + + my $datatoken=$ENV{'user.name'}.'_'.$ENV{'user.domain'}. + '_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; +} + +# ================================================= Load uploaded file from tmp +# needs $ENV{'form.datatoken'} +# sets $ENV{'form.upfile'} to the contents of the file + +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); +} + +# ========================================= Separate uploaded file into records +# returns array of records +# needs $ENV{'form.upfile'} +# needs $ENV{'form.upfiletype'} + +sub upfile_record_sep { + if ($ENV{'form.upfiletype'} eq 'xml') { + } else { + return split(/\n/,$ENV{'form.upfile'}); + } +} + +# =============================================== Separate a record into fields +# needs $ENV{'form.upfiletype'} +# takes $record as arg +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; +} + +# =============================== HTML code to select file and specify its type +sub upfile_select_html { + return (<<'ENDUPFORM'); + +
Type: +ENDUPFORM +} + +# ===================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 +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
History'.$_.'Part '.join('.',@parts).'
'.$data.'		'.$ign.'
Attempt '.$version.'
'); + foreach (sort({$a <=> $b} keys(%sone))) { $r->print(''); } + $r->print(''); + foreach my $hash (\%sone,\%stwo,\%sthree) { + $r->print(''); + foreach (sort({$a <=> $b} keys(%sone))) { + $r->print(''); + } + $r->print(''); + } + $r->print('
Column '.($_+1).'
'); + if (defined($$hash{$_})) { $r->print($$hash{$_}); } + $r->print('

'."\n"); +} + +# ======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) +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". + ''."\n"); + foreach (@$d) { + my ($value,$display)=@{ $_ }; + $r->print(''); + + $r->print(''."\n"); + $i++; + } + $i--; + return $i; +} + +# ===================Prints a table of sample values from the upload and +# can make associate samples to internal names +# $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) +sub csv_samples_select_table { + my ($r,$records,$d) = @_; + my %sone; my %stwo; my %sthree; + my $i=0; + + $r->print('
AttributeColumn
'.$display.'
'); + %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(''); + $i++; + } + $i--; + return($i); } 1; __END__; @@ -386,6 +897,12 @@ cacheheader() : returns cache-controllin nocache() : specifies header code to not have cache +=item * + +add_to_env($name,$value) : 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 =cut 500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.

FieldSamples
'); + if (defined($sone{$_})) { $r->print($sone{$_}."
\n"); } + if (defined($stwo{$_})) { $r->print($stwo{$_}."
\n"); } + if (defined($sthree{$_})) { $r->print($sthree{$_}."
\n"); } + $r->print('