--- loncom/lonnet/perl/lonnet.pm 2006/06/07 18:41:57 1.745 +++ loncom/lonnet/perl/lonnet.pm 2006/12/28 19:59:48 1.816 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.745 2006/06/07 18:41:57 raeburn Exp $ +# $Id: lonnet.pm,v 1.816 2006/12/28 19:59:48 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -52,8 +52,8 @@ use Storable qw(lock_store lock_nstore l use Time::HiRes qw( gettimeofday tv_interval ); use Cache::Memcached; use Digest::MD5; -use lib '/home/httpd/lib/perl'; -use LONCAPA; +use Math::Random; +use LONCAPA qw(:DEFAULT :match); use LONCAPA::Configuration; my $readit; @@ -281,10 +281,51 @@ sub critical { return $answer; } -# ------------------------------------------- Transfer profile into environment +# ------------------------------------------- check if return value is an error -sub transfer_profile_to_env { +sub error { + my ($result) = @_; + if ($result =~ /^(con_lost|no_such_host|error: (\d+) (.*))/) { + if ($2 == 2) { return undef; } + return $1; + } + 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 { + my ($lonidsdir,$handle,$force_transfer) = @_; + if (!$force_transfer && $env_loaded) { return; } + if (!defined($lonidsdir)) { $lonidsdir = $perlvar{'lonIDsDir'}; } @@ -292,29 +333,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"; - foreach my $expired_key (keys(%Remove)) { + $env_loaded=1; + foreach my $expired_key (keys(%remove)) { &delenv($expired_key); } } @@ -333,51 +381,13 @@ sub appenv { $env{$key}=$newenv{$key}; } } - - 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); - $name=&unescape($name); - $value=&unescape($value); - 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 &escape($newname).'='.&escape($newenv{$newname})."\n"; - } - close($fh); - } - - close($lockfh); return 'ok'; } # ----------------------------------------------------- Delete from Environment @@ -389,47 +399,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 { @@ -482,48 +478,67 @@ sub overloaderror { sub spareserver { my ($loadpercent,$userloadpercent,$want_server_name) = @_; - my $tryserver; - my $spareserver=''; + my $spare_server; if ($userloadpercent !~ /\d/) { $userloadpercent=0; } - my $lowestserver=$loadpercent > $userloadpercent? - $loadpercent : $userloadpercent; - foreach $tryserver (keys(%spareid)) { - my $loadans=&reply('load',$tryserver); - my $userloadans=&reply('userload',$tryserver); - if ($loadans !~ /\d/ && $userloadans !~ /\d/) { - next; #didn't get a number from the server - } - my $answer; - if ($loadans =~ /\d/) { - if ($userloadans =~ /\d/) { - #both are numbers, pick the bigger one - $answer=$loadans > $userloadans? - $loadans : $userloadans; - } else { - $answer = $loadans; - } - } else { - $answer = $userloadans; - } - if (($answer =~ /\d/) && ($answer<$lowestserver)) { - if ($want_server_name) { - $spareserver=$tryserver; - } else { - $spareserver="http://$hostname{$tryserver}"; - } - $lowestserver=$answer; + my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent + : $userloadpercent; + + foreach my $try_server (@{ $spareid{'primary'} }) { + ($spare_server, $lowest_load) = + &compare_server_load($try_server, $spare_server, $lowest_load); + } + + my $found_server = ($spare_server ne '' && $lowest_load < 100); + + if (!$found_server) { + foreach my $try_server (@{ $spareid{'default'} }) { + ($spare_server, $lowest_load) = + &compare_server_load($try_server, $spare_server, $lowest_load); } } - return $spareserver; + + if (!$want_server_name) { + $spare_server="http://$hostname{$spare_server}"; + } + return $spare_server; } +sub compare_server_load { + my ($try_server, $spare_server, $lowest_load) = @_; + + my $loadans = &reply('load', $try_server); + my $userloadans = &reply('userload',$try_server); + + if ($loadans !~ /\d/ && $userloadans !~ /\d/) { + next; #didn't get a number from the server + } + + my $load; + if ($loadans =~ /\d/) { + if ($userloadans =~ /\d/) { + #both are numbers, pick the bigger one + $load = ($loadans > $userloadans) ? $loadans + : $userloadans; + } else { + $load = $loadans; + } + } else { + $load = $userloadans; + } + + if (($load =~ /\d/) && ($load < $lowest_load)) { + $spare_server = $try_server; + $lowest_load = $load; + } + return ($spare_server,$lowest_load); +} # --------------------------------------------- Try to change a user's password sub changepass { - my ($uname,$udom,$currentpass,$newpass,$server)=@_; + my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_; $currentpass = &escape($currentpass); $newpass = &escape($newpass); - my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass", + my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context", $server); if (! $answer) { &logthis("No reply on password change request to $server ". @@ -572,8 +587,8 @@ sub queryauthenticate { sub authenticate { my ($uname,$upass,$udom)=@_; - $upass=escape($upass); - $uname=~s/\W//g; + $upass=&escape($upass); + $uname= &LONCAPA::clean_username($uname); my $uhome=&homeserver($uname,$udom); if (!$uhome) { &logthis("User $uname at $udom is unknown in authenticate"); @@ -648,8 +663,8 @@ sub idget { sub idrget { my ($udom,@unames)=@_; my %returnhash=(); - foreach (@unames) { - $returnhash{$_}=(&userenvironment($udom,$_,'id'))[1]; + foreach my $uname (@unames) { + $returnhash{$uname}=(&userenvironment($udom,$uname,'id'))[1]; } return %returnhash; } @@ -659,22 +674,69 @@ sub idrget { sub idput { my ($udom,%ids)=@_; my %servers=(); - foreach (keys %ids) { - &cput('environment',{'id'=>$ids{$_}},$udom,$_); - my $uhom=&homeserver($_,$udom); + foreach my $uname (keys(%ids)) { + &cput('environment',{'id'=>$ids{$uname}},$udom,$uname); + my $uhom=&homeserver($uname,$udom); if ($uhom ne 'no_host') { - my $id=&escape($ids{$_}); + my $id=&escape($ids{$uname}); $id=~tr/A-Z/a-z/; - my $unam=&escape($_); + my $esc_unam=&escape($uname); if ($servers{$uhom}) { - $servers{$uhom}.='&'.$id.'='.$unam; + $servers{$uhom}.='&'.$id.'='.$esc_unam; } else { - $servers{$uhom}=$id.'='.$unam; + $servers{$uhom}=$id.'='.$esc_unam; } } } - foreach (keys %servers) { - &critical('idput:'.$udom.':'.$servers{$_},$_); + foreach my $server (keys(%servers)) { + &critical('idput:'.$udom.':'.$servers{$server},$server); + } +} + +# ------------------------------------------- get items from domain db files + +sub get_dom { + my ($namespace,$storearr,$udom)=@_; + my $items=''; + foreach my $item (@$storearr) { + $items.=&escape($item).'&'; + } + $items=~s/\&$//; + if (!$udom) { $udom=$env{'user.domain'}; } + if (exists($domain_primary{$udom})) { + my $uhome=$domain_primary{$udom}; + my $rep=&reply("getdom:$udom:$namespace:$items",$uhome); + my @pairs=split(/\&/,$rep); + if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) { + return @pairs; + } + my %returnhash=(); + my $i=0; + foreach my $item (@$storearr) { + $returnhash{$item}=&thaw_unescape($pairs[$i]); + $i++; + } + return %returnhash; + } else { + &logthis("get_dom failed - no primary domain server for $udom"); + } +} + +# -------------------------------------------- put items in domain db files + +sub put_dom { + my ($namespace,$storehash,$udom)=@_; + if (!$udom) { $udom=$env{'user.domain'}; } + if (exists($domain_primary{$udom})) { + my $uhome=$domain_primary{$udom}; + my $items=''; + foreach my $item (keys(%$storehash)) { + $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; + } + $items=~s/\&$//; + return &reply("putdom:$udom:$namespace:$items",$uhome); + } else { + &logthis("put_dom failed - no primary domain server for $udom"); } } @@ -811,17 +873,32 @@ sub validate_access_key { # ------------------------------------- Find the section of student in a course sub devalidate_getsection_cache { my ($udom,$unam,$courseid)=@_; - $courseid=~s/\_/\//g; - $courseid=~s/^(\w)/\/$1/; my $hashid="$udom:$unam:$courseid"; &devalidate_cache_new('getsection',$hashid); } +sub courseid_to_courseurl { + my ($courseid) = @_; + #already url style courseid + return $courseid if ($courseid =~ m{^/}); + + if (exists($env{'course.'.$courseid.'.num'})) { + my $cnum = $env{'course.'.$courseid.'.num'}; + my $cdom = $env{'course.'.$courseid.'.domain'}; + return "/$cdom/$cnum"; + } + + my %courseinfo=&Apache::lonnet::coursedescription($courseid); + if (exists($courseinfo{'num'})) { + return "/$courseinfo{'domain'}/$courseinfo{'num'}"; + } + + return undef; +} + sub getsection { my ($udom,$unam,$courseid)=@_; my $cachetime=1800; - $courseid=~s/\_/\//g; - $courseid=~s/^(\w)/\/$1/; my $hashid="$udom:$unam:$courseid"; my ($result,$cached)=&is_cached_new('getsection',$hashid); @@ -842,9 +919,10 @@ sub getsection { # If there is more than one expired role, choose the one which ended last. # If there is a role which has expired, return it. # - foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles', - &homeserver($unam,$udom)))) { - my ($key,$value)=split(/\=/,$_); + $courseid = &courseid_to_courseurl($courseid); + foreach my $line (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles', + &homeserver($unam,$udom)))) { + my ($key,$value)=split(/\=/,$line,2); $key=&unescape($key); next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/); my $section=$1; @@ -880,6 +958,7 @@ sub save_cache { &purge_remembered(); #&Apache::loncommon::validate_page(); undef(%env); + undef($env_loaded); } my $to_remember=-1; @@ -1165,7 +1244,7 @@ sub ssi_body { } my $output=($filelink=~/^http\:/?&externalssi($filelink): &ssi($filelink,%form)); - $output=~s|//(\s*)?\s||gs; + $output=~s|//(\s*)?\s||gs; $output=~s/^.*?\]*\>//si; $output=~s/(.*)\<\/body\s*\>.*?$/$1/si; return $output; @@ -1173,6 +1252,15 @@ sub ssi_body { # --------------------------------------------------------- Server Side Include +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)=@_; @@ -1184,10 +1272,10 @@ sub ssi { $form{'no_update_last_known'}=1; if (%form) { - $request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn); + $request=new HTTP::Request('POST',&absolute_url().$fn); $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form)); } else { - $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn); + $request=new HTTP::Request('GET',&absolute_url().$fn); } $request->header(Cookie => $ENV{'HTTP_COOKIE'}); @@ -1610,7 +1698,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 { @@ -1622,8 +1717,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 @@ -1649,8 +1753,7 @@ sub flushcourselogs { # times and course titles for all courseids # my %courseidbuffer=(); - foreach (keys %courselogs) { - my $crsid=$_; + foreach my $crsid (keys %courselogs) { if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'. &escape($courselogs{$crsid}), $coursehombuf{$crsid}) eq 'ok') { @@ -1677,8 +1780,8 @@ sub flushcourselogs { # Write course id database (reverse lookup) to homeserver of courses # Is used in pickcourse # - foreach (keys %courseidbuffer) { - &courseidput($hostdom{$_},$courseidbuffer{$_},$_); + foreach my $crsid (keys(%courseidbuffer)) { + &courseidput($hostdom{$crsid},$courseidbuffer{$crsid},$crsid); } # # File accesses @@ -1687,7 +1790,8 @@ sub flushcourselogs { foreach my $entry (keys(%accesshash)) { if ($entry =~ /___count$/) { my ($dom,$name); - ($dom,$name,undef)=($entry=~m:___(\w+)/(\w+)/(.*)___count$:); + ($dom,$name,undef)= + ($entry=~m{___($match_domain)/($match_name)/(.*)___count$}); if (! defined($dom) || $dom eq '' || ! defined($name) || $name eq '') { my $cid = $env{'request.course.id'}; @@ -1708,7 +1812,7 @@ sub flushcourselogs { } } } else { - my ($dom,$name) = ($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:); + my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$}); my %temphash=($entry => $accesshash{$entry}); if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') { delete $accesshash{$entry}; @@ -1719,8 +1823,7 @@ sub flushcourselogs { # Roles # Reverse lookup of user roles for course faculty/staff and co-authorship # - foreach (keys %userrolehash) { - my $entry=$_; + foreach my $entry (keys(%userrolehash)) { my ($role,$uname,$udom,$runame,$rudom,$rsec)= split(/\:/,$entry); if (&Apache::lonnet::put('nohist_userroles', @@ -1792,9 +1895,9 @@ sub courseacclog { if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|task|page)$/) { $what.=':POST'; # FIXME: Probably ought to escape things.... - foreach (keys %env) { - if ($_=~/^form\.(.*)/) { - $what.=':'.$1.'='.$env{$_}; + foreach my $key (keys(%env)) { + if ($key=~/^form\.(.*)/) { + $what.=':'.$1.'='.$env{$key}; } } } elsif ($fnsymb =~ m:^/adm/searchcat:) { @@ -1856,27 +1959,24 @@ sub get_course_adv_roles { $cid=$env{'request.course.id'} unless (defined($cid)); my %coursehash=&coursedescription($cid); my %nothide=(); - foreach (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { - $nothide{join(':',split(/[\@\:]/,$_))}=1; + foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { + $nothide{join(':',split(/[\@\:]/,$user))}=1; } my %returnhash=(); my %dumphash= &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'}); my $now=time; - foreach (keys %dumphash) { - my ($tend,$tstart)=split(/\:/,$dumphash{$_}); + foreach my $entry (keys %dumphash) { + my ($tend,$tstart)=split(/\:/,$dumphash{$entry}); if (($tstart) && ($tstart<0)) { next; } if (($tend) && ($tend<$now)) { next; } if (($tstart) && ($now<$tstart)) { next; } - my ($role,$username,$domain,$section)=split(/\:/,$_); + my ($role,$username,$domain,$section)=split(/\:/,$entry); if ($username eq '' || $domain eq '') { next; } if ((&privileged($username,$domain)) && (!$nothide{$username.':'.$domain})) { next; } if ($role eq 'cr') { next; } my $key=&plaintext($role); - if ($role =~ /^cr/) { - $key=(split('/',$role))[3]; - } if ($section) { $key.=' (Sec/Grp '.$section.')'; } if ($returnhash{$key}) { $returnhash{$key}.=','.$username.':'.$domain; @@ -1895,12 +1995,12 @@ sub get_my_roles { &dump('nohist_userroles',$udom,$uname); my %returnhash=(); my $now=time; - foreach (keys %dumphash) { - my ($tend,$tstart)=split(/\:/,$dumphash{$_}); + foreach my $entry (keys(%dumphash)) { + my ($tend,$tstart)=split(/\:/,$dumphash{$entry}); if (($tstart) && ($tstart<0)) { next; } if (($tend) && ($tend<$now)) { next; } if (($tstart) && ($now<$tstart)) { next; } - my ($role,$username,$domain,$section)=split(/\:/,$_); + my ($role,$username,$domain,$section)=split(/\:/,$entry); $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend; } return %returnhash; @@ -1921,7 +2021,7 @@ sub getannounce { if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) { my $announcement=''; - while (<$fh>) { $announcement .=$_; } + while (my $line = <$fh>) { $announcement .= $line; } close($fh); if ($announcement=~/\w/) { return @@ -1945,18 +2045,18 @@ 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) { if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) || (!defined($hostidflag)) ) { if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) { - foreach ( + foreach my $line ( 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(/\=/,$_); + my ($key,$value)=split(/\=/,$line,2); if (($key) && ($value)) { $returnhash{&unescape($key)}=$value; } @@ -1985,8 +2085,8 @@ sub dcmaildump { &escape($enddate).':'; my @esc_senders=map { &escape($_)} @$senders; $cmd.=&escape(join('&',@esc_senders)); - foreach (split(/\&/,&reply($cmd,$domain_primary{$dom}))) { - my ($key,$value) = split(/\=/,$_); + foreach my $line (split(/\&/,&reply($cmd,$domain_primary{$dom}))) { + my ($key,$value) = split(/\=/,$line,2); if (($key) && ($value)) { $returnhash{&unescape($key)} = &unescape($value); } @@ -2009,11 +2109,11 @@ sub get_domain_roles { foreach my $tryserver (keys(%libserv)) { if ($hostdom{$tryserver} eq $dom) { %{$personnel{$tryserver}}=(); - foreach ( + foreach my $line ( split(/\&/,&reply('domrolesdump:'.$dom.':'. &escape($startdate).':'.&escape($enddate).':'. &escape($rolelist), $tryserver))) { - my($key,$value) = split(/\=/,$_); + my ($key,$value) = split(/\=/,$line,2); if (($key) && ($value)) { $personnel{$tryserver}{&unescape($key)} = &unescape($value); } @@ -2027,7 +2127,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') { @@ -2041,7 +2141,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); @@ -2235,27 +2335,27 @@ sub hash2str { sub hashref2str { my ($hashref)=@_; my $result='__HASH_REF__'; - foreach (sort(keys(%$hashref))) { - if (ref($_) eq 'ARRAY') { - $result.=&arrayref2str($_).'='; - } elsif (ref($_) eq 'HASH') { - $result.=&hashref2str($_).'='; - } elsif (ref($_)) { + foreach my $key (sort(keys(%$hashref))) { + if (ref($key) eq 'ARRAY') { + $result.=&arrayref2str($key).'='; + } elsif (ref($key) eq 'HASH') { + $result.=&hashref2str($key).'='; + } elsif (ref($key)) { $result.='='; - #print("Got a ref of ".(ref($_))." skipping."); + #print("Got a ref of ".(ref($key))." skipping."); } else { - if ($_) {$result.=&escape($_).'=';} else { last; } + if ($key) {$result.=&escape($key).'=';} else { last; } } - if(ref($hashref->{$_}) eq 'ARRAY') { - $result.=&arrayref2str($hashref->{$_}).'&'; - } elsif(ref($hashref->{$_}) eq 'HASH') { - $result.=&hashref2str($hashref->{$_}).'&'; - } elsif(ref($hashref->{$_})) { + if(ref($hashref->{$key}) eq 'ARRAY') { + $result.=&arrayref2str($hashref->{$key}).'&'; + } elsif(ref($hashref->{$key}) eq 'HASH') { + $result.=&hashref2str($hashref->{$key}).'&'; + } elsif(ref($hashref->{$key})) { $result.='&'; - #print("Got a ref of ".(ref($hashref->{$_}))." skipping."); + #print("Got a ref of ".(ref($hashref->{$key}))." skipping."); } else { - $result.=&escape($hashref->{$_}).'&'; + $result.=&escape($hashref->{$key}).'&'; } } $result=~s/\&$//; @@ -2535,8 +2635,8 @@ sub store { $$storehash{'host'}=$perlvar{'lonHostID'}; my $namevalue=''; - foreach (keys %$storehash) { - $namevalue.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; + foreach my $key (keys(%$storehash)) { + $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&'; } $namevalue=~s/\&$//; &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue); @@ -2571,8 +2671,8 @@ sub cstore { $$storehash{'host'}=$perlvar{'lonHostID'}; my $namevalue=''; - foreach (keys %$storehash) { - $namevalue.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; + foreach my $key (keys(%$storehash)) { + $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&'; } $namevalue=~s/\&$//; &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue); @@ -2604,14 +2704,14 @@ sub restore { my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home"); my %returnhash=(); - foreach (split(/\&/,$answer)) { - my ($name,$value)=split(/\=/,$_); + foreach my $line (split(/\&/,$answer)) { + my ($name,$value)=split(/\=/,$line); $returnhash{&unescape($name)}=&thaw_unescape($value); } my $version; for ($version=1;$version<=$returnhash{'version'};$version++) { - foreach (split(/\:/,$returnhash{$version.':keys'})) { - $returnhash{$_}=$returnhash{$version.':'.$_}; + foreach my $item (split(/\:/,$returnhash{$version.':keys'})) { + $returnhash{$item}=$returnhash{$version.':'.$item}; } } return %returnhash; @@ -2651,6 +2751,7 @@ sub coursedescription { if (!$args->{'one_time'}) { $envhash{'course.'.$normalid.'.last_cache'}=time; } + if ($chome ne 'no_host') { %returnhash=&dump('environment',$cdomain,$cnum); if (!exists($returnhash{'con_lost'})) { @@ -2686,9 +2787,9 @@ sub privileged { if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return 0; } my $now=time; if ($rolesdump ne '') { - foreach (split(/&/,$rolesdump)) { - if ($_!~/^rolesdef_/) { - my ($area,$role)=split(/=/,$_); + foreach my $entry (split(/&/,$rolesdump)) { + if ($entry!~/^rolesdef_/) { + my ($area,$role)=split(/=/,$entry); $area=~s/\_\w\w$//; my ($trole,$tend,$tstart)=split(/_/,$role); if (($trole eq 'dc') || ($trole eq 'su')) { @@ -2720,14 +2821,14 @@ sub rolesinit { my $group_privs; if ($rolesdump ne '') { - foreach (split(/&/,$rolesdump)) { - if ($_!~/^rolesdef_/) { - my ($area,$role)=split(/=/,$_); + foreach my $entry (split(/&/,$rolesdump)) { + if ($entry!~/^rolesdef_/) { + my ($area,$role)=split(/=/,$entry); $area=~s/\_\w\w$//; my ($trole,$tend,$tstart,$group_privs); if ($role=~/^cr/) { - if ($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|) { - ($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|); + if ($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) { + ($trole,my $trest)=($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|); ($tend,$tstart)=split('_',$trest); } else { $trole=$role; @@ -2806,7 +2907,7 @@ sub group_roleprivs { if (($tend!=0) && ($tend<$now)) { $access = 0; } if (($tstart!=0) && ($tstart>$now)) { $access=0; } if ($access) { - my ($course,$group) = ($area =~ m|(/\w+/\w+)/([^/]+)$|); + my ($course,$group) = ($area =~ m|(/$match_domain/$match_courseid)/([^/]+)$|); $$allgroups{$course}{$group} .=':'.$group_privs; } } @@ -2837,7 +2938,7 @@ sub set_userprivs { if (keys(%{$allgroups}) > 0) { foreach my $role (keys %{$allroles}) { my ($trole,$area,$sec,$extendedarea); - if ($role =~ m|^(\w+)\.(/\w+/\w+)(/?\w*)|) { + if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)-) { $trole = $1; $area = $2; $sec = $3; @@ -2852,15 +2953,15 @@ sub set_userprivs { } } } - foreach (keys(%grouproles)) { - $$allroles{$_} = $grouproles{$_}; + foreach my $group (keys(%grouproles)) { + $$allroles{$group} = $grouproles{$group}; } - foreach (keys %{$allroles}) { - my %thesepriv=(); - if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; } - foreach (split(/:/,$$allroles{$_})) { - if ($_ ne '') { - my ($privilege,$restrictions)=split(/&/,$_); + foreach my $role (keys(%{$allroles})) { + my %thesepriv; + if (($role=~/^au/) || ($role=~/^ca/)) { $author=1; } + foreach my $item (split(/:/,$$allroles{$role})) { + if ($item ne '') { + my ($privilege,$restrictions)=split(/&/,$item); if ($restrictions eq '') { $thesepriv{$privilege}='F'; } elsif ($thesepriv{$privilege} ne 'F') { @@ -2870,8 +2971,10 @@ sub set_userprivs { } } my $thesestr=''; - foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } - $userroles->{'user.priv.'.$_} = $thesestr; + foreach my $priv (keys(%thesepriv)) { + $thesestr.=':'.$priv.'&'.$thesepriv{$priv}; + } + $userroles->{'user.priv.'.$role} = $thesestr; } return ($author,$adv); } @@ -2881,8 +2984,8 @@ sub set_userprivs { sub get { my ($namespace,$storearr,$udomain,$uname)=@_; my $items=''; - foreach (@$storearr) { - $items.=escape($_).'&'; + foreach my $item (@$storearr) { + $items.=&escape($item).'&'; } $items=~s/\&$//; if (!$udomain) { $udomain=$env{'user.domain'}; } @@ -2896,8 +2999,8 @@ sub get { } my %returnhash=(); my $i=0; - foreach (@$storearr) { - $returnhash{$_}=&thaw_unescape($pairs[$i]); + foreach my $item (@$storearr) { + $returnhash{$item}=&thaw_unescape($pairs[$i]); $i++; } return %returnhash; @@ -2908,8 +3011,8 @@ sub get { sub del { my ($namespace,$storearr,$udomain,$uname)=@_; my $items=''; - foreach (@$storearr) { - $items.=escape($_).'&'; + foreach my $item (@$storearr) { + $items.=&escape($item).'&'; } $items=~s/\&$//; if (!$udomain) { $udomain=$env{'user.domain'}; } @@ -2922,23 +3025,25 @@ sub del { # -------------------------------------------------------------- dump interface sub dump { - my ($namespace,$udomain,$uname,$regexp,$range)=@_; - if (!$udomain) { $udomain=$env{'user.domain'}; } - if (!$uname) { $uname=$env{'user.name'}; } - my $uhome=&homeserver($uname,$udomain); - if ($regexp) { - $regexp=&escape($regexp); - } else { - $regexp='.'; - } - my $rep=reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome); - my @pairs=split(/\&/,$rep); - my %returnhash=(); - foreach (@pairs) { - my ($key,$value)=split(/=/,$_,2); - $returnhash{unescape($key)}=&thaw_unescape($value); - } - return %returnhash; + my ($namespace,$udomain,$uname,$regexp,$range)=@_; + if (!$udomain) { $udomain=$env{'user.domain'}; } + if (!$uname) { $uname=$env{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); + if ($regexp) { + $regexp=&escape($regexp); + } else { + $regexp='.'; + } + my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome); + my @pairs=split(/\&/,$rep); + my %returnhash=(); + foreach my $item (@pairs) { + my ($key,$value)=split(/=/,$item,2); + $key = &unescape($key); + next if ($key =~ /^error: 2 /); + $returnhash{$key}=&thaw_unescape($value); + } + return %returnhash; } # --------------------------------------------------------- dumpstore interface @@ -2957,8 +3062,9 @@ sub getkeys { my $uhome=&homeserver($uname,$udomain); my $rep=reply("keys:$udomain:$uname:$namespace",$uhome); my @keyarray=(); - foreach (split(/\&/,$rep)) { - push (@keyarray,&unescape($_)); + foreach my $key (split(/\&/,$rep)) { + next if ($key =~ /^error: 2 /); + push(@keyarray,&unescape($key)); } return @keyarray; } @@ -2985,8 +3091,8 @@ sub currentdump { %returnhash = %{&convert_dump_to_currentdump(\%hash)}; } else { my @pairs=split(/\&/,$rep); - foreach (@pairs) { - my ($key,$value)=split(/=/,$_); + foreach my $pair (@pairs) { + my ($key,$value)=split(/=/,$pair,2); my ($symb,$param) = split(/:/,$key); $returnhash{&unescape($symb)}->{&unescape($param)} = &thaw_unescape($value); @@ -3064,8 +3170,8 @@ sub put { if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); my $items=''; - foreach (keys %$storehash) { - $items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; + foreach my $item (keys(%$storehash)) { + $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; } $items=~s/\&$//; return &reply("put:$udomain:$uname:$namespace:$items",$uhome); @@ -3117,22 +3223,22 @@ sub old_putstore { if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); my %newstorehash; - foreach (keys %$storehash) { - my $key = $version.':'.&escape($symb).':'.$_; - $newstorehash{$key} = $storehash->{$_}; + foreach my $item (keys(%$storehash)) { + my $key = $version.':'.&escape($symb).':'.$item; + $newstorehash{$key} = $storehash->{$item}; } my $items=''; my %allitems = (); - foreach (keys %newstorehash) { - if ($_ =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) { + foreach my $item (keys(%newstorehash)) { + if ($item =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) { my $key = $1.':keys:'.$2; $allitems{$key} .= $3.':'; } - $items.=$_.'='.&freeze_escape($newstorehash{$_}).'&'; + $items.=$item.'='.&freeze_escape($newstorehash{$item}).'&'; } - foreach (keys %allitems) { - $allitems{$_} =~ s/\:$//; - $items.= $_.'='.$allitems{$_}.'&'; + foreach my $item (keys(%allitems)) { + $allitems{$item} =~ s/\:$//; + $items.= $item.'='.$allitems{$item}.'&'; } $items=~s/\&$//; return &reply("put:$udomain:$uname:$namespace:$items",$uhome); @@ -3146,8 +3252,8 @@ sub cput { if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); my $items=''; - foreach (keys %$storehash) { - $items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; + foreach my $item (keys(%$storehash)) { + $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; } $items=~s/\&$//; return &critical("put:$udomain:$uname:$namespace:$items",$uhome); @@ -3158,8 +3264,8 @@ sub cput { sub eget { my ($namespace,$storearr,$udomain,$uname)=@_; my $items=''; - foreach (@$storearr) { - $items.=escape($_).'&'; + foreach my $item (@$storearr) { + $items.=&escape($item).'&'; } $items=~s/\&$//; if (!$udomain) { $udomain=$env{'user.domain'}; } @@ -3169,8 +3275,8 @@ sub eget { my @pairs=split(/\&/,$rep); my %returnhash=(); my $i=0; - foreach (@$storearr) { - $returnhash{$_}=&thaw_unescape($pairs[$i]); + foreach my $item (@$storearr) { + $returnhash{$item}=&thaw_unescape($pairs[$i]); $i++; } return %returnhash; @@ -3178,12 +3284,15 @@ sub eget { # ------------------------------------------------------------ tmpput interface sub tmpput { - my ($storehash,$server)=@_; + my ($storehash,$server,$context)=@_; my $items=''; - foreach (keys(%$storehash)) { - $items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; + foreach my $item (keys(%$storehash)) { + $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; } $items=~s/\&$//; + if (defined($context)) { + $items .= ':'.&escape($context); + } return &reply("tmpput:$items",$server); } @@ -3207,21 +3316,259 @@ sub tmpdel { return &reply("tmpdel:$token",$server); } +# -------------------------------------------------- portfolio access checking + +sub portfolio_access { + my ($requrl) = @_; + my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl); + my $result = &get_portfolio_access($udom,$unum,$file_name,$group); + if ($result) { + my %setters; + if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') { + my ($startblock,$endblock) = + &Apache::loncommon::blockcheck(\%setters,'port',$unum,$udom); + if ($startblock && $endblock) { + return 'B'; + } + } else { + my ($startblock,$endblock) = + &Apache::loncommon::blockcheck(\%setters,'port'); + if ($startblock && $endblock) { + return 'B'; + } + } + } + if ($result eq 'ok') { + return 'F'; + } elsif ($result =~ /^[^:]+:guest_/) { + return 'A'; + } + return ''; +} + +sub get_portfolio_access { + my ($udom,$unum,$file_name,$group,$access_hash) = @_; + + if (!ref($access_hash)) { + my $current_perms = &get_portfile_permissions($udom,$unum); + my %access_controls = &get_access_controls($current_perms,$group, + $file_name); + $access_hash = $access_controls{$file_name}; + } + + my ($public,$guest,@domains,@users,@courses,@groups); + my $now = time; + if (ref($access_hash) eq 'HASH') { + foreach my $key (keys(%{$access_hash})) { + my ($num,$scope,$end,$start) = ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/); + if ($start > $now) { + next; + } + if ($end && $end<$now) { + next; + } + if ($scope eq 'public') { + $public = $key; + last; + } elsif ($scope eq 'guest') { + $guest = $key; + } elsif ($scope eq 'domains') { + push(@domains,$key); + } elsif ($scope eq 'users') { + push(@users,$key); + } elsif ($scope eq 'course') { + push(@courses,$key); + } elsif ($scope eq 'group') { + push(@groups,$key); + } + } + if ($public) { + return 'ok'; + } + if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') { + if ($guest) { + return $guest; + } + } else { + if (@domains > 0) { + foreach my $domkey (@domains) { + if (ref($access_hash->{$domkey}{'dom'}) eq 'ARRAY') { + if (grep(/^\Q$env{'user.domain'}\E$/,@{$access_hash->{$domkey}{'dom'}})) { + return 'ok'; + } + } + } + } + if (@users > 0) { + foreach my $userkey (@users) { + if (exists($access_hash->{$userkey}{'users'}{$env{'user.name'}.':'.$env{'user.domain'}})) { + return 'ok'; + } + } + } + my %roleshash; + my @courses_and_groups = @courses; + push(@courses_and_groups,@groups); + if (@courses_and_groups > 0) { + my (%allgroups,%allroles); + my ($start,$end,$role,$sec,$group); + foreach my $envkey (%env) { + if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) { + my $cid = $2.'_'.$3; + if ($1 eq 'gr') { + $group = $4; + $allgroups{$cid}{$group} = $env{$envkey}; + } else { + if ($4 eq '') { + $sec = 'none'; + } else { + $sec = $4; + } + $allroles{$cid}{$1}{$sec} = $env{$envkey}; + } + } elsif ($envkey =~ m-^user\.role\./cr/($match_domain/$match_username/\w*)./($match_domain)/($match_courseid)/?([^/]*)$-) { + my $cid = $2.'_'.$3; + if ($4 eq '') { + $sec = 'none'; + } else { + $sec = $4; + } + $allroles{$cid}{$1}{$sec} = $env{$envkey}; + } + } + if (keys(%allroles) == 0) { + return; + } + foreach my $key (@courses_and_groups) { + my %content = %{$$access_hash{$key}}; + my $cnum = $content{'number'}; + my $cdom = $content{'domain'}; + my $cid = $cdom.'_'.$cnum; + if (!exists($allroles{$cid})) { + next; + } + foreach my $role_id (keys(%{$content{'roles'}})) { + my @sections = @{$content{'roles'}{$role_id}{'section'}}; + my @groups = @{$content{'roles'}{$role_id}{'group'}}; + my @status = @{$content{'roles'}{$role_id}{'access'}}; + my @roles = @{$content{'roles'}{$role_id}{'role'}}; + foreach my $role (keys(%{$allroles{$cid}})) { + if ((grep/^all$/,@roles) || (grep/^\Q$role\E$/,@roles)) { + foreach my $sec (keys(%{$allroles{$cid}{$role}})) { + if (&course_group_datechecker($allroles{$cid}{$role}{$sec},$now,\@status) eq 'ok') { + if (grep/^all$/,@sections) { + return 'ok'; + } else { + if (grep/^$sec$/,@sections) { + return 'ok'; + } + } + } + } + if (keys(%{$allgroups{$cid}}) == 0) { + if (grep/^none$/,@groups) { + return 'ok'; + } + } else { + if (grep/^all$/,@groups) { + return 'ok'; + } + foreach my $group (keys(%{$allgroups{$cid}})) { + if (grep/^$group$/,@groups) { + return 'ok'; + } + } + } + } + } + } + } + } + if ($guest) { + return $guest; + } + } + } + return; +} + +sub course_group_datechecker { + my ($dates,$now,$status) = @_; + my ($start,$end) = split(/\./,$dates); + if (!$start && !$end) { + return 'ok'; + } + if (grep/^active$/,@{$status}) { + if (((!$start) || ($start && $start <= $now)) && ((!$end) || ($end && $end >= $now))) { + return 'ok'; + } + } + if (grep/^previous$/,@{$status}) { + if ($end > $now ) { + return 'ok'; + } + } + if (grep/^future$/,@{$status}) { + if ($start > $now) { + return 'ok'; + } + } + return; +} + +sub parse_portfolio_url { + my ($url) = @_; + + my ($type,$udom,$unum,$group,$file_name); + + if ($url =~ m-^/*uploaded/($match_domain)/($match_username)/portfolio(/.+)$-) { + $type = 1; + $udom = $1; + $unum = $2; + $file_name = $3; + } elsif ($url =~ m-^/*uploaded/($match_domain)/($match_courseid)/groups/([^/]+)/portfolio/(.+)$-) { + $type = 2; + $udom = $1; + $unum = $2; + $group = $3; + $file_name = $3.'/'.$4; + } + if (wantarray) { + return ($type,$udom,$unum,$file_name,$group); + } + return $type; +} + +sub is_portfolio_url { + my ($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 { my ($priv,$uri)=@_; - my ($urole,$urealm)=split(/\./,$env{'request.role'}); - $urealm=~s/^\W//; + my ($urole,$urealm)=split(/\./,$env{'request.role'},2); my ($udom,$ucrs,$usec)=split(/\//,$urealm); + $udom = &LONCAPA::clean_domain($udom); + $ucrs = &LONCAPA::clean_username($ucrs); my $access=0; - foreach (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) { - my ($effect,$realm,$role)=split(/\:/,$_); + foreach my $right (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) { + my ($effect,$realm,$role)=split(/\:/,$right); if ($role) { if ($role ne $urole) { next; } } - foreach (split(/\s*\,\s*/,$realm)) { - my ($tdom,$tcrs,$tsec)=split(/\_/,$_); + foreach my $scope (split(/\s*\,\s*/,$realm)) { + my ($tdom,$tcrs,$tsec)=split(/\_/,$scope); if ($tdom) { if ($tdom ne $udom) { next; } } @@ -3244,16 +3591,26 @@ sub customaccess { # ------------------------------------------------- Check for a user privilege sub allowed { - my ($priv,$uri,$symb)=@_; + my ($priv,$uri,$symb,$role)=@_; my $ver_orguri=$uri; $uri=&deversion($uri); my $orguri=$uri; $uri=&declutter($uri); - + + if ($priv eq 'evb') { +# Evade communication block restrictions for specified role in a course + if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) { + return $1; + } else { + return; + } + } + if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; } # Free bre access to adm and meta resources - if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|)) - || ($uri=~/\.meta$/)) && ($priv eq 'bre')) { + if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$})) + || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) + && ($priv eq 'bre')) { return 'F'; } @@ -3261,10 +3618,17 @@ sub allowed { my ($space,$domain,$name,@dir)=split('/',$uri); if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) && ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) { - return 'F'; + my %setters; + my ($startblock,$endblock) = + &Apache::loncommon::blockcheck(\%setters,'port'); + if ($startblock && $endblock) { + return 'B'; + } else { + return 'F'; + } } -# bre access to group if user has rgf priv for this group and course. +# bre access to group portfolio for rgf priv in group, or mdg or vcg in course. if (($space=~/^(uploaded|editupload)$/) && ($dir[0] eq 'groups') && ($dir[2] eq 'portfolio') && ($priv eq 'bre')) { if (exists($env{'request.course.id'})) { @@ -3276,6 +3640,14 @@ sub allowed { if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid .'/'.$dir[1]} =~/rgf\&([^\:]*)/) { return $1; + } else { + if ($env{'request.course.sec'}) { + $courseprivid.='/'.$env{'request.course.sec'}; + } + if ($env{'user.priv.'.$env{'request.role'}.'./'. + $courseprivid} =~/(mdg|vcg)\&([^\:]*)/) { + return $2; + } } } } @@ -3344,14 +3716,6 @@ sub allowed { $thisallowed.=$1; } -# Group: uri itself is a group - my $groupuri=$uri; - $groupuri=~s/^([^\/])/\/$1/; - if ($env{'user.priv.'.$env{'request.role'}.'.'.$groupuri} - =~/\Q$priv\E\&([^\:]*)/) { - $thisallowed.=$1; - } - # URI is an uploaded document for this course, default permissions don't matter # not allowing 'edit' access (editupload) to uploaded course docs if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) { @@ -3378,6 +3742,13 @@ sub allowed { } } + if ($priv eq 'bre' + && $thisallowed ne 'F' + && $thisallowed ne '2' + && &is_portfolio_url($uri)) { + $thisallowed = &portfolio_access($uri); + } + # Full access at system, domain or course-wide level? Exit. if ($thisallowed=~/F/) { @@ -3425,14 +3796,14 @@ sub allowed { if ($checkreferer) { my $refuri=$env{'httpref.'.$orguri}; unless ($refuri) { - foreach (keys %env) { - if ($_=~/^httpref\..*\*/) { - my $pattern=$_; + foreach my $key (keys(%env)) { + if ($key=~/^httpref\..*\*/) { + my $pattern=$key; $pattern=~s/^httpref\.\/res\///; $pattern=~s/\*/\[\^\/\]\+/g; $pattern=~s/\//\\\//g; if ($orguri=~/$pattern/) { - $refuri=$env{$_}; + $refuri=$env{$key}; } } } @@ -3528,7 +3899,13 @@ sub allowed { # unless ($env{'request.course.id'}) { - return '1'; + if ($thisallowed eq 'A') { + return 'A'; + } elsif ($thisallowed eq 'B') { + return 'B'; + } else { + return '1'; + } } # @@ -3591,6 +3968,11 @@ sub allowed { } } + if ($thisallowed eq 'A') { + return 'A'; + } elsif ($thisallowed eq 'B') { + return 'B'; + } return 'F'; } @@ -3643,8 +4025,8 @@ sub get_symb_from_alias { sub definerole { if (allowed('mcr','/')) { my ($rolename,$sysrole,$domrole,$courole)=@_; - foreach (split(':',$sysrole)) { - my ($crole,$cqual)=split(/\&/,$_); + foreach my $role (split(':',$sysrole)) { + my ($crole,$cqual)=split(/\&/,$role); if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; } if ($pr{'cr:s'}=~/\Q$crole\E\&/) { if ($pr{'cr:s'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { @@ -3652,8 +4034,8 @@ sub definerole { } } } - foreach (split(':',$domrole)) { - my ($crole,$cqual)=split(/\&/,$_); + foreach my $role (split(':',$domrole)) { + my ($crole,$cqual)=split(/\&/,$role); if ($pr{'cr:d'}!~/\Q$crole\E/) { return "refused:d:$crole"; } if ($pr{'cr:d'}=~/\Q$crole\E\&/) { if ($pr{'cr:d'}!~/\Q$crole\W\&\w*\Q$cqual\E/) { @@ -3661,8 +4043,8 @@ sub definerole { } } } - foreach (split(':',$courole)) { - my ($crole,$cqual)=split(/\&/,$_); + foreach my $role (split(':',$courole)) { + my ($crole,$cqual)=split(/\&/,$role); if ($pr{'cr:c'}!~/\Q$crole\E/) { return "refused:c:$crole"; } if ($pr{'cr:c'}=~/\Q$crole\E\&/) { if ($pr{'cr:c'}!~/\Q$crole\E\&\w*\Q$cqual\E/) { @@ -3709,7 +4091,7 @@ sub log_query { my $uhome=&homeserver($uname,$udom); if ($uhome eq 'no_host') { return 'error: no_host'; } my $uhost=$hostname{$uhome}; - my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys %filters)); + my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys(%filters))); my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command, $uhome); unless ($queryid=~/^\Q$uhost\E\_/) { return 'error: '.$queryid; } @@ -3730,8 +4112,8 @@ sub fetch_enrollment_query { } my $host=$hostname{$homeserver}; my $cmd = ''; - foreach (keys %{$affiliatesref}) { - $cmd .= $_.'='.join(",",@{$$affiliatesref{$_}}).'%%'; + foreach my $affiliate (keys %{$affiliatesref}) { + $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%'; } $cmd =~ s/%%$//; $cmd = &escape($cmd); @@ -3752,18 +4134,18 @@ sub fetch_enrollment_query { } else { my @responses = split/:/,$reply; if ($homeserver eq $perlvar{'lonHostID'}) { - foreach (@responses) { - my ($key,$value) = split/=/,$_; + foreach my $line (@responses) { + my ($key,$value) = split(/=/,$line,2); $$replyref{$key} = $value; } } else { my $pathname = $perlvar{'lonDaemons'}.'/tmp'; - foreach (@responses) { - my ($key,$value) = split/=/,$_; + foreach my $line (@responses) { + my ($key,$value) = split(/=/,$line); $$replyref{$key} = $value; if ($value > 0) { - foreach (@{$$affiliatesref{$key}}) { - my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml'; + foreach my $item (@{$$affiliatesref{$key}}) { + my $filename = $dom.'_'.$key.'_'.$item.'_classlist.xml'; my $destname = $pathname.'/'.$filename; my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver); if ($xml_classlist =~ /^error/) { @@ -3837,7 +4219,7 @@ sub auto_run { my $response = &reply('autorun:'.$cdom,$homeserver); return $response; } - + sub auto_get_sections { my ($cnum,$cdom,$inst_coursecode) = @_; my $homeserver = &homeserver($cnum,$cdom); @@ -3848,21 +4230,21 @@ sub auto_get_sections { } return @secs; } - + sub auto_new_course { my ($cnum,$cdom,$inst_course_id,$owner) = @_; my $homeserver = &homeserver($cnum,$cdom); my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver)); return $response; } - + sub auto_validate_courseID { my ($cnum,$cdom,$inst_course_id) = @_; my $homeserver = &homeserver($cnum,$cdom); my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver)); return $response; } - + sub auto_create_password { my ($cnum,$cdom,$authparam) = @_; my $homeserver = &homeserver($cnum,$cdom); @@ -3922,8 +4304,8 @@ sub auto_photoupdate { my $host=$hostname{$homeserver}; my $cmd = ''; my $maxtries = 1; - foreach (keys %{$affiliatesref}) { - $cmd .= $_.'='.join(",",@{$$affiliatesref{$_}}).'%%'; + foreach my $affiliate (keys(%{$affiliatesref})) { + $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%'; } $cmd =~ s/%%$//; $cmd = &escape($cmd); @@ -3954,43 +4336,94 @@ 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 $homeserver; + my @homeservers; if ($caller eq 'global') { - foreach my $tryserver (keys %libserv) { + foreach my $tryserver (keys(%libserv)) { if ($hostdom{$tryserver} eq $codedom) { - $homeserver = $tryserver; - last; + if (!grep(/^\Q$tryserver\E$/,@homeservers)) { + push(@homeservers,$tryserver); + } } } - if (($env{'user.name'}) && ($env{'user.domain'} eq $codedom)) { - $homeserver = &homeserver($env{'user.name'},$codedom); - } } else { - $homeserver = &homeserver($caller,$codedom); + 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 $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$homeserver); - unless ($response =~ /(con_lost|error|no_such_host|refused)/) { - my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = split/:/,$response; - %{$codes} = &str2hash($codes_str); - @{$codetitles} = &str2array($codetitles_str); - %{$cat_titles} = &str2hash($cat_titles_str); - %{$cat_order} = &str2hash($cat_order_str); + my $ok_response = 0; + my $response; + while (@homeservers > 0 && $ok_response == 0) { + my $server = shift(@homeservers); + $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; + %{$codes} = (%{$codes},&str2hash($codes_str)); + push(@{$codetitles},&str2array($codetitles_str)); + %{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str)); + %{$cat_order} = (%{$cat_order},&str2hash($cat_order_str)); + $ok_response = 1; + } + } + if ($ok_response) { + return 'ok'; + } else { + return $response; + } +} + +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); + my $response=&reply('autovalidateclass_sec:'.$inst_class.':'. + &escape($owner).':'.$cdom,$homeserver); return $response; } # ------------------------------------------------------- Course Group routines sub get_coursegroups { - my ($cdom,$cnum,$group) = @_; - return(&dump('coursegroups',$cdom,$cnum,$group)); + my ($cdom,$cnum,$group,$namespace) = @_; + return(&dump($namespace,$cdom,$cnum,$group)); } sub modify_coursegroup { @@ -3998,6 +4431,37 @@ sub modify_coursegroup { return(&put('coursegroups',$groupsettings,$cdom,$cnum)); } +sub toggle_coursegroup_status { + my ($cdom,$cnum,$group,$action) = @_; + my ($from_namespace,$to_namespace); + if ($action eq 'delete') { + $from_namespace = 'coursegroups'; + $to_namespace = 'deleted_groups'; + } else { + $from_namespace = 'deleted_groups'; + $to_namespace = 'coursegroups'; + } + my %curr_group = &get_coursegroups($cdom,$cnum,$group,$from_namespace); + if (my $tmp = &error(%curr_group)) { + &Apache::lonnet::logthis('Error retrieving group: '.$tmp.' in '.$cnum.':'.$cdom); + return ('read error',$tmp); + } else { + my %savedsettings = %curr_group; + my $result = &put($to_namespace,\%savedsettings,$cdom,$cnum); + my $deloutcome; + if ($result eq 'ok') { + $deloutcome = &del($from_namespace,[$group],$cdom,$cnum); + } else { + return ('write error',$result); + } + if ($deloutcome eq 'ok') { + return 'ok'; + } else { + return ('delete error',$deloutcome); + } + } +} + sub modify_group_roles { my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs) = @_; my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id; @@ -4021,7 +4485,7 @@ sub get_active_groups { my $now = time; my %groups = (); foreach my $key (keys(%env)) { - if ($key =~ m-user\.role\.gr\./([^/]+)/([^/]+)/(\w+)$-) { + if ($key =~ m-user\.role\.gr\./($match_domain)/($match_courseid)/(\w+)$-) { my ($start,$end) = split(/\./,$env{$key}); if (($end!=0) && ($end<$now)) { next; } if (($start!=0) && ($start>$now)) { next; } @@ -4042,8 +4506,6 @@ sub get_users_groups { my ($udom,$uname,$courseid) = @_; my @usersgroups; my $cachetime=1800; - $courseid=~s/\_/\//g; - $courseid=~s/^(\w)/\/$1/; my $hashid="$udom:$uname:$courseid"; my ($grouplist,$cached)=&is_cached_new('getgroups',$hashid); @@ -4051,7 +4513,8 @@ sub get_users_groups { @usersgroups = split(/:/,$grouplist); } else { $grouplist = ''; - my %roleshash = &dump('roles',$udom,$uname,$courseid); + my $courseurl = &courseid_to_courseurl($courseid); + my %roleshash = &dump('roles',$udom,$uname,$courseurl); my ($tmp) = keys(%roleshash); if ($tmp=~/^error:/) { &logthis('Error retrieving roles: '.$tmp.' for '.$uname.':'.$udom); @@ -4060,7 +4523,7 @@ sub get_users_groups { '.default_enrollment_end_date'}; my $now = time; foreach my $key (keys(%roleshash)) { - if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) { + if ($key =~ /^\Q$courseurl\E\/(\w+)\_gr$/) { my $group = $1; if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) { my $start = $2; @@ -4090,8 +4553,7 @@ sub get_users_groups { sub devalidate_getgroups_cache { my ($udom,$uname,$cdom,$cnum)=@_; my $courseid = $cdom.'_'.$cnum; - $courseid=~s/\_/\//g; - $courseid=~s/^(\w)/\/$1/; + my $hashid="$udom:$uname:$courseid"; &devalidate_cache_new('getgroups',$hashid); } @@ -4100,6 +4562,9 @@ sub devalidate_getgroups_cache { sub plaintext { my ($short,$type,$cid) = @_; + if ($short =~ /^cr/) { + return (split('/',$short))[-1]; + } if (!defined($cid)) { $cid = $env{'request.course.id'}; } @@ -4127,7 +4592,7 @@ sub assignrole { my $mrole; if ($role =~ /^cr\//) { my $cwosec=$url; - $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/; + $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/; unless (&allowed('ccr',$cwosec)) { &logthis('Refused custom assignrole: '. $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. @@ -4137,7 +4602,7 @@ sub assignrole { $mrole='cr'; } elsif ($role =~ /^gr\//) { my $cwogrp=$url; - $cwogrp=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/; + $cwogrp=~s{^/($match_domain)/($match_courseid)/.*}{$1/$2}; unless (&allowed('mdg',$cwogrp)) { &logthis('Refused group assignrole: '. $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. @@ -4147,7 +4612,7 @@ sub assignrole { $mrole='gr'; } else { my $cwosec=$url; - $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/; + $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/; unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) { &logthis('Refused assignrole: '. $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. @@ -4227,8 +4692,8 @@ sub modifyuser { $umode, $upass, $first, $middle, $last, $gene, $forceid, $desiredhome, $email)=@_; - $udom=~s/\W//g; - $uname=~s/\W//g; + $udom= &LONCAPA::clean_domain($udom); + $uname=&LONCAPA::clean_username($uname); &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. $umode.', '.$first.', '.$middle.', '. $last.', '.$gene.'(forceid: '.$forceid.')'. @@ -4377,8 +4842,8 @@ sub modify_student_enrollment { ['firstname','middlename','lastname', 'generation','id'] ,$udom,$uname); - #foreach (keys(%tmp)) { - # &logthis("key $_ = ".$tmp{$_}); + #foreach my $key (keys(%tmp)) { + # &logthis("key $key = ".$tmp{$key}); #} $first = $tmp{'firstname'} if (!defined($first) || $first eq ''); $middle = $tmp{'middlename'} if (!defined($middle) || $middle eq ''); @@ -4436,8 +4901,8 @@ sub writecoursepref { return 'error: no such course'; } my $cstring=''; - foreach (keys %prefs) { - $cstring.=escape($_).'='.escape($prefs{$_}).'&'; + foreach my $pref (keys(%prefs)) { + $cstring.=&escape($pref).'='.&escape($prefs{$pref}).'&'; } $cstring=~s/\&$//; return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome); @@ -4513,6 +4978,16 @@ ENDINITMAP return '/'.$udom.'/'.$uname; } +sub is_course { + my ($cdom,$cnum) = @_; + my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef, + undef,'.'); + if (exists($courses{$cdom.'_'.$cnum})) { + return 1; + } + return 0; +} + # ---------------------------------------------------------- Assign Custom Role sub assigncustomrole { @@ -4555,18 +5030,13 @@ sub is_locked { $env{'user.domain'},$env{'user.name'}); my ($tmp)=keys(%locked); if ($tmp=~/^error:/) { undef(%locked); } - if (ref($locked{$file_name}) eq 'ARRAY') { $is_locked = 'false'; foreach my $entry (@{$locked{$file_name}}) { if (ref($entry) eq 'ARRAY') { - if ($$entry[0] eq 'access' || $$entry[0] eq 'accesscount') { - next; - } else { - $is_locked = 'true'; - last; - } + $is_locked = 'true'; + last; } } } else { @@ -4574,6 +5044,14 @@ sub is_locked { } } +sub declutter_portfile { + my ($file) = @_; + &logthis("got $file"); + $file =~ s-^(/portfolio/|portfolio/)-/-; + &logthis("ret $file"); + return $file; +} + # ------------------------------------------------------------- Mark as Read Only sub mark_as_readonly { @@ -4582,6 +5060,7 @@ sub mark_as_readonly { my ($tmp)=keys(%current_permissions); if ($tmp=~/^error:/) { undef(%current_permissions); } foreach my $file (@{$files}) { + $file = &declutter_portfile($file); push(@{$current_permissions{$file}},$what); } &put('file_permissions',\%current_permissions,$domain,$user); @@ -4640,20 +5119,20 @@ sub files_not_in_path { my $filename = $user."savedfiles"; my @return_files; my $path_part; - open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); - while () { + open(IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); + while (my $line = ) { #ok, I know it's clunky, but I want it to work - my @paths_and_file = split m!/!, $_; - my $file_part = pop (@paths_and_file); - chomp ($file_part); - my $path_part = join ('/', @paths_and_file); + my @paths_and_file = split(m|/|, $line); + my $file_part = pop(@paths_and_file); + chomp($file_part); + my $path_part = join('/', @paths_and_file); $path_part .= '/'; my $path_and_file = $path_part.$file_part; if ($path_part ne $path) { - push (@return_files, ($path_and_file)); + push(@return_files, ($path_and_file)); } } - close (OUT); + close(OUT); return (@return_files); } @@ -4669,38 +5148,128 @@ sub get_portfile_permissions { #---------------------------------------------Get portfolio file access controls -sub get_access_controls { +sub get_access_controls { my ($current_permissions,$group,$file) = @_; - my @access_checks = (); - my %access; + my %access; + my $real_file = $file; + $file =~ s/\.meta$//; if (defined($file)) { - @access_checks = ($file); + if (ref($$current_permissions{$file."\0".'accesscontrol'}) eq 'HASH') { + foreach my $control (keys(%{$$current_permissions{$file."\0".'accesscontrol'}})) { + $access{$real_file}{$control} = $$current_permissions{$file."\0".$control}; + } + } } else { - @access_checks = keys(%{$current_permissions}); + foreach my $key (keys(%{$current_permissions})) { + if ($key =~ /\0accesscontrol$/) { + if (defined($group)) { + if ($key !~ m-^\Q$group\E/-) { + next; + } + } + my ($fullpath) = split(/\0/,$key); + if (ref($$current_permissions{$key}) eq 'HASH') { + foreach my $control (keys(%{$$current_permissions{$key}})) { + $access{$fullpath}{$control}=$$current_permissions{$fullpath."\0".$control}; + } + } + } + } } - foreach my $file_name (@access_checks) { - my $value = $$current_permissions{$file_name}; - if (defined($group)) { - if ($file_name !~ m-^\Q$group\E/-) { - next; + return %access; +} + +sub modify_access_controls { + my ($file_name,$changes,$domain,$user)=@_; + my ($outcome,$deloutcome); + my %store_permissions; + my %new_values; + my %new_control; + my %translation; + my @deletions = (); + my $now = time; + if (exists($$changes{'activate'})) { + if (ref($$changes{'activate'}) eq 'HASH') { + my @newitems = sort(keys(%{$$changes{'activate'}})); + my $numnew = scalar(@newitems); + for (my $i=0; $i<$numnew; $i++) { + my $newkey = $newitems[$i]; + my $newid = &Apache::loncommon::get_cgi_id(); + 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; } } - if (ref($value) eq "ARRAY") { - foreach my $stored_what (@{$value}) { - if (ref($stored_what) eq 'ARRAY') { - if ($$stored_what[0] eq 'access') { - if (!defined($access{$file_name})) { - %{$access{$file_name}} = (); - } - $access{$file_name}{$$stored_what[1]}=$$stored_what[2]; + } + my %todelete; + my %changed_items; + foreach my $action ('delete','update') { + if (exists($$changes{$action})) { + if (ref($$changes{$action}) eq 'HASH') { + foreach my $key (keys(%{$$changes{$action}})) { + my ($itemnum) = ($key =~ /^([^:]+):/); + if ($action eq 'delete') { + $todelete{$itemnum} = 1; } else { - next; + $changed_items{$itemnum} = $key; } } } } } - return %access; + # get lock on access controls for file. + my $lockhash = { + $file_name."\0".'locked_access_records' => $env{'user.name'}. + ':'.$env{'user.domain'}, + }; + my $tries = 0; + my $gotlock = &newput('file_permissions',$lockhash,$domain,$user); + + while (($gotlock ne 'ok') && $tries <3) { + $tries ++; + sleep 1; + $gotlock = &newput('file_permissions',$lockhash,$domain,$user); + } + if ($gotlock eq 'ok') { + my %curr_permissions = &dump('file_permissions',$domain,$user,$file_name); + my ($tmp)=keys(%curr_permissions); + if ($tmp=~/^error:/) { undef(%curr_permissions); } + if (exists($curr_permissions{$file_name."\0".'accesscontrol'})) { + my $curr_controls = $curr_permissions{$file_name."\0".'accesscontrol'}; + if (ref($curr_controls) eq 'HASH') { + foreach my $control_item (keys(%{$curr_controls})) { + my ($itemnum) = ($control_item =~ /^([^:]+):/); + if (defined($todelete{$itemnum})) { + push(@deletions,$file_name."\0".$control_item); + } else { + if (defined($changed_items{$itemnum})) { + $new_control{$changed_items{$itemnum}} = $now; + push(@deletions,$file_name."\0".$control_item); + $new_values{$file_name."\0".$changed_items{$itemnum}} = $$changes{'update'}{$changed_items{$itemnum}}; + } else { + $new_control{$control_item} = $$curr_controls{$control_item}; + } + } + } + } + } + $deloutcome = &del('file_permissions',\@deletions,$domain,$user); + $new_values{$file_name."\0".'accesscontrol'} = \%new_control; + $outcome = &put('file_permissions',\%new_values,$domain,$user); + # remove lock + my @del_lock = ($file_name."\0".'locked_access_records'); + my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user); + } else { + $outcome = "error: could not obtain lockfile\n"; + } + return ($outcome,$deloutcome,\%new_values,\%translation); } #------------------------------------------------------Get Marked as Read Only @@ -4720,13 +5289,8 @@ sub get_marked_as_readonly { if (ref($value) eq "ARRAY"){ foreach my $stored_what (@{$value}) { my $cmp2=$stored_what; - if (ref($stored_what)) { - if ($$stored_what[0] eq 'access' || - $$stored_what[0] eq 'accesscount') { - next; - } else { - $cmp2=join('',@{$stored_what}); - } + if (ref($stored_what) eq 'ARRAY') { + $cmp2=join('',@{$stored_what}); } if ($cmp1 eq $cmp2) { push(@readonly_files, $file_name); @@ -4754,16 +5318,18 @@ sub get_marked_as_readonly_hash { if (ref($value) eq "ARRAY"){ foreach my $stored_what (@{$value}) { if (ref($stored_what) eq 'ARRAY') { - if ($$stored_what[0] eq 'access' || - $$stored_what[0] eq 'accesscount') { - next; + foreach my $lock_descriptor(@{$stored_what}) { + if ($lock_descriptor eq 'graded') { + $readonly_files{$file_name} = 'graded'; + } elsif ($lock_descriptor eq 'handback') { + $readonly_files{$file_name} = 'handback'; + } else { + if (!exists($readonly_files{$file_name})) { + $readonly_files{$file_name} = 'locked'; + } + } } - } - if ($stored_what eq $what) { - $readonly_files{$file_name} = 'locked'; - } elsif (!defined($what)) { - $readonly_files{$file_name} = 'locked'; - } + } } } } @@ -4775,6 +5341,7 @@ sub unmark_as_readonly { # unmarks $file_name (if $file_name is defined), or all files locked by $what # for portfolio submissions, $what contains [$symb,$crsid] my ($domain,$user,$what,$file_name,$group) = @_; + $file_name = &declutter_portfile($file_name); my $symb_crs = $what; if (ref($what)) { $symb_crs=join('',@$what); } my %current_permissions = &dump('file_permissions',$domain,$user,$group); @@ -4782,7 +5349,8 @@ sub unmark_as_readonly { if ($tmp=~/^error:/) { undef(%current_permissions); } my @readonly_files = &get_marked_as_readonly($domain,$user,$what,$group); foreach my $file (@readonly_files) { - if (defined($file_name) && ($file_name ne $file)) { next; } + my $clean_file = &declutter_portfile($file); + if (defined($file_name) && ($file_name ne $clean_file)) { next; } my $current_locks = $current_permissions{$file}; my @new_locks; my @del_keys; @@ -4790,15 +5358,10 @@ sub unmark_as_readonly { foreach my $locker (@{$current_locks}) { my $compare=$locker; if (ref($locker) eq 'ARRAY') { - if ($$locker[0] eq 'access' || - $$locker[0] eq 'accesscount') { - push(@new_locks,$locker); - next; - } $compare=join('',@{$locker}); - } - if ($compare ne $symb_crs) { - push(@new_locks, $locker); + if ($compare ne $symb_crs) { + push(@new_locks, $locker); + } } } if (scalar(@new_locks) > 0) { @@ -4838,28 +5401,27 @@ sub dirlist { if($udom) { if($uname) { - my $listing=reply('ls2:'.$dirRoot.'/'.$uri, - homeserver($uname,$udom)); + my $listing = &reply('ls2:'.$dirRoot.'/'.$uri, + &homeserver($uname,$udom)); my @listing_results; if ($listing eq 'unknown_cmd') { - $listing=reply('ls:'.$dirRoot.'/'.$uri, - homeserver($uname,$udom)); + $listing = &reply('ls:'.$dirRoot.'/'.$uri, + &homeserver($uname,$udom)); @listing_results = split(/:/,$listing); } else { @listing_results = map { &unescape($_); } split(/:/,$listing); } return @listing_results; } elsif(!defined($alternateDirectoryRoot)) { - my $tryserver; - my %allusers=(); - foreach $tryserver (keys %libserv) { + my %allusers; + foreach my $tryserver (keys(%libserv)) { if($hostdom{$tryserver} eq $udom) { - my $listing=reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'. - $udom, $tryserver); + my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'. + $udom, $tryserver); my @listing_results; if ($listing eq 'unknown_cmd') { - $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'. - $udom, $tryserver); + $listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'. + $udom, $tryserver); @listing_results = split(/:/,$listing); } else { @listing_results = @@ -4868,40 +5430,36 @@ sub dirlist { if ($listing_results[0] ne 'no_such_dir' && $listing_results[0] ne 'empty' && $listing_results[0] ne 'con_lost') { - foreach (@listing_results) { - my ($entry,@stat)=split(/&/,$_); - $allusers{$entry}=1; + foreach my $line (@listing_results) { + my ($entry) = split(/&/,$line,2); + $allusers{$entry} = 1; } } } } my $alluserstr=''; - foreach (sort keys %allusers) { - $alluserstr.=$_.'&user:'; + foreach my $user (sort(keys(%allusers))) { + $alluserstr.=$user.'&user:'; } $alluserstr=~s/:$//; return split(/:/,$alluserstr); } else { - my @emptyResults = (); - push(@emptyResults, 'missing user name'); - return split(':',@emptyResults); + return ('missing user name'); } } elsif(!defined($alternateDirectoryRoot)) { my $tryserver; my %alldom=(); - foreach $tryserver (keys %libserv) { + foreach $tryserver (keys(%libserv)) { $alldom{$hostdom{$tryserver}}=1; } my $alldomstr=''; - foreach (sort keys %alldom) { - $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'/&domain:'; + foreach my $domain (sort(keys(%alldom))) { + $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain:'; } $alldomstr=~s/:$//; return split(/:/,$alldomstr); } else { - my @emptyResults = (); - push(@emptyResults, 'missing domain'); - return split(':',@emptyResults); + return ('missing domain'); } } @@ -4919,8 +5477,8 @@ sub dirlist { ## sub GetFileTimestamp { my ($studentDomain,$studentName,$filename,$root)=@_; - $studentDomain=~s/\W//g; - $studentName=~s/\W//g; + $studentDomain = &LONCAPA::clean_domain($studentDomain); + $studentName = &LONCAPA::clean_username($studentName); my $subdir=$studentName.'__'; $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; my $proname="$studentDomain/$subdir/$studentName"; @@ -4938,23 +5496,18 @@ 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) = - ($uri =~ m-/(?:uploaded|editupload)/?([^/]*)/?([^/]*)/?(.*)-); + ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-); $file = 'userfiles/'.$file; $dir = &propath($udom,$uname); } if ($uri =~ m-^/res/-) { ($udom,$uname) = - ($uri =~ m-/(?:res)/?([^/]*)/?([^/]*)/-); + ($uri =~ m-/(?:res)/?($match_domain)/?($match_username)/-); $file = $uri; } @@ -5061,6 +5614,7 @@ sub devalidatecourseresdata { &devalidate_cache_new('courseres',$hashid); } + # --------------------------------------------------- Course Resourcedata Query sub get_courseresdata { @@ -5175,8 +5729,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'}; @@ -5413,6 +5966,9 @@ sub EXT { if (($uname eq $env{'user.name'})&&($udom eq $env{'user.domain'})) { return $env{'environment.'.$spacequalifierrest}; } else { + if ($uname eq 'anonymous' && $udom eq '') { + return ''; + } my %returnhash=&userenvironment($udom,$uname, $spacequalifierrest); return $returnhash{$spacequalifierrest}; @@ -5532,7 +6088,7 @@ sub metadata { (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) || ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) || - ($uri =~ m|home/[^/]+/public_html/|)) { + ($uri =~ m|home/$match_username/public_html/|)) { return undef; } my $filename=$uri; @@ -5563,7 +6119,7 @@ sub metadata { my %metathesekeys=(); unless ($filename=~/\.meta$/) { $filename.='.meta'; } my $metastring; - if ($uri !~ m -^(uploaded|editupload)/-) { + if ($uri !~ m -^(editupload)/-) { my $file=&filelocation('',&clutter($filename)); #push(@{$metaentry{$uri.'.file'}},$file); $metastring=&getfile($file); @@ -5782,6 +6338,17 @@ sub metadata_generate_part0 { } } +# ------------------------------------------------------ Devalidate title cache + +sub devalidate_title_cache { + my ($url)=@_; + if (!$env{'request.course.id'}) { return; } + my $symb=&symbread($url); + if (!$symb) { return; } + my $key=$env{'request.course.id'}."\0".$symb; + &devalidate_cache_new('title',$key); +} + # ------------------------------------------------- Get the title of a resource sub gettitle { @@ -5816,7 +6383,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'}; } @@ -5865,9 +6432,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; } @@ -5891,13 +6455,13 @@ sub symbverify { } if ($ids) { # ------------------------------------------------------------------- Has ID(s) - foreach (split(/\,/,$ids)) { - my ($mapid,$resid)=split(/\./,$_); + foreach my $id (split(/\,/,$ids)) { + my ($mapid,$resid)=split(/\./,$id); if ( &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) eq $symb) { if (($env{'request.role.adv'}) || - $bighash{'encrypted_'.$_} eq $env{'request.enc'}) { + $bighash{'encrypted_'.$id} eq $env{'request.enc'}) { $okay=1; } } @@ -6040,10 +6604,10 @@ sub symbread { } elsif (!$donotrecurse) { # ------------------------------------------ There is more than one possibility my $realpossible=0; - foreach (@possibilities) { - my $file=$bighash{'src_'.$_}; + foreach my $id (@possibilities) { + my $file=$bighash{'src_'.$id}; if (&allowed('bre',$file)) { - my ($mapid,$resid)=split(/\./,$_); + my ($mapid,$resid)=split(/\./,$id); if ($bighash{'map_type_'.$mapid} ne 'page') { $realpossible++; $syval=&encode_symb($bighash{'map_id_'.$mapid}, @@ -6150,7 +6714,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"}; } @@ -6176,7 +6740,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; } } @@ -6184,6 +6748,7 @@ sub rndseed { if (!$domain) { $domain=$wdomain; } if (!$username) { $username=$wusername } my $which=&get_rand_alg(); + if (defined(&getCODE())) { if ($which eq '64bit5') { return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username); @@ -6217,8 +6782,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; } @@ -6238,9 +6803,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"); - if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } + #&logthis("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); + #&logthis("rndseed :$num:$symb"); if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } return "$num1,$num2"; } @@ -6262,8 +6826,9 @@ 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"); + if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); } return "$num1,$num2"; } } @@ -6284,8 +6849,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"; @@ -6308,8 +6873,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"; @@ -6333,8 +6898,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"; @@ -6352,8 +6917,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"; @@ -6414,8 +6979,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+ @@ -6438,10 +7002,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 @@ -6464,7 +7066,7 @@ sub repcopy_userfile { if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); } if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; } my ($cdom,$cnum,$filename) = - ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+([^/]+)/+([^/]+)/+(.*)|); + ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|); my ($info,$rtncode); my $uri="/uploaded/$cdom/$cnum/$filename"; if (-e "$file") { @@ -6565,7 +7167,7 @@ sub readfile { my $fh; open($fh,"<$file"); my $a=''; - while (<$fh>) { $a .=$_; } + while (my $line = <$fh>) { $a .= $line; } return $a; } @@ -6581,12 +7183,12 @@ sub filelocation { if ($file=~m:^/~:) { # is a contruction space reference $location = $file; $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; - } elsif ($file=~m:^/home/[^/]*/public_html/:) { + } elsif ($file=~m{^/home/$match_username/public_html/}) { # is a correct contruction space reference $location = $file; } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file my ($udom,$uname,$filename)= - ($file=~m -^/+(?:uploaded|editupload)/+([^/]+)/+([^/]+)/+(.*)$-); + ($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_name)/+(.*)$-); my $home=&homeserver($uname,$udom); my $is_me=0; my @ids=¤t_machine_ids(); @@ -6623,10 +7225,10 @@ sub hreflocation { } if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) { $file=~s-^\Q$perlvar{'lonDocRoot'}\E--; - } elsif ($file=~m-/home/(\w+)/public_html/-) { - $file=~s-^/home/(\w+)/public_html/-/~$1/-; + } elsif ($file=~m-/home/($match_username)/public_html/-) { + $file=~s-^/home/($match_username)/public_html/-/~$1/-; } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) { - $file=~s-^/home/httpd/lonUsers/([^/]*)/./././([^/]*)/userfiles/ + $file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/ -/uploaded/$1/$2/-x; } return $file; @@ -6704,6 +7306,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)) { @@ -6756,29 +7367,8 @@ BEGIN { # ----------------------------------- Read loncapa.conf and loncapa_apache.conf unless ($readit) { { - # FIXME: Use LONCAPA::Configuration::read_conf here and omit next block - open(my $config,") { - if ($configline=~/\S/ && $configline =~ /^[^\#]*PerlSetVar/) { - my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); - chomp($varvalue); - $perlvar{$varname}=$varvalue; - } - } - close($config); -} -{ - open(my $config,") { - if ($configline =~ /^[^\#]*PerlSetVar/) { - my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); - chomp($varvalue); - $perlvar{$varname}=$varvalue; - } - } - close($config); + my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf'); + %perlvar = (%perlvar,%{$configvars}); } # ------------------------------------------------------------ Read domain file @@ -6788,12 +7378,12 @@ BEGIN { %domain_auth_arg_def = (); my $fh; if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) { - while (<$fh>) { - next if (/^(\#|\s*$)/); + while (my $line = <$fh>) { + next if ($line =~ /^(\#|\s*$)/); # next if /^\#/; - chomp; + chomp $line; my ($domain, $domain_description, $def_auth, $def_auth_arg, - $def_lang, $city, $longi, $lati, $primary) = split(/:/,$_); + $def_lang, $city, $longi, $lati, $primary) = split(/:/,$line,9); $domain_auth_def{$domain}=$def_auth; $domain_auth_arg_def{$domain}=$def_auth_arg; $domaindescription{$domain}=$domain_description; @@ -6860,7 +7450,9 @@ sub get_iphost { while (my $configline=<$config>) { chomp($configline); if ($configline) { - $spareid{$configline}=1; + my ($host,$type) = split(':',$configline,2); + if (!defined($type) || $type eq '') { $type = 'default' }; + push(@{ $spareid{$type} }, $host); } } close($config); @@ -6922,7 +7514,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; @@ -7119,6 +7713,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 @@ -7181,13 +7782,13 @@ passed in @what from the requested user' =item * -allowed($priv,$uri) : check for a user privilege; returns codes for allowed -actions +allowed($priv,$uri,$symb,$role) : check for a user privilege; returns codes for allowed actions F: full access U,I,K: authentication modes (cxx only) '': forbidden 1: user needs to choose course 2: browse allowed + A: passphrase authentication needed =item * @@ -7587,6 +8188,31 @@ cput($namespace,$storehash,$udom,$uname) =item * +newput($namespace,$storehash,$udom,$uname) : + +Attempts to store the items in the $storehash, but only if they don't +currently exist, if this succeeds you can be certain that you have +successfully created a new key value pair in the $namespace db. + + +Args: + $namespace: name of database to store values to + $storehash: hashref to store to the db + $udom: (optional) domain of user containing the db + $uname: (optional) name of user caontaining the db + +Returns: + 'ok' -> succeeded in storing all keys of $storehash + 'key_exists: ' -> failed to anything out of $storehash, as at + least already existed in the db (other + requested keys may also already exist) + 'error: ' -> unable to tie the DB or other erorr occured + 'con_lost' -> unable to contact request server + 'refused' -> action was not allowed by remote machine + + +=item * + eget($namespace,$storearr,$udom,$uname) : returns hash with keys from array reference filled in from namesp (encrypts the return communication) ($udom and $uname are optional) @@ -7596,6 +8222,15 @@ reference filled in from namesp (encrypt log($udom,$name,$home,$message) : write to permanent log for user; use critical subroutine +=item * + +get_dom($namespace,$storearr,$udomain) : returns hash with keys from array +reference filled in from namespace found in domain level on primary domain server ($udomain is optional) + +=item * + +put_dom($namespace,$storehash,$udomain) : stores hash in namespace at domain level on primary domain server ($udomain is optional) + =back =head2 Network Status Functions @@ -7821,6 +8456,94 @@ removeuploadedurl(): convience function Args: url: a full /uploaded/... url to delete +=item * + +get_portfile_permissions(): + Args: + domain: domain of user or course contain the portfolio files + user: name of user or num of course contain the portfolio files + Returns: + hashref of a dump of the proper file_permissions.db + + +=item * + +get_access_controls(): + +Args: + current_permissions: the hash ref returned from get_portfile_permissions() + group: (optional) the group you want the files associated with + file: (optional) the file you want access info on + +Returns: + a hash (keys are file names) of hashes containing + keys are: path to file/file_name\0uniqueID:scope_end_start (see below) + values are XML containing access control settings (see below) + +Internal notes: + + access controls are stored in file_permissions.db as key=value pairs. + key -> path to file/file_name\0uniqueID:scope_end_start + where scope -> public,guest,course,group,domains or users. + end -> UNIX time for end of access (0 -> no end date) + start -> UNIX time for start of access + + value -> XML description of access control + (type =1 of: public,guest,course,group,domains,users"> + + + + for scope type = guest + + for scope type = course or group + + + + +
+ + + + for scope type = domains + + for scope type = users + + + + + + + + Access data is also aggregated for each file in an additional key=value pair: + key -> path to file/file_name\0accesscontrol + value -> reference to hash + hash contains key = value pairs + where key = uniqueID:scope_end_start + value = UNIX time record was last updated + + Used to improve speed of look-ups of access controls for each file. + + Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays. + +modify_access_controls(): + +Modifies access controls for a portfolio file +Args +1. file name +2. reference to hash of required changes, +3. domain +4. username + where domain,username are the domain of the portfolio owner + (either a user or a course) + +Returns: +1. result of additions or updates ('ok' or 'error', with error message). +2. result of deletions ('ok' or 'error', with error message). +3. reference to hash of any new or updated access controls. +4. reference to hash used to map incoming IDs to uniqueIDs assigned to control. + key = integer (inbound ID) + value = uniqueID + =back =head2 HTTP Helper Routines