--- loncom/lonnet/perl/lonnet.pm 2006/09/28 18:23:32 1.782.2.2
+++ loncom/lonnet/perl/lonnet.pm 2006/10/20 00:34:45 1.798
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.782.2.2 2006/09/28 18:23:32 albertel Exp $
+# $Id: lonnet.pm,v 1.798 2006/10/20 00:34:45 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -52,6 +52,7 @@ use Storable qw(lock_store lock_nstore l
use Time::HiRes qw( gettimeofday tv_interval );
use Cache::Memcached;
use Digest::MD5;
+use Math::Random;
use lib '/home/httpd/lib/perl';
use LONCAPA;
use LONCAPA::Configuration;
@@ -292,12 +293,40 @@ sub error {
return undef;
}
+sub convert_and_load_session_env {
+ my ($lonidsdir,$handle)=@_;
+ my @profile;
+ {
+ open(my $idf,"$lonidsdir/$handle.id");
+ flock($idf,LOCK_SH);
+ @profile=<$idf>;
+ close($idf);
+ }
+ my %temp_env;
+ foreach my $line (@profile) {
+ if ($line !~ m/=/) {
+ return 0;
+ }
+ chomp($line);
+ my ($envname,$envvalue)=split(/=/,$line,2);
+ $temp_env{&unescape($envname)} = &unescape($envvalue);
+ }
+ unlink("$lonidsdir/$handle.id");
+ if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_WRCREAT(),
+ 0640)) {
+ %disk_env = %temp_env;
+ @env{keys(%temp_env)} = @disk_env{keys(%temp_env)};
+ untie(%disk_env);
+ }
+ return 1;
+}
+
# ------------------------------------------- Transfer profile into environment
my $env_loaded;
sub transfer_profile_to_env {
- if ($env_loaded) { return; }
+ my ($lonidsdir,$handle,$force_transfer) = @_;
+ if (!$force_transfer && $env_loaded) { return; }
- my ($lonidsdir,$handle)=@_;
if (!defined($lonidsdir)) {
$lonidsdir = $perlvar{'lonIDsDir'};
}
@@ -305,30 +334,36 @@ sub transfer_profile_to_env {
($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| );
}
- my @profile;
+ my $convert;
{
- open(my $idf,"$lonidsdir/$handle.id");
+ open(my $idf,"$lonidsdir/$handle.id");
flock($idf,LOCK_SH);
- @profile=<$idf>;
- close($idf);
+ if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",
+ &GDBM_READER(),0640)) {
+ @env{keys(%disk_env)} = @disk_env{keys(%disk_env)};
+ untie(%disk_env);
+ } else {
+ $convert = 1;
+ }
}
- my $envi;
- my %Remove;
- for ($envi=0;$envi<=$#profile;$envi++) {
- chomp($profile[$envi]);
- my ($envname,$envvalue)=split(/=/,$profile[$envi],2);
- $envname=&unescape($envname);
- $envvalue=&unescape($envvalue);
- $env{$envname} = $envvalue;
+ if ($convert) {
+ if (!&convert_and_load_session_env($lonidsdir,$handle)) {
+ &logthis("Failed to load session, or convert session.");
+ }
+ }
+
+ my %remove;
+ while ( my $envname = each(%env) ) {
if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
if ($time < time-300) {
- $Remove{$key}++;
+ $remove{$key}++;
}
}
}
+
$env{'user.environment'} = "$lonidsdir/$handle.id";
$env_loaded=1;
- foreach my $expired_key (keys(%Remove)) {
+ foreach my $expired_key (keys(%remove)) {
&delenv($expired_key);
}
}
@@ -347,54 +382,13 @@ sub appenv {
$env{$key}=$newenv{$key};
}
}
- foreach my $key (keys(%newenv)) {
- my $value = &escape($newenv{$key});
- delete($newenv{$key});
- $newenv{&escape($key)}=$value;
- }
-
- my $lockfh;
- unless (open($lockfh,"$env{'user.environment'}")) {
- return 'error: '.$!;
- }
- unless (flock($lockfh,LOCK_EX)) {
- &logthis("<font color=\"blue\">WARNING: ".
- 'Could not obtain exclusive lock in appenv: '.$!);
- close($lockfh);
- return 'error: '.$!;
- }
-
- my @oldenv;
- {
- my $fh;
- unless (open($fh,"$env{'user.environment'}")) {
- return 'error: '.$!;
- }
- @oldenv=<$fh>;
- close($fh);
- }
- for (my $i=0; $i<=$#oldenv; $i++) {
- chomp($oldenv[$i]);
- if ($oldenv[$i] ne '') {
- my ($name,$value)=split(/=/,$oldenv[$i],2);
- unless (defined($newenv{$name})) {
- $newenv{$name}=$value;
- }
- }
- }
- {
- my $fh;
- unless (open($fh,">$env{'user.environment'}")) {
- return 'error';
- }
- my $newname;
- foreach $newname (keys %newenv) {
- print $fh $newname.'='.$newenv{$newname}."\n";
+ if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),
+ 0640)) {
+ while (my ($key,$value) = each(%newenv)) {
+ $disk_env{$key} = $value;
}
- close($fh);
+ untie(%disk_env);
}
-
- close($lockfh);
return 'ok';
}
# ----------------------------------------------------- Delete from Environment
@@ -406,47 +400,33 @@ sub delenv {
"Attempt to delete from environment ".$delthis);
return 'error';
}
- my @oldenv;
- {
- my $fh;
- unless (open($fh,"$env{'user.environment'}")) {
- return 'error';
- }
- unless (flock($fh,LOCK_SH)) {
- &logthis("<font color=\"blue\">WARNING: ".
- 'Could not obtain shared lock in delenv: '.$!);
- close($fh);
- return 'error: '.$!;
- }
- @oldenv=<$fh>;
- close($fh);
- }
- {
- my $fh;
- unless (open($fh,">$env{'user.environment'}")) {
- return 'error';
- }
- unless (flock($fh,LOCK_EX)) {
- &logthis("<font color=\"blue\">WARNING: ".
- 'Could not obtain exclusive lock in delenv: '.$!);
- close($fh);
- return 'error: '.$!;
- }
- foreach my $cur_key (@oldenv) {
- my $unescaped_cur_key = &unescape($cur_key);
- if ($unescaped_cur_key=~/^$delthis/) {
- my ($key) = split('=',$cur_key,2);
- $key = &unescape($key);
+ if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),
+ 0640)) {
+ foreach my $key (keys(%disk_env)) {
+ if ($key=~/^$delthis/) {
delete($env{$key});
- } else {
- print $fh $cur_key;
+ delete($disk_env{$key});
}
}
- close($fh);
+ untie(%disk_env);
}
return 'ok';
}
+sub get_env_multiple {
+ my ($name) = @_;
+ my @values;
+ if (defined($env{$name})) {
+ # exists is it an array
+ if (ref($env{$name})) {
+ @values=@{ $env{$name} };
+ } else {
+ $values[0]=$env{$name};
+ }
+ }
+ return(@values);
+}
+
# ------------------------------------------ Find out current server userload
# there is a copy in lond
sub userload {
@@ -1656,7 +1636,14 @@ sub removeuploadedurl {
sub removeuserfile {
my ($docuname,$docudom,$fname)=@_;
my $home=&homeserver($docuname,$docudom);
- return &reply("removeuserfile:$docudom/$docuname/$fname",$home);
+ my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home);
+ if ($result eq 'ok') {
+ if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {
+ my $metafile = $fname.'.meta';
+ my $metaresult = &removeuserfile($docuname,$docudom,$metafile);
+ }
+ }
+ return $result;
}
sub mkdiruserfile {
@@ -1668,8 +1655,17 @@ sub mkdiruserfile {
sub renameuserfile {
my ($docuname,$docudom,$old,$new)=@_;
my $home=&homeserver($docuname,$docudom);
- return &reply("renameuserfile:$docudom:$docuname:".&escape("$old").':'.
- &escape("$new"),$home);
+ my $result = &reply("renameuserfile:$docudom:$docuname:".
+ &escape("$old").':'.&escape("$new"),$home);
+ if ($result eq 'ok') {
+ if (($old !~ /\.meta$/) && (&is_portfolio_file($old))) {
+ my $oldmeta = $old.'.meta';
+ my $newmeta = $new.'.meta';
+ my $metaresult =
+ &renameuserfile($docuname,$docudom,$oldmeta,$newmeta);
+ }
+ }
+ return $result;
}
# ------------------------------------------------------------------------- Log
@@ -1988,7 +1984,7 @@ sub courseidput {
}
sub courseiddump {
- my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter)=@_;
+ my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_;
my %returnhash=();
unless ($domfilter) { $domfilter=''; }
foreach my $tryserver (keys %libserv) {
@@ -1997,7 +1993,7 @@ sub courseiddump {
foreach (
split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.
$sincefilter.':'.&escape($descfilter).':'.
- &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter),
+ &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter).':'.&escape($regexp_ok),
$tryserver))) {
my ($key,$value)=split(/\=/,$_);
if (($key) && ($value)) {
@@ -2070,7 +2066,7 @@ sub get_domain_roles {
sub get_first_access {
my ($type,$argsymb)=@_;
- my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();
+ my ($symb,$courseid,$udom,$uname)=&whichuser();
if ($argsymb) { $symb=$argsymb; }
my ($map,$id,$res)=&decode_symb($symb);
if ($type eq 'map') {
@@ -2084,7 +2080,7 @@ sub get_first_access {
sub set_first_access {
my ($type)=@_;
- my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();
+ my ($symb,$courseid,$udom,$uname)=&whichuser();
my ($map,$id,$res)=&decode_symb($symb);
if ($type eq 'map') {
$res=&symbread($map);
@@ -3464,6 +3460,15 @@ sub is_portfolio_url {
return scalar(&parse_portfolio_url($url));
}
+sub is_portfolio_file {
+ my ($file) = @_;
+ if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w+\/portfolio/)) {
+ return 1;
+ }
+ return;
+}
+
+
# ---------------------------------------------- Custom access rule evaluation
sub customaccess {
@@ -4226,13 +4231,14 @@ sub auto_photoupdate {
}
sub auto_instcode_format {
- my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_;
+ my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,
+ $cat_order) = @_;
my $courses = '';
my @homeservers;
if ($caller eq 'global') {
- foreach my $tryserver (keys %libserv) {
+ foreach my $tryserver (keys(%libserv)) {
if ($hostdom{$tryserver} eq $codedom) {
- if (!grep/^\Q$tryserver\E$/,@homeservers) {
+ if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
push(@homeservers,$tryserver);
}
}
@@ -4240,8 +4246,8 @@ sub auto_instcode_format {
} else {
push(@homeservers,&homeserver($caller,$codedom));
}
- foreach (keys %{$instcodes}) {
- $courses .= &escape($_).'='.&escape($$instcodes{$_}).'&';
+ foreach my $code (keys(%{$instcodes})) {
+ $courses .= &escape($code).'='.&escape($$instcodes{$code}).'&';
}
chop($courses);
my $ok_response = 0;
@@ -4251,7 +4257,7 @@ sub auto_instcode_format {
$response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server);
if ($response !~ /(con_lost|error|no_such_host|refused)/) {
my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) =
- split/:/,$response;
+ split/:/,$response;
%{$codes} = (%{$codes},&str2hash($codes_str));
push(@{$codetitles},&str2array($codetitles_str));
%{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str));
@@ -4266,6 +4272,40 @@ sub auto_instcode_format {
}
}
+sub auto_instcode_defaults {
+ my ($domain,$returnhash,$code_order) = @_;
+ my @homeservers;
+ foreach my $tryserver (keys(%libserv)) {
+ if ($hostdom{$tryserver} eq $domain) {
+ if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
+ push(@homeservers,$tryserver);
+ }
+ }
+ }
+ my $ok_response = 0;
+ my $response;
+ while (@homeservers > 0 && $ok_response == 0) {
+ my $server = shift(@homeservers);
+ $response=&reply('autoinstcodedefaults:'.$domain,$server);
+ if ($response !~ /(con_lost|error|no_such_host|refused)/) {
+ foreach my $pair (split(/\&/,$response)) {
+ my ($name,$value)=split(/\=/,$pair);
+ if ($name eq 'code_order') {
+ @{$code_order} = split(/\&/,&unescape($value));
+ } else {
+ $returnhash->{&unescape($name)}=&unescape($value);
+ }
+ }
+ }
+ $ok_response = 1;
+ }
+ if ($ok_response) {
+ return 'ok';
+ } else {
+ return $response;
+ }
+}
+
sub auto_validate_class_sec {
my ($cdom,$cnum,$owner,$inst_class) = @_;
my $homeserver = &homeserver($cnum,$cdom);
@@ -5011,8 +5051,13 @@ sub modify_access_controls {
for (my $i=0; $i<$numnew; $i++) {
my $newkey = $newitems[$i];
my $newid = &Apache::loncommon::get_cgi_id();
- $newkey =~ s/^(\d+)/$newid/;
- $translation{$1} = $newid;
+ if ($newkey =~ /^\d+:/) {
+ $newkey =~ s/^(\d+)/$newid/;
+ $translation{$1} = $newid;
+ } elsif ($newkey =~ /^\d+_\d+_\d+:/) {
+ $newkey =~ s/^(\d+_\d+_\d+)/$newid/;
+ $translation{$1} = $newid;
+ }
$new_values{$file_name."\0".$newkey} =
$$changes{'activate'}{$newitems[$i]};
$new_control{$newkey} = $now;
@@ -5312,13 +5357,8 @@ sub GetFileTimestamp {
sub stat_file {
my ($uri) = @_;
- $uri = &clutter($uri);
+ $uri = &clutter_with_no_wrapper($uri);
- # we want just the url part without the unneeded accessor url bits
- if ($uri =~ m-^/adm/-) {
- $uri=~s-^/adm/wrapper/-/-;
- $uri=~s-^/adm/coursedocs/showdoc/-/-;
- }
my ($udom,$uname,$file,$dir);
if ($uri =~ m-^/(uploaded|editupload)/-) {
($udom,$uname,$file) =
@@ -5550,8 +5590,7 @@ sub EXT {
$symbparm=&get_symb_from_alias($symbparm);
}
if (!($uname && $udom)) {
- (my $cursymb,$courseid,$udom,$uname,$publicuser)=
- &Apache::lonxml::whichuser($symbparm);
+ (my $cursymb,$courseid,$udom,$uname,$publicuser)= &whichuser($symbparm);
if (!$symbparm) { $symbparm=$cursymb; }
} else {
$courseid=$env{'request.course.id'};
@@ -6205,7 +6244,7 @@ sub gettitle {
sub get_slot {
my ($which,$cnum,$cdom)=@_;
if (!$cnum || !$cdom) {
- (undef,my $courseid)=&Apache::lonxml::whichuser();
+ (undef,my $courseid)=&whichuser();
$cdom=$env{'course.'.$courseid.'.domain'};
$cnum=$env{'course.'.$courseid.'.num'};
}
@@ -6254,9 +6293,6 @@ sub symblist {
sub symbverify {
my ($symb,$thisurl)=@_;
my $thisfn=$thisurl;
-# wrapper not part of symbs
- $thisfn=~s/^\/adm\/wrapper//;
- $thisfn=~s/^\/adm\/coursedocs\/showdoc\///;
$thisfn=&declutter($thisfn);
# direct jump to resource in page or to a sequence - will construct own symbs
if ($thisfn=~/\.(page|sequence)$/) { return 1; }
@@ -6539,7 +6575,7 @@ sub latest_rnd_algorithm_id {
sub get_rand_alg {
my ($courseid)=@_;
- if (!$courseid) { $courseid=(&Apache::lonxml::whichuser())[1]; }
+ if (!$courseid) { $courseid=(&whichuser())[1]; }
if ($courseid) {
return $env{"course.$courseid.rndseed"};
}
@@ -6565,7 +6601,7 @@ sub getCODE {
sub rndseed {
my ($symb,$courseid,$domain,$username)=@_;
- my ($wsymb,$wcourseid,$wdomain,$wusername)=&Apache::lonxml::whichuser();
+ my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();
if (!$symb) {
unless ($symb=$wsymb) { return time; }
}
@@ -6606,8 +6642,8 @@ sub rndseed_32bit {
my $domainseed=unpack("%32C*",$domain) << 7;
my $courseseed=unpack("%32C*",$courseid);
my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
- #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
- #&Apache::lonxml::debug("rndseed :$num:$symb");
+ #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
+ #&logthis("rndseed :$num:$symb");
if ($_64bit) { $num=(($num<<32)>>32); }
return $num;
}
@@ -6627,8 +6663,8 @@ sub rndseed_64bit {
my $num1=$symbchck+$symbseed+$namechck;
my $num2=$nameseed+$domainseed+$courseseed;
- #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
- #&Apache::lonxml::debug("rndseed :$num:$symb");
+ #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
+ #&logthis("rndseed :$num:$symb");
if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
return "$num1,$num2";
@@ -6651,8 +6687,8 @@ sub rndseed_64bit2 {
my $num1=$symbchck+$symbseed+$namechck;
my $num2=$nameseed+$domainseed+$courseseed;
- #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
- #&Apache::lonxml::debug("rndseed :$num:$symb");
+ #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
+ #&logthis("rndseed :$num:$symb");
return "$num1,$num2";
}
}
@@ -6673,8 +6709,8 @@ sub rndseed_64bit3 {
my $num1=$symbchck+$symbseed+$namechck;
my $num2=$nameseed+$domainseed+$courseseed;
- #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
- #&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit");
+ #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
+ #&logthis("rndseed :$num1:$num2:$_64bit");
if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
return "$num1:$num2";
@@ -6697,8 +6733,8 @@ sub rndseed_64bit4 {
my $num1=$symbchck+$symbseed+$namechck;
my $num2=$nameseed+$domainseed+$courseseed;
- #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
- #&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit");
+ #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
+ #&logthis("rndseed :$num1:$num2:$_64bit");
if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
return "$num1:$num2";
@@ -6722,8 +6758,8 @@ sub rndseed_CODE_64bit {
my $courseseed=unpack("%32S*",$courseid.' ');
my $num1=$symbseed+$CODEchck;
my $num2=$CODEseed+$courseseed+$symbchck;
- #&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
- #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");
+ #&logthis("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
+ #&logthis("rndseed :$num1:$num2:$symb");
if ($_64bit) { $num1=(($num1<<32)>>32); }
if ($_64bit) { $num2=(($num2<<32)>>32); }
return "$num1:$num2";
@@ -6741,8 +6777,8 @@ sub rndseed_CODE_64bit4 {
my $courseseed=unpack("%32S*",$courseid.' ');
my $num1=$symbseed+$CODEchck;
my $num2=$CODEseed+$courseseed+$symbchck;
- #&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
- #&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");
+ #&logthis("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
+ #&logthis("rndseed :$num1:$num2:$symb");
if ($_64bit) { $num1=(($num1<<32)>>32); }
if ($_64bit) { $num2=(($num2<<32)>>32); }
return "$num1:$num2";
@@ -6803,8 +6839,7 @@ sub ireceipt {
my $return =&recprefix($fucourseid).'-';
if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' ||
$env{'request.state'} eq 'construct') {
- &Apache::lonxml::debug("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname).
- " and ".($cpart%$cudom));
+ #&logthis("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname)." and ".($cpart%$cudom));
$return.= ($cunique%$cuname+
$cunique%$cudom+
@@ -6827,10 +6862,48 @@ sub ireceipt {
sub receipt {
my ($part)=@_;
- my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser();
+ my ($symb,$courseid,$domain,$name) = &whichuser();
return &ireceipt($name,$domain,$courseid,$symb,$part);
}
+sub whichuser {
+ my ($passedsymb)=@_;
+ my ($symb,$courseid,$domain,$name,$publicuser);
+ if (defined($env{'form.grade_symb'})) {
+ my ($tmp_courseid)=&get_env_multiple('form.grade_courseid');
+ my $allowed=&allowed('vgr',$tmp_courseid);
+ if (!$allowed &&
+ exists($env{'request.course.sec'}) &&
+ $env{'request.course.sec'} !~ /^\s*$/) {
+ $allowed=&allowed('vgr',$tmp_courseid.
+ '/'.$env{'request.course.sec'});
+ }
+ if ($allowed) {
+ ($symb)=&get_env_multiple('form.grade_symb');
+ $courseid=$tmp_courseid;
+ ($domain)=&get_env_multiple('form.grade_domain');
+ ($name)=&get_env_multiple('form.grade_username');
+ return ($symb,$courseid,$domain,$name,$publicuser);
+ }
+ }
+ if (!$passedsymb) {
+ $symb=&symbread();
+ } else {
+ $symb=$passedsymb;
+ }
+ $courseid=$env{'request.course.id'};
+ $domain=$env{'user.domain'};
+ $name=$env{'user.name'};
+ if ($name eq 'public' && $domain eq 'public') {
+ if (!defined($env{'form.username'})) {
+ $env{'form.username'}.=time.rand(10000000);
+ }
+ $name.=$env{'form.username'};
+ }
+ return ($symb,$courseid,$domain,$name,$publicuser);
+
+}
+
# ------------------------------------------------------------ Serves up a file
# returns either the contents of the file or
# -1 if the file doesn't exist
@@ -7093,6 +7166,15 @@ sub clutter {
return $thisfn;
}
+sub clutter_with_no_wrapper {
+ my $uri = &clutter(shift);
+ if ($uri =~ m-^/adm/-) {
+ $uri =~ s-^/adm/wrapper/-/-;
+ $uri =~ s-^/adm/coursedocs/showdoc/-/-;
+ }
+ return $uri;
+}
+
sub freeze_escape {
my ($value)=@_;
if (ref($value)) {
@@ -7292,7 +7374,9 @@ sub get_iphost {
}
-$memcache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']});
+$memcache=new Cache::Memcached({'servers' => ['127.0.0.1:11211'],
+ 'compress_threshold'=> 20_000,
+ });
$processmarker='_'.time.'_'.$perlvar{'lonHostID'};
$dumpcount=0;
@@ -7489,6 +7573,13 @@ B<delenv($regexp)>: removes all items fr
environment file that matches the regular expression in $regexp. The
values are also delted from the current processes %env.
+=item * get_env_multiple($name)
+
+gets $name from the %env hash, it seemlessly handles the cases where multiple
+values may be defined and end up as an array ref.
+
+returns an array of values
+
=back
=head2 User Information