--- loncom/interface/loncommon.pm 2001/12/21 17:06:56 1.19 +++ 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.19 2001/12/21 17:06:56 harris41 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 @@ -173,7 +456,14 @@ sub get_previous_attempt { } $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
FieldSamples
'); + if (defined($sone{$_})) { $r->print($sone{$_}."
\n"); } + if (defined($stwo{$_})) { $r->print($stwo{$_}."
\n"); } + if (defined($sthree{$_})) { $r->print($sthree{$_}."
\n"); } + $r->print('