--- loncom/lonnet/perl/lonnet.pm 2006/10/20 20:39:44 1.782.2.4 +++ loncom/lonnet/perl/lonnet.pm 2006/10/19 21:23:23 1.797 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.782.2.4 2006/10/20 20:39:44 albertel Exp $ +# $Id: lonnet.pm,v 1.797 2006/10/19 21:23:23 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,6 +293,34 @@ 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 { @@ -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; + } + } + if ($convert) { + if (!&convert_and_load_session_env($lonidsdir,$handle)) { + &logthis("Failed to load session, or convert session."); + } } - 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; + + 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("WARNING: ". - 'Could not obtain exclusive lock in appenv: '.$!); - close($lockfh); - return 'error: '.$!; - } - - my @oldenv; - { - my $fh; - unless (open($fh,"$env{'user.environment'}")) { - return 'error: '.$!; + if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(), + 0640)) { + while (my ($key,$value) = each(%newenv)) { + $disk_env{$key} = $value; } - @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; - } - } + untie(%disk_env); } - { - my $fh; - unless (open($fh,">$env{'user.environment'}")) { - return 'error'; - } - my $newname; - foreach $newname (keys %newenv) { - print $fh $newname.'='.$newenv{$newname}."\n"; - } - close($fh); - } - - 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("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("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 { @@ -1988,7 +1968,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 +1977,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 +2050,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 +2064,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); @@ -4226,13 +4206,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 +4221,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 +4232,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 +4247,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 +5026,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 +5332,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 +5565,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 +6219,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 +6268,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 +6550,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 +6576,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 +6617,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 +6638,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 +6662,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 +6684,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 +6708,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 +6733,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 +6752,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 +6814,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 +6837,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 +7141,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)) { @@ -7491,6 +7548,13 @@ B: 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