Annotation of loncom/interface/loncommon.pm, revision 1.28

1.10      albertel    1: # The LearningOnline Network with CAPA
1.1       albertel    2: # a pile of common routines
1.10      albertel    3: #
1.28    ! albertel    4: # $Id: loncommon.pm,v 1.27 2002/03/21 20:24:21 albertel Exp $
1.10      albertel    5: #
                      6: # Copyright Michigan State University Board of Trustees
                      7: #
                      8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
                      9: #
                     10: # LON-CAPA is free software; you can redistribute it and/or modify
                     11: # it under the terms of the GNU General Public License as published by
                     12: # the Free Software Foundation; either version 2 of the License, or
                     13: # (at your option) any later version.
                     14: #
                     15: # LON-CAPA is distributed in the hope that it will be useful,
                     16: # but WITHOUT ANY WARRANTY; without even the implied warranty of
                     17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     18: # GNU General Public License for more details.
                     19: #
                     20: # You should have received a copy of the GNU General Public License
                     21: # along with LON-CAPA; if not, write to the Free Software
                     22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
                     23: #
                     24: # /home/httpd/html/adm/gpl.txt
                     25: #
                     26: # http://www.lon-capa.org/
                     27: #
1.12      harris41   28: # YEAR=2001
                     29: # 2/13-12/7 Guy Albertelli
1.17      harris41   30: # 12/11,12/12,12/17 Scott Harrison
1.18      www        31: # 12/21 Gerd Kortemeyer
1.20      www        32: # 12/21 Scott Harrison
1.22      www        33: # 12/25,12/28 Gerd Kortemeyer
1.23      www        34: # YEAR=2002
                     35: # 1/4 Gerd Kortemeyer
1.1       albertel   36: 
                     37: # Makes a table out of the previous attempts
1.2       albertel   38: # Inputs result_from_symbread, user, domain, course_id
1.16      harris41   39: # Reads in non-network-related .tab files
1.1       albertel   40: 
                     41: package Apache::loncommon;
                     42: 
                     43: use strict;
1.22      www        44: use Apache::lonnet();
1.8       albertel   45: use POSIX qw(strftime);
1.1       albertel   46: use Apache::Constants qw(:common);
                     47: use Apache::lonmsg();
1.12      harris41   48: 
1.22      www        49: my $readit;
                     50: 
1.20      www        51: # ----------------------------------------------- Filetypes/Languages/Copyright
1.12      harris41   52: my %language;
                     53: my %cprtag;
                     54: my %fe; my %fd;
1.15      harris41   55: my %fc;
1.12      harris41   56: 
1.20      www        57: # -------------------------------------------------------------- Thesaurus data
1.21      www        58: my @therelated;
                     59: my @theword;
                     60: my @thecount;
                     61: my %theindex;
                     62: my $thetotalcount;
1.20      www        63: my $thefuzzy=2;
                     64: my $thethreshold=0.1/$thefuzzy;
                     65: my $theavecount;
                     66: 
1.12      harris41   67: # ----------------------------------------------------------------------- BEGIN
1.18      www        68: BEGIN {
1.22      www        69: 
                     70:     unless ($readit) {
1.12      harris41   71: # ------------------------------------------------------------------- languages
                     72:     {
                     73: 	my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
                     74: 				 '/language.tab');
1.16      harris41   75: 	if ($fh) {
                     76: 	    while (<$fh>) {
                     77: 		next if /^\#/;
                     78: 		chomp;
                     79: 		my ($key,$val)=(split(/\s+/,$_,2));
                     80: 		$language{$key}=$val;
                     81: 	    }
1.12      harris41   82: 	}
                     83:     }
                     84: # ------------------------------------------------------------------ copyrights
                     85:     {
1.16      harris41   86: 	my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonIncludes'}.
                     87: 				  '/copyright.tab');
                     88: 	if ($fh) {
                     89: 	    while (<$fh>) {
                     90: 		next if /^\#/;
                     91: 		chomp;
                     92: 		my ($key,$val)=(split(/\s+/,$_,2));
                     93: 		$cprtag{$key}=$val;
                     94: 	    }
1.12      harris41   95: 	}
                     96:     }
1.15      harris41   97: # ------------------------------------------------------------- file categories
                     98:     {
                     99: 	my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
1.16      harris41  100: 				  '/filecategories.tab');
                    101: 	if ($fh) {
                    102: 	    while (<$fh>) {
                    103: 		next if /^\#/;
                    104: 		chomp;
                    105: 		my ($key,$val)=(split(/\s+/,$_,2));
                    106: 		push @{$fc{$key}},$val;
                    107: 	    }
1.15      harris41  108: 	}
                    109:     }
1.12      harris41  110: # ------------------------------------------------------------------ file types
                    111:     {
1.16      harris41  112: 	my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
                    113: 	       '/filetypes.tab');
                    114: 	if ($fh) {
                    115:             while (<$fh>) {
                    116: 		next if (/^\#/);
                    117: 		chomp;
                    118: 		my ($ending,$emb,$descr)=split(/\s+/,$_,3);
                    119: 		if ($descr ne '') { 
                    120: 		    $fe{$ending}=lc($emb);
                    121: 		    $fd{$ending}=$descr;
                    122: 		}
1.12      harris41  123: 	    }
                    124: 	}
                    125:     }
1.20      www       126: # -------------------------------------------------------------- Thesaurus data
                    127:     {
                    128: 	my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
                    129: 	       '/thesaurus.dat');
                    130: 	if ($fh) {
                    131:             while (<$fh>) {
                    132:                my ($tword,$tindex,$tcount,$trelated)=split(/\@/,$_);
                    133:                $theindex{$tword}=$tindex;
                    134:                $theword[$tindex]=$tword;
                    135:                $thecount[$tindex]=$tcount;
                    136:                $thetotalcount+=$tcount;
                    137:                $therelated[$tindex]=$trelated;
                    138: 	   }
                    139:         }
                    140:         $theavecount=$thetotalcount/$#thecount;
                    141:     }
1.22      www       142:     &Apache::lonnet::logthis(
                    143:               "<font color=yellow>INFO: Read file types and thesaurus</font>");
                    144:     $readit=1;
                    145: }
                    146: 
1.20      www       147: }
                    148: # ============================================================= END BEGIN BLOCK
                    149: 
                    150: 
                    151: # ---------------------------------------------------------- Is this a keyword?
                    152: 
                    153: sub keyword {
                    154:     my $newword=shift;
                    155:     $newword=~s/\W//g;
                    156:     $newword=~tr/A-Z/a-z/;
                    157:     my $tindex=$theindex{$newword};
                    158:     if ($tindex) {
                    159:         if ($thecount[$tindex]>$theavecount) {
                    160:            return 1;
                    161:         }
                    162:     }
                    163:     return 0;
                    164: }
                    165: # -------------------------------------------------------- Return related words
                    166: 
                    167: sub related {
                    168:     my $newword=shift;
                    169:     $newword=~s/\W//g;
                    170:     $newword=~tr/A-Z/a-z/;
                    171:     my $tindex=$theindex{$newword};
                    172:     if ($tindex) {
                    173:         my %found=();
                    174:         foreach (split(/\,/,$therelated[$tindex])) {
                    175: # - Related word found
                    176:             my ($ridx,$rcount)=split(/\:/,$_);
                    177: # - Direct relation index
                    178:             my $directrel=$rcount/$thecount[$tindex];
                    179:             if ($directrel>$thethreshold) {
                    180:                foreach (split(/\,/,$therelated[$ridx])) {
                    181:                   my ($rridx,$rrcount)=split(/\:/,$_);
                    182:                   if ($rridx==$tindex) {
                    183: # - Determine reverse relation index
                    184:                      my $revrel=$rrcount/$thecount[$ridx];
                    185: # - Calculate full index
                    186:                      $found{$ridx}=$directrel*$revrel;
                    187:                      if ($found{$ridx}>$thethreshold) {
                    188:                         foreach (split(/\,/,$therelated[$ridx])) {
                    189:                             my ($rrridx,$rrrcount)=split(/\:/,$_);
                    190:                             unless ($found{$rrridx}) {
                    191:                                my $revrevrel=$rrrcount/$thecount[$ridx];
                    192:                                if (
                    193:                           $directrel*$revrel*$revrevrel>$thethreshold
                    194:                                ) {
                    195:                                   $found{$rrridx}=
                    196:                                        $directrel*$revrel*$revrevrel;
                    197:                                }
                    198:                             }
                    199:                         }
                    200:                      }
                    201:                   }
                    202:                }
                    203:             }
                    204:         }
                    205:     }
                    206:     return ();
1.14      harris41  207: }
                    208: 
                    209: # ---------------------------------------------------------------- Language IDs
                    210: sub languageids {
1.16      harris41  211:     return sort(keys(%language));
1.14      harris41  212: }
                    213: 
                    214: # -------------------------------------------------------- Language Description
                    215: sub languagedescription {
1.16      harris41  216:     return $language{shift(@_)};
1.14      harris41  217: }
                    218: 
                    219: # --------------------------------------------------------------- Copyright IDs
                    220: sub copyrightids {
1.16      harris41  221:     return sort(keys(%cprtag));
1.14      harris41  222: }
                    223: 
                    224: # ------------------------------------------------------- Copyright Description
                    225: sub copyrightdescription {
1.16      harris41  226:     return $cprtag{shift(@_)};
1.14      harris41  227: }
                    228: 
                    229: # ------------------------------------------------------------- File Categories
                    230: sub filecategories {
1.16      harris41  231:     return sort(keys(%fc));
1.15      harris41  232: }
1.14      harris41  233: 
1.17      harris41  234: # -------------------------------------- File Types within a specified category
1.15      harris41  235: sub filecategorytypes {
1.16      harris41  236:     return @{$fc{lc(shift(@_))}};
1.14      harris41  237: }
                    238: 
                    239: # ------------------------------------------------------------------ File Types
                    240: sub fileextensions {
1.16      harris41  241:     return sort(keys(%fe));
1.14      harris41  242: }
                    243: 
                    244: # ------------------------------------------------------------- Embedding Style
                    245: sub fileembstyle {
1.16      harris41  246:     return $fe{lc(shift(@_))};
1.14      harris41  247: }
                    248: 
                    249: # ------------------------------------------------------------ Description Text
                    250: sub filedescription {
1.16      harris41  251:     return $fd{lc(shift(@_))};
                    252: }
                    253: 
                    254: # ------------------------------------------------------------ Description Text
                    255: sub filedescriptionex {
                    256:     my $ex=shift;
                    257:     return '.'.$ex.' '.$fd{lc($ex)};
1.12      harris41  258: }
1.1       albertel  259: 
                    260: sub get_previous_attempt {
1.2       albertel  261:   my ($symb,$username,$domain,$course)=@_;
1.1       albertel  262:   my $prevattempts='';
                    263:   if ($symb) {
1.3       albertel  264:     my (%returnhash)=
                    265:       &Apache::lonnet::restore($symb,$course,$domain,$username);
1.1       albertel  266:     if ($returnhash{'version'}) {
                    267:       my %lasthash=();
                    268:       my $version;
                    269:       for ($version=1;$version<=$returnhash{'version'};$version++) {
1.19      harris41  270:         foreach (sort(split(/\:/,$returnhash{$version.':keys'}))) {
1.1       albertel  271: 	  $lasthash{$_}=$returnhash{$version.':'.$_};
1.19      harris41  272:         }
1.1       albertel  273:       }
                    274:       $prevattempts='<table border=2></tr><th>History</th>';
1.16      harris41  275:       foreach (sort(keys %lasthash)) {
1.1       albertel  276:         $prevattempts.='<th>'.$_.'</th>';
1.16      harris41  277:       }
1.1       albertel  278:       for ($version=1;$version<=$returnhash{'version'};$version++) {
                    279:         $prevattempts.='</tr><tr><th>Attempt '.$version.'</th>';
1.16      harris41  280:         foreach (sort(keys %lasthash)) {
1.5       albertel  281: 	  my $value;
                    282: 	  if ($_ =~ /timestamp/) {
                    283: 	    $value=scalar(localtime($returnhash{$version.':'.$_}));
                    284: 	  } else {
                    285: 	    $value=$returnhash{$version.':'.$_};
                    286: 	  }
                    287: 	  $prevattempts.='<td>'.$value.'</td>';   
1.16      harris41  288:         }
1.1       albertel  289:       }
                    290:       $prevattempts.='</tr><tr><th>Current</th>';
1.16      harris41  291:       foreach (sort(keys %lasthash)) {
1.5       albertel  292: 	my $value;
                    293: 	if ($_ =~ /timestamp/) {
                    294: 	  $value=scalar(localtime($lasthash{$_}));
                    295: 	} else {
                    296: 	  $value=$lasthash{$_};
                    297: 	}
                    298: 	$prevattempts.='<td>'.$value.'</td>';
1.16      harris41  299:       }
1.1       albertel  300:       $prevattempts.='</tr></table>';
                    301:     } else {
                    302:       $prevattempts='Nothing submitted - no attempts.';
                    303:     }
                    304:   } else {
                    305:     $prevattempts='No data.';
                    306:   }
1.10      albertel  307: }
                    308: 
                    309: sub get_student_view {
                    310:   my ($symb,$username,$domain,$courseid) = @_;
                    311:   my ($map,$id,$feedurl) = split(/___/,$symb);
                    312:   my (%old,%moreenv);
                    313:   my @elements=('symb','courseid','domain','username');
                    314:   foreach my $element (@elements) {
                    315:     $old{$element}=$ENV{'form.grade_'.$element};
                    316:     $moreenv{'form.grade_'.$element}=eval '$'.$element #'
                    317:   }
1.11      albertel  318:   &Apache::lonnet::appenv(%moreenv);
                    319:   my $userview=&Apache::lonnet::ssi('/res/'.$feedurl);
                    320:   &Apache::lonnet::delenv('form.grade_');
                    321:   foreach my $element (@elements) {
                    322:     $ENV{'form.grade_'.$element}=$old{$element};
                    323:   }
                    324:   $userview=~s/\<body[^\>]*\>//gi;
                    325:   $userview=~s/\<\/body\>//gi;
                    326:   $userview=~s/\<html\>//gi;
                    327:   $userview=~s/\<\/html\>//gi;
                    328:   $userview=~s/\<head\>//gi;
                    329:   $userview=~s/\<\/head\>//gi;
                    330:   $userview=~s/action\s*\=/would_be_action\=/gi;
                    331:   return $userview;
                    332: }
                    333: 
                    334: sub get_student_answers {
                    335:   my ($symb,$username,$domain,$courseid) = @_;
                    336:   my ($map,$id,$feedurl) = split(/___/,$symb);
                    337:   my (%old,%moreenv);
                    338:   my @elements=('symb','courseid','domain','username');
                    339:   foreach my $element (@elements) {
                    340:     $old{$element}=$ENV{'form.grade_'.$element};
                    341:     $moreenv{'form.grade_'.$element}=eval '$'.$element #'
                    342:   }
                    343:   $moreenv{'form.grade_target'}='answer';
1.10      albertel  344:   &Apache::lonnet::appenv(%moreenv);
                    345:   my $userview=&Apache::lonnet::ssi('/res/'.$feedurl);
                    346:   &Apache::lonnet::delenv('form.grade_');
                    347:   foreach my $element (@elements) {
                    348:     $ENV{'form.grade_'.$element}=$old{$element};
                    349:   }
                    350:   $userview=~s/\<body[^\>]*\>//gi;
                    351:   $userview=~s/\<\/body\>//gi;
                    352:   $userview=~s/\<html\>//gi;
                    353:   $userview=~s/\<\/html\>//gi;
                    354:   $userview=~s/\<head\>//gi;
                    355:   $userview=~s/\<\/head\>//gi;
                    356:   $userview=~s/action\s*\=/would_be_action\=/gi;
                    357:   return $userview;
1.1       albertel  358: }
                    359: 
1.6       albertel  360: sub get_unprocessed_cgi {
1.25      albertel  361:   my ($query,$possible_names)= @_;
1.26      matthew   362:   # $Apache::lonxml::debug=1;
1.16      harris41  363:   foreach (split(/&/,$query)) {
1.6       albertel  364:     my ($name, $value) = split(/=/,$_);
1.25      albertel  365:     $name = &Apache::lonnet::unescape($name);
                    366:     if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) {
                    367:       $value =~ tr/+/ /;
                    368:       $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
                    369:       &Apache::lonxml::debug("Seting :$name: to :$value:");
                    370:       &add_to_env('form.'.$name,$value);
                    371:     }
1.16      harris41  372:   }
1.6       albertel  373: }
                    374: 
1.7       albertel  375: sub cacheheader {
1.23      www       376:   unless ($ENV{'request.method'} eq 'GET') { return ''; }
1.8       albertel  377:   my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
1.7       albertel  378:   my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" />
                    379:                 <meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" />
                    380:                 <meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />';
                    381:   return $output;
                    382: }
                    383: 
1.9       albertel  384: sub no_cache {
                    385:   my ($r) = @_;
1.23      www       386:   unless ($ENV{'request.method'} eq 'GET') { return ''; }
1.24      albertel  387:   #my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
1.9       albertel  388:   $r->no_cache(1);
                    389:   $r->header_out("Pragma" => "no-cache");
1.24      albertel  390:   #$r->header_out("Expires" => $date);
1.9       albertel  391: }
1.25      albertel  392: 
                    393: sub add_to_env {
                    394:   my ($name,$value)=@_;
1.28    ! albertel  395:   if (defined($ENV{$name})) {
1.27      albertel  396:     if (ref($ENV{$name})) {
1.25      albertel  397:       #already have multiple values
                    398:       push(@{ $ENV{$name} },$value);
                    399:     } else {
                    400:       #first time seeing multiple values, convert hash entry to an arrayref
                    401:       my $first=$ENV{$name};
                    402:       undef($ENV{$name});
                    403:       push(@{ $ENV{$name} },$first,$value);
                    404:     }
                    405:   } else {
                    406:     $ENV{$name}=$value;
                    407:   }
                    408: }
1.1       albertel  409: 1;
                    410: __END__;
1.17      harris41  411: 
                    412: 
                    413: =head1 NAME
                    414: 
                    415: Apache::loncommon - pile of common routines
                    416: 
                    417: =head1 SYNOPSIS
                    418: 
                    419: Referenced by other mod_perl Apache modules.
                    420: 
                    421: Invocation:
                    422:  &Apache::loncommon::SUBROUTINENAME(ARGUMENTS);
                    423: 
                    424: =head1 INTRODUCTION
                    425: 
                    426: Common collection of used subroutines.  This collection helps remove
                    427: redundancy from other modules and increase efficiency of memory usage.
                    428: 
                    429: Current things done:
                    430: 
                    431:  Makes a table out of the previous homework attempts
                    432:  Inputs result_from_symbread, user, domain, course_id
                    433:  Reads in non-network-related .tab files
                    434: 
                    435: This is part of the LearningOnline Network with CAPA project
                    436: described at http://www.lon-capa.org.
                    437: 
                    438: =head1 HANDLER SUBROUTINE
                    439: 
                    440: There is no handler subroutine.
                    441: 
                    442: =head1 OTHER SUBROUTINES
                    443: 
                    444: =over 4
                    445: 
                    446: =item *
                    447: 
                    448: BEGIN() : initialize values from language.tab, copyright.tab, filetypes.tab,
                    449: and filecategories.tab.
                    450: 
                    451: =item *
                    452: 
                    453: languageids() : returns list of all language ids
                    454: 
                    455: =item *
                    456: 
                    457: languagedescription() : returns description of a specified language id
                    458: 
                    459: =item *
                    460: 
                    461: copyrightids() : returns list of all copyrights
                    462: 
                    463: =item *
                    464: 
                    465: copyrightdescription() : returns description of a specified copyright id
                    466: 
                    467: =item *
                    468: 
                    469: filecategories() : returns list of all file categories
                    470: 
                    471: =item *
                    472: 
                    473: filecategorytypes() : returns list of file types belonging to a given file
                    474: category
                    475: 
                    476: =item *
                    477: 
                    478: fileembstyle() : returns embedding style for a specified file type
                    479: 
                    480: =item *
                    481: 
                    482: filedescription() : returns description for a specified file type
                    483: 
                    484: =item *
                    485: 
                    486: filedescriptionex() : returns description for a specified file type with
                    487: extra formatting
                    488: 
                    489: =item *
                    490: 
                    491: get_previous_attempt() : return string with previous attempt on problem
                    492: 
                    493: =item *
                    494: 
                    495: get_student_view() : show a snapshot of what student was looking at
                    496: 
                    497: =item *
                    498: 
                    499: get_student_answers() : show a snapshot of how student was answering problem
                    500: 
                    501: =item *
                    502: 
                    503: get_unprocessed_cgi() : get unparsed CGI parameters
                    504: 
                    505: =item *
                    506: 
                    507: cacheheader() : returns cache-controlling header code
                    508: 
                    509: =item *
                    510: 
                    511: nocache() : specifies header code to not have cache
1.25      albertel  512: 
                    513: =item *
                    514: 
                    515: add_to_env($name,$value) : adds $name to the %ENV hash with value
                    516: $value, if $name already exists, the entry is converted to an array
                    517: reference and $value is added to the array.
1.17      harris41  518: 
                    519: =back
                    520: 
                    521: =cut

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