File:
[LON-CAPA] /
loncom /
interface /
loncommon.pm
Revision
1.25:
download - view:
text,
annotated -
select for diffs
Tue Feb 26 20:59:28 2002 UTC (23 years, 2 months ago) by
albertel
Branches:
MAIN
CVS tags:
HEAD
- add_to_env() added, adds a $value to $name entry in %ENV, makes it an array if it already existed
- get_unprocessed_cgi now accepts a arrayref of names that are allowed to be set in %ENV, preventing external abuse
# The LearningOnline Network with CAPA
# a pile of common routines
#
# $Id: loncommon.pm,v 1.25 2002/02/26 20:59:28 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
# This file is part of the LearningOnline Network with CAPA (LON-CAPA).
#
# LON-CAPA is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# LON-CAPA is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with LON-CAPA; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
#
# /home/httpd/html/adm/gpl.txt
#
# http://www.lon-capa.org/
#
# YEAR=2001
# 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
# Reads in non-network-related .tab files
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'}.
'/language.tab');
if ($fh) {
while (<$fh>) {
next if /^\#/;
chomp;
my ($key,$val)=(split(/\s+/,$_,2));
$language{$key}=$val;
}
}
}
# ------------------------------------------------------------------ copyrights
{
my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonIncludes'}.
'/copyright.tab');
if ($fh) {
while (<$fh>) {
next if /^\#/;
chomp;
my ($key,$val)=(split(/\s+/,$_,2));
$cprtag{$key}=$val;
}
}
}
# ------------------------------------------------------------- file categories
{
my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
'/filecategories.tab');
if ($fh) {
while (<$fh>) {
next if /^\#/;
chomp;
my ($key,$val)=(split(/\s+/,$_,2));
push @{$fc{$key}},$val;
}
}
}
# ------------------------------------------------------------------ file types
{
my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
'/filetypes.tab');
if ($fh) {
while (<$fh>) {
next if (/^\#/);
chomp;
my ($ending,$emb,$descr)=split(/\s+/,$_,3);
if ($descr ne '') {
$fe{$ending}=lc($emb);
$fd{$ending}=$descr;
}
}
}
}
# -------------------------------------------------------------- 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
sub languageids {
return sort(keys(%language));
}
# -------------------------------------------------------- Language Description
sub languagedescription {
return $language{shift(@_)};
}
# --------------------------------------------------------------- Copyright IDs
sub copyrightids {
return sort(keys(%cprtag));
}
# ------------------------------------------------------- Copyright Description
sub copyrightdescription {
return $cprtag{shift(@_)};
}
# ------------------------------------------------------------- File Categories
sub filecategories {
return sort(keys(%fc));
}
# -------------------------------------- File Types within a specified category
sub filecategorytypes {
return @{$fc{lc(shift(@_))}};
}
# ------------------------------------------------------------------ File Types
sub fileextensions {
return sort(keys(%fe));
}
# ------------------------------------------------------------- Embedding Style
sub fileembstyle {
return $fe{lc(shift(@_))};
}
# ------------------------------------------------------------ Description Text
sub filedescription {
return $fd{lc(shift(@_))};
}
# ------------------------------------------------------------ Description Text
sub filedescriptionex {
my $ex=shift;
return '.'.$ex.' '.$fd{lc($ex)};
}
sub get_previous_attempt {
my ($symb,$username,$domain,$course)=@_;
my $prevattempts='';
if ($symb) {
my (%returnhash)=
&Apache::lonnet::restore($symb,$course,$domain,$username);
if ($returnhash{'version'}) {
my %lasthash=();
my $version;
for ($version=1;$version<=$returnhash{'version'};$version++) {
foreach (sort(split(/\:/,$returnhash{$version.':keys'}))) {
$lasthash{$_}=$returnhash{$version.':'.$_};
}
}
$prevattempts='<table border=2></tr><th>History</th>';
foreach (sort(keys %lasthash)) {
$prevattempts.='<th>'.$_.'</th>';
}
for ($version=1;$version<=$returnhash{'version'};$version++) {
$prevattempts.='</tr><tr><th>Attempt '.$version.'</th>';
foreach (sort(keys %lasthash)) {
my $value;
if ($_ =~ /timestamp/) {
$value=scalar(localtime($returnhash{$version.':'.$_}));
} else {
$value=$returnhash{$version.':'.$_};
}
$prevattempts.='<td>'.$value.'</td>';
}
}
$prevattempts.='</tr><tr><th>Current</th>';
foreach (sort(keys %lasthash)) {
my $value;
if ($_ =~ /timestamp/) {
$value=scalar(localtime($lasthash{$_}));
} else {
$value=$lasthash{$_};
}
$prevattempts.='<td>'.$value.'</td>';
}
$prevattempts.='</tr></table>';
} else {
$prevattempts='Nothing submitted - no attempts.';
}
} else {
$prevattempts='No data.';
}
}
sub get_student_view {
my ($symb,$username,$domain,$courseid) = @_;
my ($map,$id,$feedurl) = split(/___/,$symb);
my (%old,%moreenv);
my @elements=('symb','courseid','domain','username');
foreach my $element (@elements) {
$old{$element}=$ENV{'form.grade_'.$element};
$moreenv{'form.grade_'.$element}=eval '$'.$element #'
}
&Apache::lonnet::appenv(%moreenv);
my $userview=&Apache::lonnet::ssi('/res/'.$feedurl);
&Apache::lonnet::delenv('form.grade_');
foreach my $element (@elements) {
$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;
}
sub get_student_answers {
my ($symb,$username,$domain,$courseid) = @_;
my ($map,$id,$feedurl) = split(/___/,$symb);
my (%old,%moreenv);
my @elements=('symb','courseid','domain','username');
foreach my $element (@elements) {
$old{$element}=$ENV{'form.grade_'.$element};
$moreenv{'form.grade_'.$element}=eval '$'.$element #'
}
$moreenv{'form.grade_target'}='answer';
&Apache::lonnet::appenv(%moreenv);
my $userview=&Apache::lonnet::ssi('/res/'.$feedurl);
&Apache::lonnet::delenv('form.grade_');
foreach my $element (@elements) {
$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;
}
sub get_unprocessed_cgi {
my ($query,$possible_names)= @_;
$Apache::lonxml::debug=1;
foreach (split(/&/,$query)) {
my ($name, $value) = split(/=/,$_);
$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:");
&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" />
<meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />';
return $output;
}
sub no_cache {
my ($r) = @_;
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);
}
sub add_to_env {
my ($name,$value)=@_;
if ($ENV{$name}) {
if (defined(@{ $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__;
=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.
=head1 HANDLER SUBROUTINE
There is no handler subroutine.
=head1 OTHER SUBROUTINES
=over 4
=item *
BEGIN() : initialize values from language.tab, copyright.tab, filetypes.tab,
and filecategories.tab.
=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
=item *
fileembstyle() : returns embedding style for a specified file type
=item *
filedescription() : returns description for a specified file type
=item *
filedescriptionex() : returns description for a specified file type with
extra formatting
=item *
get_previous_attempt() : return string with previous attempt on problem
=item *
get_student_view() : show a snapshot of what student was looking at
=item *
get_student_answers() : show a snapshot of how student was answering problem
=item *
get_unprocessed_cgi() : get unparsed CGI parameters
=item *
cacheheader() : returns cache-controlling header code
=item *
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
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to loncommon.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / interface