--- loncom/interface/loncommon.pm 2001/12/21 17:06:56 1.19
+++ loncom/interface/loncommon.pm 2002/03/28 21:38:53 1.29
@@ -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.29 2002/03/28 21:38:53 www 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,87 @@ 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
+
+
+# ---------------------------------------------------------- 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
@@ -258,16 +358,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 ($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 .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" />
<meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" />
@@ -277,10 +383,28 @@ 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;
+ }
}
1;
__END__;
@@ -386,6 +510,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