--- loncom/lonnet/perl/lonnet.pm 2006/09/28 21:24:56 1.786 +++ loncom/lonnet/perl/lonnet.pm 2006/10/13 04:23:15 1.791 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.786 2006/09/28 21:24:56 albertel Exp $ +# $Id: lonnet.pm,v 1.791 2006/10/13 04:23:15 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; @@ -323,9 +324,9 @@ sub convert_and_load_session_env { # ------------------------------------------- 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'}; } @@ -412,6 +413,31 @@ sub delenv { return 'ok'; } +=pod + +=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 + +=cut + +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 { @@ -1184,15 +1210,6 @@ sub absolute_url { return $protocol.$host_name; } -sub absolute_url { - my ($host_name) = @_; - my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://'); - if ($host_name eq '') { - $host_name = $ENV{'SERVER_NAME'}; - } - return $protocol.$host_name; -} - sub ssi { my ($fn,%form)=@_; @@ -1962,7 +1979,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) { @@ -1971,7 +1988,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)) { @@ -2044,7 +2061,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') { @@ -2058,7 +2075,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); @@ -5286,13 +5303,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) = @@ -5524,8 +5536,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'}; @@ -6179,7 +6190,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'}; } @@ -6228,9 +6239,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; } @@ -6513,7 +6521,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"}; } @@ -6539,7 +6547,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; } } @@ -6580,8 +6588,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; } @@ -6601,8 +6609,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"; @@ -6625,8 +6633,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"; } } @@ -6647,8 +6655,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"; @@ -6671,8 +6679,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"; @@ -6696,8 +6704,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"; @@ -6715,8 +6723,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"; @@ -6777,8 +6785,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+ @@ -6801,10 +6808,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 @@ -7067,6 +7112,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)) {