--- loncom/lonnet/perl/lonnet.pm 2006/06/16 22:37:35 1.749 +++ loncom/lonnet/perl/lonnet.pm 2006/09/29 18:23:25 1.787 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.749 2006/06/16 22:37:35 raeburn Exp $ +# $Id: lonnet.pm,v 1.787 2006/09/29 18:23:25 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -281,9 +281,50 @@ sub critical { return $answer; } -# ------------------------------------------- Transfer profile into environment +# ------------------------------------------- check if return value is an error + +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 { + if ($env_loaded) { return; } + my ($lonidsdir,$handle)=@_; 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; + } } - my $envi; - my %Remove; - for ($envi=0;$envi<=$#profile;$envi++) { - chomp($profile[$envi]); - my ($envname,$envvalue)=split(/=/,$profile[$envi],2); - $envname=&unescape($envname); - $envvalue=&unescape($envvalue); - $env{$envname} = $envvalue; + if ($convert) { + if (!&convert_and_load_session_env($lonidsdir,$handle)) { + &logthis("Failed to load session, or convert session."); + } + } + + my %remove; + while ( my $envname = each(%env) ) { if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) { if ($time < time-300) { - $Remove{$key}++; + $remove{$key}++; } } } + $env{'user.environment'} = "$lonidsdir/$handle.id"; - 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); + untie(%disk_env); } - 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; - } - } - } - { - 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,43 +399,15 @@ 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'; } @@ -482,41 +464,60 @@ 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 { @@ -880,6 +881,7 @@ sub save_cache { &purge_remembered(); #&Apache::loncommon::validate_page(); undef(%env); + undef($env_loaded); } my $to_remember=-1; @@ -1165,7 +1167,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 +1175,24 @@ 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 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 +1204,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'}); @@ -1874,9 +1894,6 @@ sub get_course_adv_roles { (!$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; @@ -2837,7 +2854,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/\w+/\w+/\w+)\.(/\w+/\w+)(/?\w*)-) { $trole = $1; $area = $2; $sec = $3; @@ -2922,23 +2939,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 @@ -3207,6 +3226,218 @@ 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 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)\./([^/]+)/([^/]+)/?([^/]*)$-) { + 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/(\w+/\w+/\w*)./([^/]+)/([^/]+)/?([^/]*)$-) { + 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/([^/]+)/([^/]+)/portfolio(/.+)$-) { + $type = 1; + $udom = $1; + $unum = $2; + $file_name = $3; + } elsif ($url =~ m-^/*uploaded/([^/]+)/([^/]+)/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)); +} + # ---------------------------------------------- Custom access rule evaluation sub customaccess { @@ -3252,8 +3483,9 @@ sub allowed { 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'; } @@ -3264,7 +3496,7 @@ sub allowed { 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 +3508,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 +3584,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 +3610,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/) { @@ -3528,7 +3767,11 @@ sub allowed { # unless ($env{'request.course.id'}) { - return '1'; + if ($thisallowed eq 'A') { + return 'A'; + } else { + return '1'; + } } # @@ -3591,6 +3834,9 @@ sub allowed { } } + if ($thisallowed eq 'A') { + return 'A'; + } return 'F'; } @@ -3837,7 +4083,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 +4094,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); @@ -3956,33 +4202,49 @@ sub auto_photoupdate { sub auto_instcode_format { 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) { 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{$_}).'&'; } 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_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; } @@ -4100,6 +4362,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'}; } @@ -4569,6 +4834,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 { @@ -4577,6 +4850,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); @@ -4666,11 +4940,13 @@ sub get_portfile_permissions { sub get_access_controls { my ($current_permissions,$group,$file) = @_; - my %access; + my %access; + my $real_file = $file; + $file =~ s/\.meta$//; if (defined($file)) { if (ref($$current_permissions{$file."\0".'accesscontrol'}) eq 'HASH') { foreach my $control (keys(%{$$current_permissions{$file."\0".'accesscontrol'}})) { - $access{$file}{$control} = $$current_permissions{$file."\0".$control}; + $access{$real_file}{$control} = $$current_permissions{$file."\0".$control}; } } } else { @@ -4693,25 +4969,6 @@ sub get_access_controls { return %access; } -sub parse_access_controls { - my ($access_item) = @_; - my %content; - my $token; - my $parser=HTML::TokeParser->new(\$access_item); - while ($token=$parser->get_token) { - if ($token->[0] eq 'S') { - my $entry=$token->[1]; - if ($entry eq 'scope') { - my $type = $token->[2]{'type'}; - } else { - my $value=$parser->get_text('/'.$entry); - $content{$entry}=$value; - } - } - } - return %content; -} - sub modify_access_controls { my ($file_name,$changes,$domain,$user)=@_; my ($outcome,$deloutcome); @@ -4817,7 +5074,7 @@ sub get_marked_as_readonly { if (ref($value) eq "ARRAY"){ foreach my $stored_what (@{$value}) { my $cmp2=$stored_what; - if (ref($stored_what eq 'ARRAY')) { + if (ref($stored_what) eq 'ARRAY') { $cmp2=join('',@{$stored_what}); } if ($cmp1 eq $cmp2) { @@ -4846,12 +5103,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 eq $what) { - $readonly_files{$file_name} = 'locked'; - } elsif (!defined($what)) { - $readonly_files{$file_name} = 'locked'; + 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'; + } + } } - } + } } } } @@ -4863,6 +5126,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); @@ -4870,7 +5134,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; @@ -5021,13 +5286,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) = @@ -5144,6 +5404,7 @@ sub devalidatecourseresdata { &devalidate_cache_new('courseres',$hashid); } + # --------------------------------------------------- Course Resourcedata Query sub get_courseresdata { @@ -5496,6 +5757,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}; @@ -5646,7 +5910,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); @@ -5865,6 +6129,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 { @@ -5948,9 +6223,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; } @@ -6787,6 +7059,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)) { @@ -6839,29 +7120,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 @@ -6943,7 +7203,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); @@ -7271,6 +7533,7 @@ actions '': forbidden 1: user needs to choose course 2: browse allowed + A: passphrase authentication needed =item * @@ -7998,15 +8261,6 @@ Internal notes: Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays. -parse_access_controls(): - -Parses XML of an access control record -Args -1. Text string (XML) of access comtrol record - -Returns: -1. Hash of access control settings. - modify_access_controls(): Modifies access controls for a portfolio file