|
version 1.1172.2.64, 2015/04/09 18:24:44
|
version 1.1172.2.91, 2017/03/13 20:59:59
|
|
Line 89 use GDBM_File;
|
Line 89 use GDBM_File;
|
| use HTML::LCParser; |
use HTML::LCParser; |
| use Fcntl qw(:flock); |
use Fcntl qw(:flock); |
| use Storable qw(thaw nfreeze); |
use Storable qw(thaw nfreeze); |
| use Time::HiRes qw( gettimeofday tv_interval ); |
use Time::HiRes qw( sleep gettimeofday tv_interval ); |
| use Cache::Memcached; |
use Cache::Memcached; |
| use Digest::MD5; |
use Digest::MD5; |
| use Math::Random; |
use Math::Random; |
|
Line 102 use LONCAPA::Lond;
|
Line 102 use LONCAPA::Lond;
|
| use File::Copy; |
use File::Copy; |
| |
|
| my $readit; |
my $readit; |
| my $max_connection_retries = 10; # Or some such value. |
my $max_connection_retries = 20; # Or some such value. |
| |
|
| require Exporter; |
require Exporter; |
| |
|
|
Line 370 sub subreply {
|
Line 370 sub subreply {
|
| |
|
| my $lockfile=$peerfile.".lock"; |
my $lockfile=$peerfile.".lock"; |
| while (-e $lockfile) { # Need to wait for the lockfile to disappear. |
while (-e $lockfile) { # Need to wait for the lockfile to disappear. |
| sleep(1); |
sleep(0.1); |
| } |
} |
| # At this point, either a loncnew parent is listening or an old lonc |
# At this point, either a loncnew parent is listening or an old lonc |
| # or loncnew child is listening so we can connect or everything's dead. |
# or loncnew child is listening so we can connect or everything's dead. |
|
Line 388 sub subreply {
|
Line 388 sub subreply {
|
| } else { |
} else { |
| &create_connection(&hostname($server),$server); |
&create_connection(&hostname($server),$server); |
| } |
} |
| sleep(1); # Try again later if failed connection. |
sleep(0.1); # Try again later if failed connection. |
| } |
} |
| my $answer; |
my $answer; |
| if ($client) { |
if ($client) { |
|
Line 417 sub reply {
|
Line 417 sub reply {
|
| |
|
| sub reconlonc { |
sub reconlonc { |
| my ($lonid) = @_; |
my ($lonid) = @_; |
| my $hostname = &hostname($lonid); |
|
| if ($lonid) { |
if ($lonid) { |
| |
my $hostname = &hostname($lonid); |
| my $peerfile="$perlvar{'lonSockDir'}/$hostname"; |
my $peerfile="$perlvar{'lonSockDir'}/$hostname"; |
| if ($hostname && -e $peerfile) { |
if ($hostname && -e $peerfile) { |
| &logthis("Trying to reconnect lonc for $lonid ($hostname)"); |
&logthis("Trying to reconnect lonc for $lonid ($hostname)"); |
|
Line 464 sub critical {
|
Line 464 sub critical {
|
| } |
} |
| my $answer=reply($cmd,$server); |
my $answer=reply($cmd,$server); |
| if ($answer eq 'con_lost') { |
if ($answer eq 'con_lost') { |
| &reconlonc("$perlvar{'lonSockDir'}/$server"); |
&reconlonc($server); |
| my $answer=reply($cmd,$server); |
my $answer=reply($cmd,$server); |
| if ($answer eq 'con_lost') { |
if ($answer eq 'con_lost') { |
| my $now=time; |
my $now=time; |
|
Line 481 sub critical {
|
Line 481 sub critical {
|
| close($dfh); |
close($dfh); |
| } |
} |
| } |
} |
| sleep 2; |
sleep 1; |
| my $wcmd=''; |
my $wcmd=''; |
| { |
{ |
| my $dfh; |
my $dfh; |
|
Line 1002 sub choose_server {
|
Line 1002 sub choose_server {
|
| if ($login_host ne '') { |
if ($login_host ne '') { |
| $hostname = &hostname($login_host); |
$hostname = &hostname($login_host); |
| } |
} |
| return ($login_host,$hostname,$portal_path,$isredirect); |
return ($login_host,$hostname,$portal_path,$isredirect,$lowest_load); |
| } |
} |
| |
|
| # --------------------------------------------- Try to change a user's password |
# --------------------------------------------- Try to change a user's password |
|
Line 1274 sub get_lonbalancer_config {
|
Line 1274 sub get_lonbalancer_config {
|
| } |
} |
| |
|
| sub check_loadbalancing { |
sub check_loadbalancing { |
| my ($uname,$udom) = @_; |
my ($uname,$udom,$caller) = @_; |
| my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom, |
my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom, |
| $rule_in_effect,$offloadto,$otherserver); |
$rule_in_effect,$offloadto,$otherserver); |
| my $lonhost = $perlvar{'lonHostID'}; |
my $lonhost = $perlvar{'lonHostID'}; |
|
Line 1283 sub check_loadbalancing {
|
Line 1283 sub check_loadbalancing {
|
| my $uintdom = &Apache::lonnet::internet_dom($uprimary_id); |
my $uintdom = &Apache::lonnet::internet_dom($uprimary_id); |
| my $intdom = &Apache::lonnet::internet_dom($lonhost); |
my $intdom = &Apache::lonnet::internet_dom($lonhost); |
| my $serverhomedom = &host_domain($lonhost); |
my $serverhomedom = &host_domain($lonhost); |
| |
my $domneedscache; |
| my $cachetime = 60*60*24; |
my $cachetime = 60*60*24; |
| |
|
| if (($uintdom ne '') && ($uintdom eq $intdom)) { |
if (($uintdom ne '') && ($uintdom eq $intdom)) { |
|
Line 1298 sub check_loadbalancing {
|
Line 1298 sub check_loadbalancing {
|
| &Apache::lonnet::get_dom('configuration',['loadbalancing'],$dom_in_use); |
&Apache::lonnet::get_dom('configuration',['loadbalancing'],$dom_in_use); |
| if (ref($domconfig{'loadbalancing'}) eq 'HASH') { |
if (ref($domconfig{'loadbalancing'}) eq 'HASH') { |
| $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime); |
$result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime); |
| |
} else { |
| |
$domneedscache = $dom_in_use; |
| } |
} |
| } |
} |
| if (ref($result) eq 'HASH') { |
if (ref($result) eq 'HASH') { |
|
Line 1356 sub check_loadbalancing {
|
Line 1358 sub check_loadbalancing {
|
| my %domconfig = |
my %domconfig = |
| &Apache::lonnet::get_dom('configuration',['loadbalancing'],$serverhomedom); |
&Apache::lonnet::get_dom('configuration',['loadbalancing'],$serverhomedom); |
| if (ref($domconfig{'loadbalancing'}) eq 'HASH') { |
if (ref($domconfig{'loadbalancing'}) eq 'HASH') { |
| $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime); |
$result = &do_cache_new('loadbalancing',$serverhomedom,$domconfig{'loadbalancing'},$cachetime); |
| |
} else { |
| |
$domneedscache = $serverhomedom; |
| } |
} |
| } |
} |
| if (ref($result) eq 'HASH') { |
if (ref($result) eq 'HASH') { |
|
Line 1376 sub check_loadbalancing {
|
Line 1380 sub check_loadbalancing {
|
| $is_balancer = 1; |
$is_balancer = 1; |
| $offloadto = &this_host_spares($dom_in_use); |
$offloadto = &this_host_spares($dom_in_use); |
| } |
} |
| |
unless (defined($cached)) { |
| |
$domneedscache = $serverhomedom; |
| |
} |
| } |
} |
| } else { |
} else { |
| if ($perlvar{'lonBalancer'} eq 'yes') { |
if ($perlvar{'lonBalancer'} eq 'yes') { |
| $is_balancer = 1; |
$is_balancer = 1; |
| $offloadto = &this_host_spares($dom_in_use); |
$offloadto = &this_host_spares($dom_in_use); |
| } |
} |
| |
unless (defined($cached)) { |
| |
$domneedscache = $serverhomedom; |
| |
} |
| |
} |
| |
if ($domneedscache) { |
| |
&do_cache_new('loadbalancing',$domneedscache,$is_balancer,$cachetime); |
| } |
} |
| if ($is_balancer) { |
if ($is_balancer) { |
| my $lowest_load = 30000; |
my $lowest_load = 30000; |
|
Line 1412 sub check_loadbalancing {
|
Line 1425 sub check_loadbalancing {
|
| } |
} |
| } |
} |
| } |
} |
| if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) { |
unless ($caller eq 'login') { |
| $is_balancer = 0; |
if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) { |
| if ($uname ne '' && $udom ne '') { |
$is_balancer = 0; |
| if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) { |
if ($uname ne '' && $udom ne '') { |
| |
if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) { |
| |
|
| &appenv({'user.loadbalexempt' => $lonhost, |
&appenv({'user.loadbalexempt' => $lonhost, |
| 'user.loadbalcheck.time' => time}); |
'user.loadbalcheck.time' => time}); |
| |
} |
| } |
} |
| } |
} |
| } |
} |
|
Line 1554 sub idget {
|
Line 1569 sub idget {
|
| |
|
| my %servers = &get_servers($udom,'library'); |
my %servers = &get_servers($udom,'library'); |
| foreach my $tryserver (keys(%servers)) { |
foreach my $tryserver (keys(%servers)) { |
| my $idlist=join('&',@ids); |
my $idlist=join('&', map { &escape($_); } @ids); |
| $idlist=~tr/A-Z/a-z/; |
$idlist=~tr/A-Z/a-z/; |
| my $reply=&reply("idget:$udom:".$idlist,$tryserver); |
my $reply=&reply("idget:$udom:".$idlist,$tryserver); |
| my @answer=(); |
my @answer=(); |
|
Line 1564 sub idget {
|
Line 1579 sub idget {
|
| my $i; |
my $i; |
| for ($i=0;$i<=$#ids;$i++) { |
for ($i=0;$i<=$#ids;$i++) { |
| if ($answer[$i]) { |
if ($answer[$i]) { |
| $returnhash{$ids[$i]}=$answer[$i]; |
$returnhash{$ids[$i]}=&unescape($answer[$i]); |
| } |
} |
| } |
} |
| } |
} |
|
Line 1793 sub retrieve_inst_usertypes {
|
Line 1808 sub retrieve_inst_usertypes {
|
| |
|
| sub is_domainimage { |
sub is_domainimage { |
| my ($url) = @_; |
my ($url) = @_; |
| if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo)/+-) { |
if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo)/+[^/]-) { |
| if (&domain($1) ne '') { |
if (&domain($1) ne '') { |
| return '1'; |
return '1'; |
| } |
} |
|
Line 1934 sub get_instuser {
|
Line 1949 sub get_instuser {
|
| return ($outcome,%userinfo); |
return ($outcome,%userinfo); |
| } |
} |
| |
|
| |
sub get_multiple_instusers { |
| |
my ($udom,$users,$caller) = @_; |
| |
my ($outcome,$results); |
| |
if (ref($users) eq 'HASH') { |
| |
my $count = keys(%{$users}); |
| |
my $requested = &freeze_escape($users); |
| |
my $homeserver = &domain($udom,'primary'); |
| |
if ($homeserver ne '') { |
| |
my $queryid=&reply('querysend:getmultinstusers:::'.$caller.'='.$requested,$homeserver); |
| |
my $host=&hostname($homeserver); |
| |
if ($queryid !~/^\Q$host\E\_/) { |
| |
&logthis('get_multiple_instusers invalid queryid: '.$queryid. |
| |
' for host: '.$homeserver.'in domain '.$udom); |
| |
return ($outcome,$results); |
| |
} |
| |
my $response = &get_query_reply($queryid); |
| |
my $maxtries = 5; |
| |
if ($count > 100) { |
| |
$maxtries = 1+int($count/20); |
| |
} |
| |
my $tries = 1; |
| |
while (($response=~/^timeout/) && ($tries <= $maxtries)) { |
| |
$response = &get_query_reply($queryid); |
| |
$tries ++; |
| |
} |
| |
if ($response eq '') { |
| |
$results = {}; |
| |
foreach my $key (keys(%{$users})) { |
| |
my ($uname,$id); |
| |
if ($caller eq 'id') { |
| |
$id = $key; |
| |
} else { |
| |
$uname = $key; |
| |
} |
| |
my ($resp,%info) = &get_instuser($udom,$uname,$id); |
| |
$outcome = $resp; |
| |
if ($resp eq 'ok') { |
| |
%{$results} = (%{$results}, %info); |
| |
} else { |
| |
last; |
| |
} |
| |
} |
| |
} elsif(!&error($response) && ($response ne 'refused')) { |
| |
if (($response eq 'unavailable') || ($response eq 'invalid') || ($response eq 'timeout')) { |
| |
$outcome = $response; |
| |
} else { |
| |
($outcome,my $userdata) = split(/=/,$response,2); |
| |
if ($outcome eq 'ok') { |
| |
$results = &thaw_unescape($userdata); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return ($outcome,$results); |
| |
} |
| |
|
| sub inst_rulecheck { |
sub inst_rulecheck { |
| my ($udom,$uname,$id,$item,$rules) = @_; |
my ($udom,$uname,$id,$item,$rules) = @_; |
| my %returnhash; |
my %returnhash; |
|
Line 2030 sub get_domain_defaults {
|
Line 2102 sub get_domain_defaults {
|
| 'requestcourses','inststatus', |
'requestcourses','inststatus', |
| 'coursedefaults','usersessions', |
'coursedefaults','usersessions', |
| 'requestauthor','selfenrollment', |
'requestauthor','selfenrollment', |
| 'coursecategories'],$domain); |
'coursecategories','autoenroll', |
| |
'helpsettings'],$domain); |
| my @coursetypes = ('official','unofficial','community','textbook'); |
my @coursetypes = ('official','unofficial','community','textbook'); |
| if (ref($domconfig{'defaults'}) eq 'HASH') { |
if (ref($domconfig{'defaults'}) eq 'HASH') { |
| $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; |
$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; |
|
Line 2039 sub get_domain_defaults {
|
Line 2112 sub get_domain_defaults {
|
| $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'}; |
$domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'}; |
| $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'}; |
$domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'}; |
| $domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'}; |
$domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'}; |
| |
$domdefaults{'intauth_cost'} = $domconfig{'defaults'}{'intauth_cost'}; |
| |
$domdefaults{'intauth_switch'} = $domconfig{'defaults'}{'intauth_switch'}; |
| |
$domdefaults{'intauth_check'} = $domconfig{'defaults'}{'intauth_check'}; |
| } else { |
} else { |
| $domdefaults{'lang_def'} = &domain($domain,'lang_def'); |
$domdefaults{'lang_def'} = &domain($domain,'lang_def'); |
| $domdefaults{'auth_def'} = &domain($domain,'auth_def'); |
$domdefaults{'auth_def'} = &domain($domain,'auth_def'); |
|
Line 2095 sub get_domain_defaults {
|
Line 2171 sub get_domain_defaults {
|
| } |
} |
| } |
} |
| } |
} |
| |
if (ref($domconfig{'coursedefaults'}{'canclone'}) eq 'HASH') { |
| |
if (ref($domconfig{'coursedefaults'}{'canclone'}{'instcode'}) eq 'ARRAY') { |
| |
my @clonecodes = @{$domconfig{'coursedefaults'}{'canclone'}{'instcode'}}; |
| |
if (@clonecodes) { |
| |
$domdefaults{'canclone'} = join('+',@clonecodes); |
| |
} |
| |
} |
| |
} elsif ($domconfig{'coursedefaults'}{'canclone'}) { |
| |
$domdefaults{'canclone'}=$domconfig{'coursedefaults'}{'canclone'}; |
| |
} |
| } |
} |
| if (ref($domconfig{'usersessions'}) eq 'HASH') { |
if (ref($domconfig{'usersessions'}) eq 'HASH') { |
| if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') { |
if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') { |
|
Line 2145 sub get_domain_defaults {
|
Line 2231 sub get_domain_defaults {
|
| $domdefaults{'catunauth'} = $domconfig{'coursecategories'}{'unauth'}; |
$domdefaults{'catunauth'} = $domconfig{'coursecategories'}{'unauth'}; |
| } |
} |
| } |
} |
| |
if (ref($domconfig{'autoenroll'}) eq 'HASH') { |
| |
$domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'}; |
| |
} |
| |
if (ref($domconfig{'helpsettings'}) eq 'HASH') { |
| |
$domdefaults{'submitbugs'} = $domconfig{'helpsettings'}{'submitbugs'}; |
| |
if (ref($domconfig{'helpsettings'}{'adhoc'}) eq 'HASH') { |
| |
$domdefaults{'adhocroles'} = $domconfig{'helpsettings'}{'adhoc'}; |
| |
} |
| |
} |
| &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime); |
&do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime); |
| return %domdefaults; |
return %domdefaults; |
| } |
} |
|
Line 2385 sub make_key {
|
Line 2480 sub make_key {
|
| sub devalidate_cache_new { |
sub devalidate_cache_new { |
| my ($name,$id,$debug) = @_; |
my ($name,$id,$debug) = @_; |
| if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); } |
if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); } |
| |
my $remembered_id=$name.':'.$id; |
| $id=&make_key($name,$id); |
$id=&make_key($name,$id); |
| $memcache->delete($id); |
$memcache->delete($id); |
| delete($remembered{$id}); |
delete($remembered{$remembered_id}); |
| delete($accessed{$id}); |
delete($accessed{$remembered_id}); |
| } |
} |
| |
|
| sub is_cached_new { |
sub is_cached_new { |
| my ($name,$id,$debug) = @_; |
my ($name,$id,$debug) = @_; |
| $id=&make_key($name,$id); |
my $remembered_id=$name.':'.$id; # this is to avoid make_key (which is slow) for |
| if (exists($remembered{$id})) { |
# keys in %remembered hash, which persists for |
| if ($debug) { &Apache::lonnet::logthis("Early return $id of $remembered{$id} "); } |
# duration of request (no restriction on key length). |
| $accessed{$id}=[&gettimeofday()]; |
if (exists($remembered{$remembered_id})) { |
| |
if ($debug) { &Apache::lonnet::logthis("Early return $remembered_id of $remembered{$remembered_id} "); } |
| |
$accessed{$remembered_id}=[&gettimeofday()]; |
| $hits++; |
$hits++; |
| return ($remembered{$id},1); |
return ($remembered{$remembered_id},1); |
| } |
} |
| |
$id=&make_key($name,$id); |
| my $value = $memcache->get($id); |
my $value = $memcache->get($id); |
| if (!(defined($value))) { |
if (!(defined($value))) { |
| if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); } |
if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); } |
|
Line 2409 sub is_cached_new {
|
Line 2508 sub is_cached_new {
|
| if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); } |
if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); } |
| $value=undef; |
$value=undef; |
| } |
} |
| &make_room($id,$value,$debug); |
&make_room($remembered_id,$value,$debug); |
| if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); } |
if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); } |
| return ($value,1); |
return ($value,1); |
| } |
} |
| |
|
| sub do_cache_new { |
sub do_cache_new { |
| my ($name,$id,$value,$time,$debug) = @_; |
my ($name,$id,$value,$time,$debug) = @_; |
| |
my $remembered_id=$name.':'.$id; |
| $id=&make_key($name,$id); |
$id=&make_key($name,$id); |
| my $setvalue=$value; |
my $setvalue=$value; |
| if (!defined($setvalue)) { |
if (!defined($setvalue)) { |
|
Line 2431 sub do_cache_new {
|
Line 2531 sub do_cache_new {
|
| $memcache->disconnect_all(); |
$memcache->disconnect_all(); |
| } |
} |
| # need to make a copy of $value |
# need to make a copy of $value |
| &make_room($id,$value,$debug); |
&make_room($remembered_id,$value,$debug); |
| return $value; |
return $value; |
| } |
} |
| |
|
| sub make_room { |
sub make_room { |
| my ($id,$value,$debug)=@_; |
my ($remembered_id,$value,$debug)=@_; |
| |
|
| $remembered{$id}= (ref($value)) ? &Storable::dclone($value) |
$remembered{$remembered_id}= (ref($value)) ? &Storable::dclone($value) |
| : $value; |
: $value; |
| if ($to_remember<0) { return; } |
if ($to_remember<0) { return; } |
| $accessed{$id}=[&gettimeofday()]; |
$accessed{$remembered_id}=[&gettimeofday()]; |
| if (scalar(keys(%remembered)) <= $to_remember) { return; } |
if (scalar(keys(%remembered)) <= $to_remember) { return; } |
| my $to_kick; |
my $to_kick; |
| my $max_time=0; |
my $max_time=0; |
|
Line 3820 sub flushcourselogs {
|
Line 3920 sub flushcourselogs {
|
| } |
} |
| } |
} |
| # |
# |
| # Reverse lookup of domain roles (dc, ad, li, sc, au) |
# Reverse lookup of domain roles (dc, ad, li, sc, dh, da, au) |
| # |
# |
| my %domrolebuffer = (); |
my %domrolebuffer = (); |
| foreach my $entry (keys(%domainrolehash)) { |
foreach my $entry (keys(%domainrolehash)) { |
|
Line 3835 sub flushcourselogs {
|
Line 3935 sub flushcourselogs {
|
| delete $domainrolehash{$entry}; |
delete $domainrolehash{$entry}; |
| } |
} |
| foreach my $dom (keys(%domrolebuffer)) { |
foreach my $dom (keys(%domrolebuffer)) { |
| my %servers = &get_servers($dom,'library'); |
my %servers; |
| |
if (defined(&domain($dom,'primary'))) { |
| |
my $primary=&domain($dom,'primary'); |
| |
my $hostname=&hostname($primary); |
| |
$servers{$primary} = $hostname; |
| |
} else { |
| |
%servers = &get_servers($dom,'library'); |
| |
} |
| foreach my $tryserver (keys(%servers)) { |
foreach my $tryserver (keys(%servers)) { |
| unless (&reply('domroleput:'.$dom.':'. |
if (&reply('domroleput:'.$dom.':'. |
| $domrolebuffer{$dom},$tryserver) eq 'ok') { |
$domrolebuffer{$dom},$tryserver) eq 'ok') { |
| |
last; |
| |
} else { |
| &logthis('Put of domain roles failed for '.$dom.' and '.$tryserver); |
&logthis('Put of domain roles failed for '.$dom.' and '.$tryserver); |
| } |
} |
| } |
} |
|
Line 3958 sub userrolelog {
|
Line 4067 sub userrolelog {
|
| {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'} |
{$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'} |
| =$tend.':'.$tstart; |
=$tend.':'.$tstart; |
| } |
} |
| if ($trole =~ /^(dc|ad|li|au|dg|sc)/ ) { |
if ($trole =~ /^(dc|ad|li|au|dg|sc|dh|da)/ ) { |
| my (undef,$rudom,$runame,$rsec)=split(/\//,$area); |
my (undef,$rudom,$runame,$rsec)=split(/\//,$area); |
| $domainrolehash |
$domainrolehash |
| {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} |
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} |
|
Line 4185 sub get_my_roles {
|
Line 4294 sub get_my_roles {
|
| return %returnhash; |
return %returnhash; |
| } |
} |
| |
|
| |
sub get_all_adhocroles { |
| |
my ($dom) = @_; |
| |
my @roles_by_num = (); |
| |
my %domdefaults = &get_domain_defaults($dom); |
| |
my (%description,%access_in_dom,%access_info); |
| |
if (ref($domdefaults{'adhocroles'}) eq 'HASH') { |
| |
my $count = 0; |
| |
my %domcurrent = %{$domdefaults{'adhocroles'}}; |
| |
my %ordered; |
| |
foreach my $role (sort(keys(%domcurrent))) { |
| |
my ($order,$desc,$access_in_dom); |
| |
if (ref($domcurrent{$role}) eq 'HASH') { |
| |
$order = $domcurrent{$role}{'order'}; |
| |
$desc = $domcurrent{$role}{'desc'}; |
| |
$access_in_dom{$role} = $domcurrent{$role}{'access'}; |
| |
$access_info{$role} = $domcurrent{$role}{$access_in_dom{$role}}; |
| |
} |
| |
if ($order eq '') { |
| |
$order = $count; |
| |
} |
| |
$ordered{$order} = $role; |
| |
if ($desc ne '') { |
| |
$description{$role} = $desc; |
| |
} else { |
| |
$description{$role}= $role; |
| |
} |
| |
$count++; |
| |
} |
| |
foreach my $item (sort {$a <=> $b } (keys(%ordered))) { |
| |
push(@roles_by_num,$ordered{$item}); |
| |
} |
| |
} |
| |
return (\@roles_by_num,\%description,\%access_in_dom,\%access_info); |
| |
} |
| |
|
| |
sub get_my_adhocroles { |
| |
my ($cid,$checkreg) = @_; |
| |
my ($cdom,$cnum,%info,@possroles,$description,$roles_by_num); |
| |
if ($env{'request.course.id'} eq $cid) { |
| |
$cdom = $env{'course.'.$cid.'.domain'}; |
| |
$cnum = $env{'course.'.$cid.'.num'}; |
| |
$info{'internal.coursecode'} = $env{'course.'.$cid.'.internal.coursecode'}; |
| |
} elsif ($cid =~ /^($match_domain)_($match_courseid)$/) { |
| |
$cdom = $1; |
| |
$cnum = $2; |
| |
%info = &Apache::lonnet::get('environment',['internal.coursecode'], |
| |
$cdom,$cnum); |
| |
} |
| |
if (($info{'internal.coursecode'} ne '') && ($checkreg)) { |
| |
my $user = $env{'user.name'}.':'.$env{'user.domain'}; |
| |
my %rosterhash = &get('classlist',[$user],$cdom,$cnum); |
| |
if ($rosterhash{$user} ne '') { |
| |
my $type = (split(/:/,$rosterhash{$user}))[5]; |
| |
return ([],{}) if ($type eq 'auto'); |
| |
} |
| |
} |
| |
if (($cdom ne '') && ($cnum ne '')) { |
| |
if (($env{"user.role.dh./$cdom/"}) || ($env{"user.role.da./$cdom/"})) { |
| |
my $then=$env{'user.login.time'}; |
| |
my $update=$env{'user.update.time'}; |
| |
if (!$update) { |
| |
$update = $then; |
| |
} |
| |
my @liveroles; |
| |
foreach my $role ('dh','da') { |
| |
if ($env{"user.role.$role./$cdom/"}) { |
| |
my ($tstart,$tend)=split(/\./,$env{"user.role.$role./$cdom/"}); |
| |
my $limit = $update; |
| |
if ($env{'request.role'} eq "$role./$cdom/") { |
| |
$limit = $then; |
| |
} |
| |
my $activerole = 1; |
| |
if ($tstart && $tstart>$limit) { $activerole = 0; } |
| |
if ($tend && $tend <$limit) { $activerole = 0; } |
| |
if ($activerole) { |
| |
push(@liveroles,$role); |
| |
} |
| |
} |
| |
} |
| |
if (@liveroles) { |
| |
if (&homeserver($cnum,$cdom) ne 'no_host') { |
| |
my ($accessref,$accessinfo,%access_in_dom); |
| |
($roles_by_num,$description,$accessref,$accessinfo) = &get_all_adhocroles($cdom); |
| |
if (ref($roles_by_num) eq 'ARRAY') { |
| |
if (@{$roles_by_num}) { |
| |
my %settings; |
| |
if ($env{'request.course.id'} eq $cid) { |
| |
foreach my $envkey (keys(%env)) { |
| |
if ($envkey =~ /^\Qcourse.$cid.\E(internal\.adhoc.+)$/) { |
| |
$settings{$1} = $env{$envkey}; |
| |
} |
| |
} |
| |
} else { |
| |
%settings = &dump('environment',$cdom,$cnum,'internal\.adhoc'); |
| |
} |
| |
my %setincrs; |
| |
if ($settings{'internal.adhocaccess'}) { |
| |
map { $setincrs{$_} = 1; } split(/,/,$settings{'internal.adhocaccess'}); |
| |
} |
| |
my @statuses; |
| |
if ($env{'environment.inststatus'}) { |
| |
@statuses = split(/,/,$env{'environment.inststatus'}); |
| |
} |
| |
my $user = $env{'user.name'}.':'.$env{'user.domain'}; |
| |
if (ref($accessref) eq 'HASH') { |
| |
%access_in_dom = %{$accessref}; |
| |
} |
| |
foreach my $role (@{$roles_by_num}) { |
| |
my ($curraccess,@okstatus,@personnel); |
| |
if ($setincrs{$role}) { |
| |
($curraccess,my $rest) = split(/=/,$settings{'internal.adhoc.'.$role}); |
| |
if ($curraccess eq 'status') { |
| |
@okstatus = split(/\&/,$rest); |
| |
} elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) { |
| |
@personnel = split(/\&/,$rest); |
| |
} |
| |
} else { |
| |
$curraccess = $access_in_dom{$role}; |
| |
if (ref($accessinfo) eq 'HASH') { |
| |
if ($curraccess eq 'status') { |
| |
if (ref($accessinfo->{$role}) eq 'ARRAY') { |
| |
@okstatus = @{$accessinfo->{$role}}; |
| |
} |
| |
} elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) { |
| |
if (ref($accessinfo->{$role}) eq 'ARRAY') { |
| |
@personnel = @{$accessinfo->{$role}}; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if ($curraccess eq 'none') { |
| |
next; |
| |
} elsif ($curraccess eq 'all') { |
| |
push(@possroles,$role); |
| |
} elsif ($curraccess eq 'dh') { |
| |
if (grep(/^dh$/,@liveroles)) { |
| |
push(@possroles,$role); |
| |
} else { |
| |
next; |
| |
} |
| |
} elsif ($curraccess eq 'da') { |
| |
if (grep(/^da$/,@liveroles)) { |
| |
push(@possroles,$role); |
| |
} else { |
| |
next; |
| |
} |
| |
} elsif ($curraccess eq 'status') { |
| |
if (@okstatus) { |
| |
if (!@statuses) { |
| |
if (grep(/^default$/,@okstatus)) { |
| |
push(@possroles,$role); |
| |
} |
| |
} else { |
| |
foreach my $status (@okstatus) { |
| |
if (grep(/^\Q$status\E$/,@statuses)) { |
| |
push(@possroles,$role); |
| |
last; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) { |
| |
if (grep(/^\Q$user\E$/,@personnel)) { |
| |
if ($curraccess eq 'exc') { |
| |
push(@possroles,$role); |
| |
} |
| |
} elsif ($curraccess eq 'inc') { |
| |
push(@possroles,$role); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
unless (ref($description) eq 'HASH') { |
| |
if (ref($roles_by_num) eq 'ARRAY') { |
| |
my %desc; |
| |
map { $desc{$_} = $_; } (@{$roles_by_num}); |
| |
$description = \%desc; |
| |
} else { |
| |
$description = {}; |
| |
} |
| |
} |
| |
return (\@possroles,$description); |
| |
} |
| |
|
| # ----------------------------------------------------- Frontpage Announcements |
# ----------------------------------------------------- Frontpage Announcements |
| # |
# |
| # |
# |
|
Line 4261 sub courseiddump {
|
Line 4559 sub courseiddump {
|
| $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok, |
$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok, |
| $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone, |
$selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone, |
| $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner, |
$cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner, |
| $hasuniquecode)=@_; |
$hasuniquecode,$reqcrsdom,$reqinstcode)=@_; |
| my $as_hash = 1; |
my $as_hash = 1; |
| my %returnhash; |
my %returnhash; |
| if (!$domfilter) { $domfilter=''; } |
if (!$domfilter) { $domfilter=''; } |
|
Line 4284 sub courseiddump {
|
Line 4582 sub courseiddump {
|
| &escape($catfilter), $showhidden, $caller, |
&escape($catfilter), $showhidden, $caller, |
| &escape($cloner), &escape($cc_clone), $cloneonly, |
&escape($cloner), &escape($cc_clone), $cloneonly, |
| &escape($createdbefore), &escape($createdafter), |
&escape($createdbefore), &escape($createdafter), |
| &escape($creationcontext), $domcloner, $hasuniquecode))); |
&escape($creationcontext),$domcloner,$hasuniquecode, |
| |
$reqcrsdom,&escape($reqinstcode)))); |
| } else { |
} else { |
| $rep = &reply('courseiddump:'.&host_domain($tryserver).':'. |
$rep = &reply('courseiddump:'.&host_domain($tryserver).':'. |
| $sincefilter.':'.&escape($descfilter).':'. |
$sincefilter.':'.&escape($descfilter).':'. |
|
Line 4295 sub courseiddump {
|
Line 4594 sub courseiddump {
|
| $showhidden.':'.$caller.':'.&escape($cloner).':'. |
$showhidden.':'.$caller.':'.&escape($cloner).':'. |
| &escape($cc_clone).':'.$cloneonly.':'. |
&escape($cc_clone).':'.$cloneonly.':'. |
| &escape($createdbefore).':'.&escape($createdafter).':'. |
&escape($createdbefore).':'.&escape($createdafter).':'. |
| &escape($creationcontext).':'.$domcloner.':'.$hasuniquecode, |
&escape($creationcontext).':'.$domcloner.':'.$hasuniquecode. |
| $tryserver); |
':'.$reqcrsdom.':'.&escape($reqinstcode),$tryserver); |
| } |
} |
| |
|
| my @pairs=split(/\&/,$rep); |
my @pairs=split(/\&/,$rep); |
|
Line 4424 sub get_domain_roles {
|
Line 4723 sub get_domain_roles {
|
| return %personnel; |
return %personnel; |
| } |
} |
| |
|
| |
sub get_active_domroles { |
| |
my ($dom,$roles) = @_; |
| |
return () unless (ref($roles) eq 'ARRAY'); |
| |
my $now = time; |
| |
my %dompersonnel = &get_domain_roles($dom,$roles,$now,$now); |
| |
my %domroles; |
| |
foreach my $server (keys(%dompersonnel)) { |
| |
foreach my $user (sort(keys(%{$dompersonnel{$server}}))) { |
| |
my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,$user); |
| |
$domroles{$uname.':'.$udom} = $dompersonnel{$server}{$user}; |
| |
} |
| |
} |
| |
return %domroles; |
| |
} |
| |
|
| # ----------------------------------------------------------- Interval timing |
# ----------------------------------------------------------- Interval timing |
| |
|
| { |
{ |
|
Line 4435 my $cachedkey='';
|
Line 4749 my $cachedkey='';
|
| # The cached times for this user |
# The cached times for this user |
| my %cachedtimes=(); |
my %cachedtimes=(); |
| # When this was last done |
# When this was last done |
| my $cachedtime=(); |
my $cachedtime=''; |
| |
|
| sub load_all_first_access { |
sub load_all_first_access { |
| my ($uname,$udom)=@_; |
my ($uname,$udom)=@_; |
|
Line 5362 sub rolesinit {
|
Line 5676 sub rolesinit {
|
| } |
} |
| } |
} |
| |
|
| @userroles{'user.author', 'user.adv'} = &set_userprivs(\%userroles, |
@userroles{'user.author','user.adv','user.rar'} = &set_userprivs(\%userroles, |
| \%allroles, \%allgroups); |
\%allroles, \%allgroups); |
| $env{'user.adv'} = $userroles{'user.adv'}; |
$env{'user.adv'} = $userroles{'user.adv'}; |
| |
$env{'user.rar'} = $userroles{'user.rar'}; |
| |
|
| return (\%userroles,\%firstaccenv,\%timerintenv); |
return (\%userroles,\%firstaccenv,\%timerintenv); |
| } |
} |
|
Line 5400 sub custom_roleprivs {
|
Line 5715 sub custom_roleprivs {
|
| $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv; |
$$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv; |
| } |
} |
| if (($trest ne '') && (defined($coursepriv))) { |
if (($trest ne '') && (defined($coursepriv))) { |
| |
if ($trole =~ m{^cr/$tdomain/$tdomain\Q-domainconfig\E/([^/]+)$}) { |
| |
my $rolename = $1; |
| |
$coursepriv = &course_adhocrole_privs($rolename,$tdomain,$trest,$coursepriv); |
| |
} |
| $$allroles{'cm.'.$area}.=':'.$coursepriv; |
$$allroles{'cm.'.$area}.=':'.$coursepriv; |
| $$allroles{$spec.'.'.$area}.=':'.$coursepriv; |
$$allroles{$spec.'.'.$area}.=':'.$coursepriv; |
| } |
} |
|
Line 5408 sub custom_roleprivs {
|
Line 5727 sub custom_roleprivs {
|
| } |
} |
| } |
} |
| |
|
| |
sub course_adhocrole_privs { |
| |
my ($rolename,$cdom,$cnum,$coursepriv) = @_; |
| |
my %overrides = &get('environment',["internal.adhocpriv.$rolename"],$cdom,$cnum); |
| |
if ($overrides{"internal.adhocpriv.$rolename"}) { |
| |
my (%currprivs,%storeprivs); |
| |
foreach my $item (split(/:/,$coursepriv)) { |
| |
my ($priv,$restrict) = split(/\&/,$item); |
| |
$currprivs{$priv} = $restrict; |
| |
} |
| |
my (%possadd,%possremove,%full); |
| |
foreach my $item (split(/\:/,$Apache::lonnet::pr{'cr:c'})) { |
| |
my ($priv,$restrict)=split(/\&/,$item); |
| |
$full{$priv} = $restrict; |
| |
} |
| |
foreach my $item (split(/,/,$overrides{"internal.adhocpriv.$rolename"})) { |
| |
next if ($item eq ''); |
| |
my ($rule,$rest) = split(/=/,$item); |
| |
next unless (($rule eq 'off') || ($rule eq 'on')); |
| |
foreach my $priv (split(/:/,$rest)) { |
| |
if ($priv ne '') { |
| |
if ($rule eq 'off') { |
| |
$possremove{$priv} = 1; |
| |
} else { |
| |
$possadd{$priv} = 1; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
foreach my $priv (sort(keys(%full))) { |
| |
if (exists($currprivs{$priv})) { |
| |
unless (exists($possremove{$priv})) { |
| |
$storeprivs{$priv} = $currprivs{$priv}; |
| |
} |
| |
} elsif (exists($possadd{$priv})) { |
| |
$storeprivs{$priv} = $full{$priv}; |
| |
} |
| |
} |
| |
$coursepriv = ':'.join(':',map { $_.'&'.$storeprivs{$_}; } sort(keys(%storeprivs))); |
| |
} |
| |
return $coursepriv; |
| |
} |
| |
|
| sub group_roleprivs { |
sub group_roleprivs { |
| my ($allgroups,$area,$group_privs,$tend,$tstart) = @_; |
my ($allgroups,$area,$group_privs,$tend,$tstart) = @_; |
| my $access = 1; |
my $access = 1; |
|
Line 5442 sub set_userprivs {
|
Line 5803 sub set_userprivs {
|
| my ($userroles,$allroles,$allgroups,$groups_roles) = @_; |
my ($userroles,$allroles,$allgroups,$groups_roles) = @_; |
| my $author=0; |
my $author=0; |
| my $adv=0; |
my $adv=0; |
| |
my $rar=0; |
| my %grouproles = (); |
my %grouproles = (); |
| if (keys(%{$allgroups}) > 0) { |
if (keys(%{$allgroups}) > 0) { |
| my @groupkeys; |
my @groupkeys; |
|
Line 5489 sub set_userprivs {
|
Line 5851 sub set_userprivs {
|
| $thesepriv{$privilege}.=$restrictions; |
$thesepriv{$privilege}.=$restrictions; |
| } |
} |
| if ($thesepriv{'adv'} eq 'F') { $adv=1; } |
if ($thesepriv{'adv'} eq 'F') { $adv=1; } |
| |
if ($thesepriv{'rar'} eq 'F') { $rar=1; } |
| } |
} |
| } |
} |
| my $thesestr=''; |
my $thesestr=''; |
|
Line 5497 sub set_userprivs {
|
Line 5860 sub set_userprivs {
|
| } |
} |
| $userroles->{'user.priv.'.$role} = $thesestr; |
$userroles->{'user.priv.'.$role} = $thesestr; |
| } |
} |
| return ($author,$adv); |
return ($author,$adv,$rar); |
| } |
} |
| |
|
| sub role_status { |
sub role_status { |
|
Line 5542 sub role_status {
|
Line 5905 sub role_status {
|
| push(@rolecodes,$$role); |
push(@rolecodes,$$role); |
| &standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where); |
&standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where); |
| } |
} |
| my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups,\%groups_roles); |
my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%allroles,\%allgroups, |
| |
\%groups_roles); |
| &appenv(\%userroles,\@rolecodes); |
&appenv(\%userroles,\@rolecodes); |
| &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role); |
&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role); |
| } |
} |
|
Line 5620 sub delete_env_groupprivs {
|
Line 5984 sub delete_env_groupprivs {
|
| } |
} |
| |
|
| sub check_adhoc_privs { |
sub check_adhoc_privs { |
| my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller) = @_; |
my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller,$sec) = @_; |
| my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum; |
my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum; |
| |
if ($sec) { |
| |
$cckey .= '/'.$sec; |
| |
} |
| my $setprivs; |
my $setprivs; |
| if ($env{$cckey}) { |
if ($env{$cckey}) { |
| my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend); |
my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend); |
| &role_status($cckey,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend); |
&role_status($cckey,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend); |
| unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) { |
unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) { |
| &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller); |
&set_adhoc_privileges($cdom,$cnum,$checkrole,$caller,$sec); |
| $setprivs = 1; |
$setprivs = 1; |
| } |
} |
| } else { |
} else { |
| &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller); |
&set_adhoc_privileges($cdom,$cnum,$checkrole,$caller,$sec); |
| $setprivs = 1; |
$setprivs = 1; |
| } |
} |
| return $setprivs; |
return $setprivs; |
| } |
} |
| |
|
| sub set_adhoc_privileges { |
sub set_adhoc_privileges { |
| # role can be cc or ca |
# role can be cc, ca, or cr/<dom>/<dom>-domainconfig/role |
| my ($dcdom,$pickedcourse,$role,$caller) = @_; |
my ($dcdom,$pickedcourse,$role,$caller,$sec) = @_; |
| my $area = '/'.$dcdom.'/'.$pickedcourse; |
my $area = '/'.$dcdom.'/'.$pickedcourse; |
| |
if ($sec ne '') { |
| |
$area .= '/'.$sec; |
| |
} |
| my $spec = $role.'.'.$area; |
my $spec = $role.'.'.$area; |
| my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'}, |
my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'}, |
| $env{'user.name'},1); |
$env{'user.name'},1); |
| my %ccrole = (); |
my %rolehash = (); |
| &standard_roleprivs(\%ccrole,$role,$dcdom,$spec,$pickedcourse,$area); |
if ($role =~ m{^\Qcr/$dcdom/$dcdom\E\-domainconfig/(\w+)$}) { |
| my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole); |
my $rolename = $1; |
| |
&custom_roleprivs(\%rolehash,$role,$dcdom,$pickedcourse,$spec,$area); |
| |
my %domdef = &get_domain_defaults($dcdom); |
| |
if (ref($domdef{'adhocroles'}) eq 'HASH') { |
| |
if (ref($domdef{'adhocroles'}{$rolename}) eq 'HASH') { |
| |
&appenv({'request.role.desc' => $domdef{'adhocroles'}{$rolename}{'desc'},}); |
| |
} |
| |
} |
| |
} else { |
| |
&standard_roleprivs(\%rolehash,$role,$dcdom,$spec,$pickedcourse,$area); |
| |
} |
| |
my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%rolehash); |
| &appenv(\%userroles,[$role,'cm']); |
&appenv(\%userroles,[$role,'cm']); |
| &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role); |
&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role); |
| unless ($caller eq 'constructaccess' && $env{'request.course.id'}) { |
unless ($caller eq 'constructaccess' && $env{'request.course.id'}) { |
| &appenv( {'request.role' => $spec, |
&appenv( {'request.role' => $spec, |
| 'request.role.domain' => $dcdom, |
'request.role.domain' => $dcdom, |
| 'request.course.sec' => '' |
'request.course.sec' => $sec, |
| } |
} |
| ); |
); |
| my $tadv=0; |
my $tadv=0; |
|
Line 6034 sub tmpget {
|
Line 6415 sub tmpget {
|
| if (!defined($server)) { $server = $perlvar{'lonHostID'}; } |
if (!defined($server)) { $server = $perlvar{'lonHostID'}; } |
| my $rep=&reply("tmpget:$token",$server); |
my $rep=&reply("tmpget:$token",$server); |
| my %returnhash; |
my %returnhash; |
| |
if ($rep =~ /^(con_lost|error|no_such_host)/i) { |
| |
return %returnhash; |
| |
} |
| foreach my $item (split(/\&/,$rep)) { |
foreach my $item (split(/\&/,$rep)) { |
| my ($key,$value)=split(/=/,$item); |
my ($key,$value)=split(/=/,$item); |
| next if ($key =~ /^error: 2 /); |
|
| $returnhash{&unescape($key)}=&thaw_unescape($value); |
$returnhash{&unescape($key)}=&thaw_unescape($value); |
| } |
} |
| return %returnhash; |
return %returnhash; |
|
Line 6151 sub sixnum_code {
|
Line 6534 sub sixnum_code {
|
| # -------------------------------------------------- portfolio access checking |
# -------------------------------------------------- portfolio access checking |
| |
|
| sub portfolio_access { |
sub portfolio_access { |
| my ($requrl) = @_; |
my ($requrl,$clientip) = @_; |
| my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl); |
my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl); |
| my $result = &get_portfolio_access($udom,$unum,$file_name,$group); |
my $result = &get_portfolio_access($udom,$unum,$file_name,$group,$clientip); |
| if ($result) { |
if ($result) { |
| my %setters; |
my %setters; |
| if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') { |
if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') { |
|
Line 6179 sub portfolio_access {
|
Line 6562 sub portfolio_access {
|
| } |
} |
| |
|
| sub get_portfolio_access { |
sub get_portfolio_access { |
| my ($udom,$unum,$file_name,$group,$access_hash) = @_; |
my ($udom,$unum,$file_name,$group,$clientip,$access_hash) = @_; |
| |
|
| if (!ref($access_hash)) { |
if (!ref($access_hash)) { |
| my $current_perms = &get_portfile_permissions($udom,$unum); |
my $current_perms = &get_portfile_permissions($udom,$unum); |
|
Line 6188 sub get_portfolio_access {
|
Line 6571 sub get_portfolio_access {
|
| $access_hash = $access_controls{$file_name}; |
$access_hash = $access_controls{$file_name}; |
| } |
} |
| |
|
| my ($public,$guest,@domains,@users,@courses,@groups); |
my ($public,$guest,@domains,@users,@courses,@groups,@ips); |
| my $now = time; |
my $now = time; |
| if (ref($access_hash) eq 'HASH') { |
if (ref($access_hash) eq 'HASH') { |
| foreach my $key (keys(%{$access_hash})) { |
foreach my $key (keys(%{$access_hash})) { |
|
Line 6212 sub get_portfolio_access {
|
Line 6595 sub get_portfolio_access {
|
| push(@courses,$key); |
push(@courses,$key); |
| } elsif ($scope eq 'group') { |
} elsif ($scope eq 'group') { |
| push(@groups,$key); |
push(@groups,$key); |
| |
} elsif ($scope eq 'ip') { |
| |
push(@ips,$key); |
| } |
} |
| } |
} |
| if ($public) { |
if ($public) { |
| return 'ok'; |
return 'ok'; |
| |
} elsif (@ips > 0) { |
| |
my $allowed; |
| |
foreach my $ipkey (@ips) { |
| |
if (ref($access_hash->{$ipkey}{'ip'}) eq 'ARRAY') { |
| |
if (&Apache::loncommon::check_ip_acc(join(',',@{$access_hash->{$ipkey}{'ip'}}),$clientip)) { |
| |
$allowed = 1; |
| |
last; |
| |
} |
| |
} |
| |
} |
| |
if ($allowed) { |
| |
return 'ok'; |
| |
} |
| } |
} |
| if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') { |
if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') { |
| if ($guest) { |
if ($guest) { |
|
Line 6699 sub customaccess {
|
Line 7097 sub customaccess {
|
| # ------------------------------------------------- Check for a user privilege |
# ------------------------------------------------- Check for a user privilege |
| |
|
| sub allowed { |
sub allowed { |
| my ($priv,$uri,$symb,$role)=@_; |
my ($priv,$uri,$symb,$role,$clientip,$noblockcheck)=@_; |
| my $ver_orguri=$uri; |
my $ver_orguri=$uri; |
| $uri=&deversion($uri); |
$uri=&deversion($uri); |
| my $orguri=$uri; |
my $orguri=$uri; |
|
Line 6894 sub allowed {
|
Line 7292 sub allowed {
|
| if ($match) { |
if ($match) { |
| if ($env{'user.priv.'.$env{'request.role'}.'./'} |
if ($env{'user.priv.'.$env{'request.role'}.'./'} |
| =~/\Q$priv\E\&([^\:]*)/) { |
=~/\Q$priv\E\&([^\:]*)/) { |
| my @blockers = &has_comm_blocking($priv,$symb,$uri); |
my $value = $1; |
| if (@blockers > 0) { |
if ($noblockcheck) { |
| $thisallowed = 'B'; |
$thisallowed.=$value; |
| } else { |
} else { |
| $thisallowed.=$1; |
my @blockers = &has_comm_blocking($priv,$symb,$uri); |
| |
if (@blockers > 0) { |
| |
$thisallowed = 'B'; |
| |
} else { |
| |
$thisallowed.=$value; |
| |
} |
| } |
} |
| } |
} |
| } else { |
} else { |
|
Line 6910 sub allowed {
|
Line 7313 sub allowed {
|
| $refuri=&declutter($refuri); |
$refuri=&declutter($refuri); |
| my ($match) = &is_on_map($refuri); |
my ($match) = &is_on_map($refuri); |
| if ($match) { |
if ($match) { |
| my @blockers = &has_comm_blocking($priv,$symb,$refuri); |
if ($noblockcheck) { |
| if (@blockers > 0) { |
|
| $thisallowed = 'B'; |
|
| } else { |
|
| $thisallowed='F'; |
$thisallowed='F'; |
| |
} else { |
| |
my @blockers = &has_comm_blocking($priv,$symb,$refuri); |
| |
if (@blockers > 0) { |
| |
$thisallowed = 'B'; |
| |
} else { |
| |
$thisallowed='F'; |
| |
} |
| } |
} |
| } |
} |
| } |
} |
|
Line 6926 sub allowed {
|
Line 7333 sub allowed {
|
| && $thisallowed ne 'F' |
&& $thisallowed ne 'F' |
| && $thisallowed ne '2' |
&& $thisallowed ne '2' |
| && &is_portfolio_url($uri)) { |
&& &is_portfolio_url($uri)) { |
| $thisallowed = &portfolio_access($uri); |
$thisallowed = &portfolio_access($uri,$clientip); |
| } |
} |
| |
|
| # Full access at system, domain or course-wide level? Exit. |
# Full access at system, domain or course-wide level? Exit. |
|
Line 6969 sub allowed {
|
Line 7376 sub allowed {
|
| =~/\Q$priv\E\&([^\:]*)/) { |
=~/\Q$priv\E\&([^\:]*)/) { |
| my $value = $1; |
my $value = $1; |
| if ($priv eq 'bre') { |
if ($priv eq 'bre') { |
| my @blockers = &has_comm_blocking($priv,$symb,$uri); |
if ($noblockcheck) { |
| if (@blockers > 0) { |
|
| $thisallowed = 'B'; |
|
| } else { |
|
| $thisallowed.=$value; |
$thisallowed.=$value; |
| |
} else { |
| |
my @blockers = &has_comm_blocking($priv,$symb,$uri); |
| |
if (@blockers > 0) { |
| |
$thisallowed = 'B'; |
| |
} else { |
| |
$thisallowed.=$value; |
| |
} |
| } |
} |
| } else { |
} else { |
| $thisallowed.=$value; |
$thisallowed.=$value; |
|
Line 7007 sub allowed {
|
Line 7418 sub allowed {
|
| =~/\Q$priv\E\&([^\:]*)/) { |
=~/\Q$priv\E\&([^\:]*)/) { |
| my $value = $1; |
my $value = $1; |
| if ($priv eq 'bre') { |
if ($priv eq 'bre') { |
| my @blockers = &has_comm_blocking($priv,$symb,$refuri); |
if ($noblockcheck) { |
| if (@blockers > 0) { |
|
| $thisallowed = 'B'; |
|
| } else { |
|
| $thisallowed.=$value; |
$thisallowed.=$value; |
| |
} else { |
| |
my @blockers = &has_comm_blocking($priv,$symb,$refuri); |
| |
if (@blockers > 0) { |
| |
$thisallowed = 'B'; |
| |
} else { |
| |
$thisallowed.=$value; |
| |
} |
| } |
} |
| } else { |
} else { |
| $thisallowed.=$value; |
$thisallowed.=$value; |
|
Line 7187 sub constructaccess {
|
Line 7602 sub constructaccess {
|
| my ($ownername,$ownerdomain,$ownerhome); |
my ($ownername,$ownerdomain,$ownerhome); |
| |
|
| ($ownerdomain,$ownername) = |
($ownerdomain,$ownername) = |
| ($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)/priv/($match_domain)/($match_username)/}); |
($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)/priv/($match_domain)/($match_username)(?:/|$)}); |
| |
|
| # The URL does not really point to any authorspace, forget it |
# The URL does not really point to any authorspace, forget it |
| unless (($ownername) && ($ownerdomain)) { return ''; } |
unless (($ownername) && ($ownerdomain)) { return ''; } |
|
Line 7242 sub constructaccess {
|
Line 7657 sub constructaccess {
|
| return ''; |
return ''; |
| } |
} |
| |
|
| |
# ----------------------------------------------------------- Content Blocking |
| |
|
| |
{ |
| |
# Caches for faster Course Contents display where content blocking |
| |
# is in operation (i.e., interval param set) for timed quiz. |
| |
# |
| |
# User for whom data are being temporarily cached. |
| |
my $cacheduser=''; |
| |
# Cached blockers for this user (a hash of blocking items). |
| |
my %cachedblockers=(); |
| |
# When the data were last cached. |
| |
my $cachedlast=''; |
| |
|
| |
sub load_all_blockers { |
| |
my ($uname,$udom,$blocks)=@_; |
| |
if (($uname ne '') && ($udom ne '')) { |
| |
if (($cacheduser eq $uname.':'.$udom) && |
| |
(abs($cachedlast-time)<5)) { |
| |
return; |
| |
} |
| |
} |
| |
$cachedlast=time; |
| |
$cacheduser=$uname.':'.$udom; |
| |
%cachedblockers = &get_commblock_resources($blocks); |
| |
} |
| |
|
| sub get_comm_blocks { |
sub get_comm_blocks { |
| my ($cdom,$cnum) = @_; |
my ($cdom,$cnum) = @_; |
| if ($cdom eq '' || $cnum eq '') { |
if ($cdom eq '' || $cnum eq '') { |
|
Line 7262 sub get_comm_blocks {
|
Line 7703 sub get_comm_blocks {
|
| return %commblocks; |
return %commblocks; |
| } |
} |
| |
|
| sub has_comm_blocking { |
sub get_commblock_resources { |
| my ($priv,$symb,$uri,$blocks) = @_; |
my ($blocks) = @_; |
| return unless ($env{'request.course.id'}); |
my %blockers = (); |
| return unless ($priv eq 'bre'); |
return %blockers unless ($env{'request.course.id'}); |
| return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/); |
return %blockers if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/); |
| my %commblocks; |
my %commblocks; |
| if (ref($blocks) eq 'HASH') { |
if (ref($blocks) eq 'HASH') { |
| %commblocks = %{$blocks}; |
%commblocks = %{$blocks}; |
| } else { |
} else { |
| %commblocks = &get_comm_blocks(); |
%commblocks = &get_comm_blocks(); |
| } |
} |
| return unless (keys(%commblocks) > 0); |
return %blockers unless (keys(%commblocks) > 0); |
| if (!$symb) { $symb=&symbread($uri,1); } |
|
| my ($map,$resid,undef)=&decode_symb($symb); |
|
| my %tocheck = ( |
|
| maps => $map, |
|
| resources => $symb, |
|
| ); |
|
| my @blockers; |
|
| my $now = time; |
|
| my $navmap = Apache::lonnavmaps::navmap->new(); |
my $navmap = Apache::lonnavmaps::navmap->new(); |
| |
return %blockers unless (ref($navmap)); |
| |
my $now = time; |
| foreach my $block (keys(%commblocks)) { |
foreach my $block (keys(%commblocks)) { |
| if ($block =~ /^(\d+)____(\d+)$/) { |
if ($block =~ /^(\d+)____(\d+)$/) { |
| my ($start,$end) = ($1,$2); |
my ($start,$end) = ($1,$2); |
|
Line 7290 sub has_comm_blocking {
|
Line 7725 sub has_comm_blocking {
|
| if (ref($commblocks{$block}{'blocks'}) eq 'HASH') { |
if (ref($commblocks{$block}{'blocks'}) eq 'HASH') { |
| if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') { |
if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') { |
| if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) eq 'HASH') { |
if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) eq 'HASH') { |
| if ($commblocks{$block}{'blocks'}{'docs'}{'maps'}{$map}) { |
if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'maps'}})) { |
| unless (grep(/^\Q$block\E$/,@blockers)) { |
$blockers{$block}{maps} = $commblocks{$block}{'blocks'}{'docs'}{'maps'}; |
| push(@blockers,$block); |
|
| } |
|
| } |
} |
| } |
} |
| if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') { |
if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') { |
| if ($commblocks{$block}{'blocks'}{'docs'}{'resources'}{$symb}) { |
if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'resources'}})) { |
| unless (grep(/^\Q$block\E$/,@blockers)) { |
$blockers{$block}{'resources'} = $commblocks{$block}{'blocks'}{'docs'}{'resources'}; |
| push(@blockers,$block); |
|
| } |
|
| } |
} |
| } |
} |
| } |
} |
|
Line 7311 sub has_comm_blocking {
|
Line 7742 sub has_comm_blocking {
|
| my @to_test; |
my @to_test; |
| if (ref($commblocks{$block}{'blocks'}) eq 'HASH') { |
if (ref($commblocks{$block}{'blocks'}) eq 'HASH') { |
| if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') { |
if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') { |
| my $check_interval; |
my @interval; |
| if (&check_docs_block($commblocks{$block}{'blocks'}{'docs'},\%tocheck)) { |
my $type = 'map'; |
| my @interval; |
if ($item eq 'course') { |
| my $type = 'map'; |
$type = 'course'; |
| if ($item eq 'course') { |
@interval=&EXT("resource.0.interval"); |
| $type = 'course'; |
} else { |
| @interval=&EXT("resource.0.interval"); |
if ($item =~ /___\d+___/) { |
| |
$type = 'resource'; |
| |
@interval=&EXT("resource.0.interval",$item); |
| |
if (ref($navmap)) { |
| |
my $res = $navmap->getBySymb($item); |
| |
push(@to_test,$res); |
| |
} |
| } else { |
} else { |
| if ($item =~ /___\d+___/) { |
my $mapsymb = &symbread($item,1); |
| $type = 'resource'; |
if ($mapsymb) { |
| @interval=&EXT("resource.0.interval",$item); |
if (ref($navmap)) { |
| if (ref($navmap)) { |
my $mapres = $navmap->getBySymb($mapsymb); |
| my $res = $navmap->getBySymb($item); |
@to_test = $mapres->retrieveResources($mapres,undef,0,0,0,1); |
| push(@to_test,$res); |
foreach my $res (@to_test) { |
| } |
my $symb = $res->symb(); |
| } else { |
next if ($symb eq $mapsymb); |
| my $mapsymb = &symbread($item,1); |
if ($symb ne '') { |
| if ($mapsymb) { |
@interval=&EXT("resource.0.interval",$symb); |
| if (ref($navmap)) { |
if ($interval[1] eq 'map') { |
| my $mapres = $navmap->getBySymb($mapsymb); |
last; |
| @to_test = $mapres->retrieveResources($mapres); |
|
| foreach my $res (@to_test) { |
|
| my $symb = $res->symb(); |
|
| next if ($symb eq $mapsymb); |
|
| if ($symb ne '') { |
|
| @interval=&EXT("resource.0.interval",$symb); |
|
| if ($interval[1] eq 'map') { |
|
| last; |
|
| } |
|
| } |
} |
| } |
} |
| } |
} |
| } |
} |
| } |
} |
| } |
} |
| if ($interval[0] =~ /\d+/) { |
} |
| my $first_access; |
if ($interval[0] =~ /^\d+$/) { |
| if ($type eq 'resource') { |
my $first_access; |
| $first_access=&get_first_access($interval[1],$item); |
if ($type eq 'resource') { |
| } elsif ($type eq 'map') { |
$first_access=&get_first_access($interval[1],$item); |
| $first_access=&get_first_access($interval[1],undef,$item); |
} elsif ($type eq 'map') { |
| } else { |
$first_access=&get_first_access($interval[1],undef,$item); |
| $first_access=&get_first_access($interval[1]); |
} else { |
| } |
$first_access=&get_first_access($interval[1]); |
| if ($first_access) { |
} |
| my $timesup = $first_access+$interval[0]; |
if ($first_access) { |
| if ($timesup > $now) { |
my $timesup = $first_access+$interval[0]; |
| foreach my $res (@to_test) { |
if ($timesup > $now) { |
| if ($res->is_problem()) { |
my $activeblock; |
| if ($res->completable()) { |
foreach my $res (@to_test) { |
| unless (grep(/^\Q$block\E$/,@blockers)) { |
if ($res->answerable()) { |
| push(@blockers,$block); |
$activeblock = 1; |
| } |
last; |
| last; |
} |
| } |
} |
| |
if ($activeblock) { |
| |
if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) eq 'HASH') { |
| |
if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'maps'}})) { |
| |
$blockers{$block}{'maps'} = $commblocks{$block}{'blocks'}{'docs'}{'maps'}; |
| |
} |
| |
} |
| |
if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') { |
| |
if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'resources'}})) { |
| |
$blockers{$block}{'resources'} = $commblocks{$block}{'blocks'}{'docs'}{'resources'}; |
| } |
} |
| } |
} |
| } |
} |
|
Line 7376 sub has_comm_blocking {
|
Line 7813 sub has_comm_blocking {
|
| } |
} |
| } |
} |
| } |
} |
| return @blockers; |
return %blockers; |
| } |
} |
| |
|
| sub check_docs_block { |
sub has_comm_blocking { |
| my ($docsblock,$tocheck) =@_; |
my ($priv,$symb,$uri,$blocks) = @_; |
| if ((ref($docsblock) ne 'HASH') || (ref($tocheck) ne 'HASH')) { |
my @blockers; |
| return; |
return unless ($env{'request.course.id'}); |
| |
return unless ($priv eq 'bre'); |
| |
return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/); |
| |
return if ($env{'request.state'} eq 'construct'); |
| |
&load_all_blockers($env{'user.name'},$env{'user.domain'},$blocks); |
| |
return unless (keys(%cachedblockers) > 0); |
| |
my (%possibles,@symbs); |
| |
if (!$symb) { |
| |
$symb = &symbread($uri,1,1,1,\%possibles); |
| } |
} |
| if (ref($docsblock->{'maps'}) eq 'HASH') { |
if ($symb) { |
| if ($tocheck->{'maps'}) { |
@symbs = ($symb); |
| if ($docsblock->{'maps'}{$tocheck->{'maps'}}) { |
} elsif (keys(%possibles)) { |
| return 1; |
@symbs = keys(%possibles); |
| |
} |
| |
my $noblock; |
| |
foreach my $symb (@symbs) { |
| |
last if ($noblock); |
| |
my ($map,$resid,$resurl)=&decode_symb($symb); |
| |
foreach my $block (keys(%cachedblockers)) { |
| |
if ($block =~ /^firstaccess____(.+)$/) { |
| |
my $item = $1; |
| |
if (($item eq $map) || ($item eq $symb)) { |
| |
$noblock = 1; |
| |
last; |
| |
} |
| } |
} |
| } |
if (ref($cachedblockers{$block}) eq 'HASH') { |
| } |
if (ref($cachedblockers{$block}{'resources'}) eq 'HASH') { |
| if (ref($docsblock->{'resources'}) eq 'HASH') { |
if ($cachedblockers{$block}{'resources'}{$symb}) { |
| if ($tocheck->{'resources'}) { |
unless (grep(/^\Q$block\E$/,@blockers)) { |
| if ($docsblock->{'resources'}{$tocheck->{'resources'}}) { |
push(@blockers,$block); |
| return 1; |
} |
| |
} |
| |
} |
| |
} |
| |
if (ref($cachedblockers{$block}{'maps'}) eq 'HASH') { |
| |
if ($cachedblockers{$block}{'maps'}{$map}) { |
| |
unless (grep(/^\Q$block\E$/,@blockers)) { |
| |
push(@blockers,$block); |
| |
} |
| |
} |
| } |
} |
| } |
} |
| } |
} |
| return; |
return if ($noblock); |
| |
return @blockers; |
| } |
} |
| |
} |
| |
|
| |
# -------------------------------- Deversion and split uri into path an filename |
| |
|
| # |
# |
| # Removes the versino from a URI and |
# Removes the version from a URI and |
| # splits it in to its filename and path to the filename. |
# splits it in to its filename and path to the filename. |
| # Seems like File::Basename could have done this more clearly. |
# Seems like File::Basename could have done this more clearly. |
| # Parameters: |
# Parameters: |
|
Line 7470 sub get_symb_from_alias {
|
Line 7940 sub get_symb_from_alias {
|
| |
|
| sub definerole { |
sub definerole { |
| if (allowed('mcr','/')) { |
if (allowed('mcr','/')) { |
| my ($rolename,$sysrole,$domrole,$courole)=@_; |
my ($rolename,$sysrole,$domrole,$courole,$uname,$udom)=@_; |
| foreach my $role (split(':',$sysrole)) { |
foreach my $role (split(':',$sysrole)) { |
| my ($crole,$cqual)=split(/\&/,$role); |
my ($crole,$cqual)=split(/\&/,$role); |
| if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; } |
if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; } |
|
Line 7498 sub definerole {
|
Line 7968 sub definerole {
|
| } |
} |
| } |
} |
| } |
} |
| |
my $uhome; |
| |
if (($uname ne '') && ($udom ne '')) { |
| |
$uhome = &homeserver($uname,$udom); |
| |
return $uhome if ($uhome eq 'no_host'); |
| |
} else { |
| |
$uname = $env{'user.name'}; |
| |
$udom = $env{'user.domain'}; |
| |
$uhome = $env{'user.home'}; |
| |
} |
| my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:". |
my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:". |
| "$env{'user.domain'}:$env{'user.name'}:". |
"$udom:$uname:rolesdef_$rolename=". |
| "rolesdef_$rolename=". |
|
| escape($sysrole.'_'.$domrole.'_'.$courole); |
escape($sysrole.'_'.$domrole.'_'.$courole); |
| return reply($command,$env{'user.home'}); |
return reply($command,$uhome); |
| } else { |
} else { |
| return 'refused'; |
return 'refused'; |
| } |
} |
|
Line 7584 sub update_allusers_table {
|
Line 8062 sub update_allusers_table {
|
| |
|
| sub fetch_enrollment_query { |
sub fetch_enrollment_query { |
| my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_; |
my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_; |
| my $homeserver; |
my ($homeserver,$sleep,$loopmax); |
| my $maxtries = 1; |
my $maxtries = 1; |
| if ($context eq 'automated') { |
if ($context eq 'automated') { |
| $homeserver = $perlvar{'lonHostID'}; |
$homeserver = $perlvar{'lonHostID'}; |
| |
$sleep = 2; |
| |
$loopmax = 100; |
| $maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout |
$maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout |
| } else { |
} else { |
| $homeserver = &homeserver($cnum,$dom); |
$homeserver = &homeserver($cnum,$dom); |
|
Line 7605 sub fetch_enrollment_query {
|
Line 8085 sub fetch_enrollment_query {
|
| &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum); |
&logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum); |
| return 'error: '.$queryid; |
return 'error: '.$queryid; |
| } |
} |
| my $reply = &get_query_reply($queryid); |
my $reply = &get_query_reply($queryid,$sleep.$loopmax); |
| my $tries = 1; |
my $tries = 1; |
| while (($reply=~/^timeout/) && ($tries < $maxtries)) { |
while (($reply=~/^timeout/) && ($tries < $maxtries)) { |
| $reply = &get_query_reply($queryid); |
$reply = &get_query_reply($queryid,$sleep,$loopmax); |
| $tries ++; |
$tries ++; |
| } |
} |
| if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { |
if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { |
| &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries); |
&logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries); |
| } else { |
} else { |
| my @responses = split(/:/,$reply); |
my @responses = split(/:/,$reply); |
| if ($homeserver eq $perlvar{'lonHostID'}) { |
if (grep { $_ eq $homeserver } ¤t_machine_ids()) { |
| foreach my $line (@responses) { |
foreach my $line (@responses) { |
| my ($key,$value) = split(/=/,$line,2); |
my ($key,$value) = split(/=/,$line,2); |
| $$replyref{$key} = $value; |
$$replyref{$key} = $value; |
|
Line 7650 sub fetch_enrollment_query {
|
Line 8130 sub fetch_enrollment_query {
|
| } |
} |
| |
|
| sub get_query_reply { |
sub get_query_reply { |
| my $queryid=shift; |
my ($queryid,$sleep,$loopmax) = @_; |
| |
if (($sleep eq '') || ($sleep !~ /^\d+\.?\d*$/)) { |
| |
$sleep = 0.2; |
| |
} |
| |
if (($loopmax eq '') || ($loopmax =~ /\D/)) { |
| |
$loopmax = 100; |
| |
} |
| my $replyfile=LONCAPA::tempdir().$queryid; |
my $replyfile=LONCAPA::tempdir().$queryid; |
| my $reply=''; |
my $reply=''; |
| for (1..100) { |
for (1..$loopmax) { |
| sleep 2; |
sleep($sleep); |
| if (-e $replyfile.'.end') { |
if (-e $replyfile.'.end') { |
| if (open(my $fh,$replyfile)) { |
if (open(my $fh,$replyfile)) { |
| $reply = join('',<$fh>); |
$reply = join('',<$fh>); |
|
Line 8076 sub auto_crsreq_update {
|
Line 8562 sub auto_crsreq_update {
|
| return \%crsreqresponse; |
return \%crsreqresponse; |
| } |
} |
| |
|
| |
sub auto_export_grades { |
| |
my ($cdom,$cnum,$inforef,$gradesref) = @_; |
| |
my ($homeserver,%exportresponse); |
| |
if ($cdom =~ /^$match_domain$/) { |
| |
$homeserver = &domain($cdom,'primary'); |
| |
} |
| |
unless (($homeserver eq 'no_host') || ($homeserver eq '')) { |
| |
my $info; |
| |
if (ref($inforef) eq 'HASH') { |
| |
$info = &freeze_escape($inforef); |
| |
} |
| |
if (ref($gradesref) eq 'HASH') { |
| |
my $grades = &freeze_escape($gradesref); |
| |
my $response=&reply('encrypt:autoexportgrades:'.$cdom.':'.$cnum.':'. |
| |
$info.':'.$grades,$homeserver); |
| |
unless ($response =~ /(con_lost|error|no_such_host|refused|unknown_command)/) { |
| |
my @items = split(/&/,$response); |
| |
foreach my $item (@items) { |
| |
my ($key,$value) = split('=',$item); |
| |
$exportresponse{&unescape($key)} = &thaw_unescape($value); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return \%exportresponse; |
| |
} |
| |
|
| |
sub check_instcode_cloning { |
| |
my ($codedefaults,$code_order,$cloner,$clonefromcode,$clonetocode) = @_; |
| |
unless ((ref($codedefaults) eq 'HASH') && (ref($code_order) eq 'ARRAY')) { |
| |
return; |
| |
} |
| |
my $canclone; |
| |
if (@{$code_order} > 0) { |
| |
my $instcoderegexp ='^'; |
| |
my @clonecodes = split(/\&/,$cloner); |
| |
foreach my $item (@{$code_order}) { |
| |
if (grep(/^\Q$item\E=/,@clonecodes)) { |
| |
foreach my $pair (@clonecodes) { |
| |
my ($key,$val) = split(/\=/,$pair,2); |
| |
$val = &unescape($val); |
| |
if ($key eq $item) { |
| |
$instcoderegexp .= '('.$val.')'; |
| |
last; |
| |
} |
| |
} |
| |
} else { |
| |
$instcoderegexp .= $codedefaults->{$item}; |
| |
} |
| |
} |
| |
$instcoderegexp .= '$'; |
| |
my (@from,@to); |
| |
eval { |
| |
(@from) = ($clonefromcode =~ /$instcoderegexp/); |
| |
(@to) = ($clonetocode =~ /$instcoderegexp/); |
| |
}; |
| |
if ((@from > 0) && (@to > 0)) { |
| |
my @diffs = &Apache::loncommon::compare_arrays(\@from,\@to); |
| |
if (!@diffs) { |
| |
$canclone = 1; |
| |
} |
| |
} |
| |
} |
| |
return $canclone; |
| |
} |
| |
|
| |
sub default_instcode_cloning { |
| |
my ($clonedom,$domdefclone,$clonefromcode,$clonetocode,$codedefaultsref,$codeorderref) = @_; |
| |
my (%codedefaults,@code_order,$canclone); |
| |
if ((ref($codedefaultsref) eq 'HASH') && (ref($codeorderref) eq 'ARRAY')) { |
| |
%codedefaults = %{$codedefaultsref}; |
| |
@code_order = @{$codeorderref}; |
| |
} elsif ($clonedom) { |
| |
&auto_instcode_defaults($clonedom,\%codedefaults,\@code_order); |
| |
} |
| |
if (($domdefclone) && (@code_order)) { |
| |
my @clonecodes = split(/\+/,$domdefclone); |
| |
my $instcoderegexp ='^'; |
| |
foreach my $item (@code_order) { |
| |
if (grep(/^\Q$item\E$/,@clonecodes)) { |
| |
$instcoderegexp .= '('.$codedefaults{$item}.')'; |
| |
} else { |
| |
$instcoderegexp .= $codedefaults{$item}; |
| |
} |
| |
} |
| |
$instcoderegexp .= '$'; |
| |
my (@from,@to); |
| |
eval { |
| |
(@from) = ($clonefromcode =~ /$instcoderegexp/); |
| |
(@to) = ($clonetocode =~ /$instcoderegexp/); |
| |
}; |
| |
if ((@from > 0) && (@to > 0)) { |
| |
my @diffs = &Apache::loncommon::compare_arrays(\@from,\@to); |
| |
if (!@diffs) { |
| |
$canclone = 1; |
| |
} |
| |
} |
| |
} |
| |
return $canclone; |
| |
} |
| |
|
| # ------------------------------------------------------- Course Group routines |
# ------------------------------------------------------- Course Group routines |
| |
|
| sub get_coursegroups { |
sub get_coursegroups { |
|
Line 8440 sub assignrole {
|
Line 9027 sub assignrole {
|
| &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, |
&courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, |
| $selfenroll,$context); |
$selfenroll,$context); |
| } elsif (($role eq 'li') || ($role eq 'dg') || ($role eq 'sc') || |
} elsif (($role eq 'li') || ($role eq 'dg') || ($role eq 'sc') || |
| ($role eq 'au') || ($role eq 'dc')) { |
($role eq 'au') || ($role eq 'dc') || ($role eq 'dh') || |
| |
($role eq 'da')) { |
| &domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, |
&domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, |
| $context); |
$context); |
| } elsif (($role eq 'ca') || ($role eq 'aa')) { |
} elsif (($role eq 'ca') || ($role eq 'aa')) { |
|
Line 8745 sub modifyuser {
|
Line 9333 sub modifyuser {
|
| sub modifystudent { |
sub modifystudent { |
| my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, |
my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, |
| $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid, |
$end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid, |
| $selfenroll,$context,$inststatus,$credits)=@_; |
$selfenroll,$context,$inststatus,$credits,$instsec)=@_; |
| if (!$cid) { |
if (!$cid) { |
| unless ($cid=$env{'request.course.id'}) { |
unless ($cid=$env{'request.course.id'}) { |
| return 'not_in_class'; |
return 'not_in_class'; |
|
Line 8761 sub modifystudent {
|
Line 9349 sub modifystudent {
|
| $uid = undef if (!$forceid); |
$uid = undef if (!$forceid); |
| $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last, |
$reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last, |
| $gene,$usec,$end,$start,$type,$locktype, |
$gene,$usec,$end,$start,$type,$locktype, |
| $cid,$selfenroll,$context,$credits); |
$cid,$selfenroll,$context,$credits,$instsec); |
| return $reply; |
return $reply; |
| } |
} |
| |
|
| sub modify_student_enrollment { |
sub modify_student_enrollment { |
| my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type, |
my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type, |
| $locktype,$cid,$selfenroll,$context,$credits) = @_; |
$locktype,$cid,$selfenroll,$context,$credits,$instsec) = @_; |
| my ($cdom,$cnum,$chome); |
my ($cdom,$cnum,$chome); |
| if (!$cid) { |
if (!$cid) { |
| unless ($cid=$env{'request.course.id'}) { |
unless ($cid=$env{'request.course.id'}) { |
|
Line 8814 sub modify_student_enrollment {
|
Line 9402 sub modify_student_enrollment {
|
| my %old_entry = &Apache::lonnet::get('classlist',[$user],$cdom,$cnum); |
my %old_entry = &Apache::lonnet::get('classlist',[$user],$cdom,$cnum); |
| my $reply=cput('classlist', |
my $reply=cput('classlist', |
| {$user => |
{$user => |
| join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits) }, |
join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits,$instsec) }, |
| $cdom,$cnum); |
$cdom,$cnum); |
| if (($reply eq 'ok') || ($reply eq 'delayed')) { |
if (($reply eq 'ok') || ($reply eq 'delayed')) { |
| &devalidate_getsection_cache($udom,$uname,$cid); |
&devalidate_getsection_cache($udom,$uname,$cid); |
|
Line 9338 sub modify_access_controls {
|
Line 9926 sub modify_access_controls {
|
| my $tries = 0; |
my $tries = 0; |
| my $gotlock = &newput('file_permissions',$lockhash,$domain,$user); |
my $gotlock = &newput('file_permissions',$lockhash,$domain,$user); |
| |
|
| while (($gotlock ne 'ok') && $tries <3) { |
while (($gotlock ne 'ok') && $tries < 10) { |
| $tries ++; |
$tries ++; |
| sleep 1; |
sleep(0.1); |
| $gotlock = &newput('file_permissions',$lockhash,$domain,$user); |
$gotlock = &newput('file_permissions',$lockhash,$domain,$user); |
| } |
} |
| if ($gotlock eq 'ok') { |
if ($gotlock eq 'ok') { |
|
Line 9633 sub dirlist {
|
Line 10221 sub dirlist {
|
| foreach my $user (sort(keys(%allusers))) { |
foreach my $user (sort(keys(%allusers))) { |
| push(@alluserslist,$user.'&user'); |
push(@alluserslist,$user.'&user'); |
| } |
} |
| return (\@alluserslist); |
if (!%listerror) { |
| |
# no errors |
| |
return (\@alluserslist); |
| |
} elsif (scalar(keys(%servers)) == 1) { |
| |
# one library server, one error |
| |
my ($key) = keys(%listerror); |
| |
return (\@alluserslist, $listerror{$key}); |
| |
} elsif ( grep { $_ eq 'con_lost' } values(%listerror) ) { |
| |
# con_lost indicates that we might miss data from at least one |
| |
# library server |
| |
return (\@alluserslist, 'con_lost'); |
| |
} else { |
| |
# multiple library servers and no con_lost -> data should be |
| |
# complete. |
| |
return (\@alluserslist); |
| |
} |
| |
|
| } else { |
} else { |
| return ([],'missing username'); |
return ([],'missing username'); |
| } |
} |
|
Line 9850 sub get_userresdata {
|
Line 10454 sub get_userresdata {
|
| } |
} |
| #error 2 occurs when the .db doesn't exist |
#error 2 occurs when the .db doesn't exist |
| if ($tmp!~/error: 2 /) { |
if ($tmp!~/error: 2 /) { |
| &logthis("<font color=\"blue\">WARNING:". |
if ((!defined($cached)) || ($tmp ne 'con_lost')) { |
| " Trying to get resource data for ". |
&logthis("<font color=\"blue\">WARNING:". |
| $uname." at ".$udom.": ". |
" Trying to get resource data for ". |
| $tmp."</font>"); |
$uname." at ".$udom.": ". |
| |
$tmp."</font>"); |
| |
} |
| } elsif ($tmp=~/error: 2 /) { |
} elsif ($tmp=~/error: 2 /) { |
| #&EXT_cache_set($udom,$uname); |
#&EXT_cache_set($udom,$uname); |
| &do_cache_new('userres',$hashid,undef,600); |
&do_cache_new('userres',$hashid,undef,600); |
|
Line 10983 sub deversion {
|
Line 11589 sub deversion {
|
| # ------------------------------------------------------ Return symb list entry |
# ------------------------------------------------------ Return symb list entry |
| |
|
| sub symbread { |
sub symbread { |
| my ($thisfn,$donotrecurse)=@_; |
my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles)=@_; |
| my $cache_str='request.symbread.cached.'.$thisfn; |
my $cache_str='request.symbread.cached.'.$thisfn; |
| if (defined($env{$cache_str})) { return $env{$cache_str}; } |
if (defined($env{$cache_str})) { |
| |
if ($ignorecachednull) { |
| |
return $env{$cache_str} unless ($env{$cache_str} eq ''); |
| |
} else { |
| |
return $env{$cache_str}; |
| |
} |
| |
} |
| # no filename provided? try from environment |
# no filename provided? try from environment |
| unless ($thisfn) { |
unless ($thisfn) { |
| if ($env{'request.symb'}) { |
if ($env{'request.symb'}) { |
|
Line 11047 sub symbread {
|
Line 11659 sub symbread {
|
| my ($mapid,$resid)=split(/\./,$ids); |
my ($mapid,$resid)=split(/\./,$ids); |
| $syval=&encode_symb($bighash{'map_id_'.$mapid}, |
$syval=&encode_symb($bighash{'map_id_'.$mapid}, |
| $resid,$thisfn); |
$resid,$thisfn); |
| } elsif (!$donotrecurse) { |
if (ref($possibles) eq 'HASH') { |
| |
$possibles->{$syval} = 1; |
| |
} |
| |
if ($checkforblock) { |
| |
my @blockers = &has_comm_blocking('bre',$syval,$bighash{'src_'.$ids}); |
| |
if (@blockers) { |
| |
$syval = ''; |
| |
return; |
| |
} |
| |
} |
| |
} elsif ((!$donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) { |
| # ------------------------------------------ There is more than one possibility |
# ------------------------------------------ There is more than one possibility |
| my $realpossible=0; |
my $realpossible=0; |
| foreach my $id (@possibilities) { |
foreach my $id (@possibilities) { |
| my $file=$bighash{'src_'.$id}; |
my $file=$bighash{'src_'.$id}; |
| if (&allowed('bre',$file)) { |
my $canaccess; |
| my ($mapid,$resid)=split(/\./,$id); |
if (($donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) { |
| if ($bighash{'map_type_'.$mapid} ne 'page') { |
$canaccess = 1; |
| $realpossible++; |
} else { |
| $syval=&encode_symb($bighash{'map_id_'.$mapid}, |
$canaccess = &allowed('bre',$file); |
| $resid,$thisfn); |
} |
| } |
if ($canaccess) { |
| |
my ($mapid,$resid)=split(/\./,$id); |
| |
if ($bighash{'map_type_'.$mapid} ne 'page') { |
| |
my $poss_syval=&encode_symb($bighash{'map_id_'.$mapid}, |
| |
$resid,$thisfn); |
| |
if (ref($possibles) eq 'HASH') { |
| |
$possibles->{$syval} = 1; |
| |
} |
| |
if ($checkforblock) { |
| |
my @blockers = &has_comm_blocking('bre',$poss_syval,$file); |
| |
unless (@blockers > 0) { |
| |
$syval = $poss_syval; |
| |
$realpossible++; |
| |
} |
| |
} else { |
| |
$syval = $poss_syval; |
| |
$realpossible++; |
| |
} |
| |
} |
| } |
} |
| } |
} |
| if ($realpossible!=1) { $syval=''; } |
if ($realpossible!=1) { $syval=''; } |
|
Line 11066 sub symbread {
|
Line 11706 sub symbread {
|
| $syval=''; |
$syval=''; |
| } |
} |
| } |
} |
| untie(%bighash) |
untie(%bighash); |
| } |
} |
| } |
} |
| if ($syval) { |
if ($syval) { |
|
Line 12036 sub fetch_dns_checksums {
|
Line 12676 sub fetch_dns_checksums {
|
| } |
} |
| |
|
| sub load_domain_tab { |
sub load_domain_tab { |
| my ($ignore_cache) = @_; |
my ($ignore_cache,$nocache) = @_; |
| &get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache); |
&get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache,$nocache); |
| my $fh; |
my $fh; |
| if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) { |
if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) { |
| my @lines = <$fh>; |
my @lines = <$fh>; |
|
Line 12123 sub fetch_dns_checksums {
|
Line 12763 sub fetch_dns_checksums {
|
| } |
} |
| |
|
| sub load_hosts_tab { |
sub load_hosts_tab { |
| my ($ignore_cache) = @_; |
my ($ignore_cache,$nocache) = @_; |
| &get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache); |
&get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache,$nocache); |
| open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); |
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); |
| my @config = <$config>; |
my @config = <$config>; |
| &parse_hosts_tab(\@config); |
&parse_hosts_tab(\@config); |
|
Line 12146 sub fetch_dns_checksums {
|
Line 12786 sub fetch_dns_checksums {
|
| } |
} |
| |
|
| sub all_names { |
sub all_names { |
| &load_hosts_tab() if (!$loaded); |
my ($ignore_cache,$nocache) = @_; |
| |
&load_hosts_tab($ignore_cache,$nocache) if (!$loaded); |
| |
|
| return %name_to_host; |
return %name_to_host; |
| } |
} |
|
Line 12268 sub fetch_dns_checksums {
|
Line 12909 sub fetch_dns_checksums {
|
| } |
} |
| |
|
| sub get_iphost { |
sub get_iphost { |
| my ($ignore_cache) = @_; |
my ($ignore_cache,$nocache) = @_; |
| |
|
| if (!$ignore_cache) { |
if (!$ignore_cache) { |
| if (%iphost) { |
if (%iphost) { |
|
Line 12292 sub fetch_dns_checksums {
|
Line 12933 sub fetch_dns_checksums {
|
| %old_name_to_ip = %{$ip_info->[1]}; |
%old_name_to_ip = %{$ip_info->[1]}; |
| } |
} |
| |
|
| my %name_to_host = &all_names(); |
my %name_to_host = &all_names($ignore_cache,$nocache); |
| foreach my $name (keys(%name_to_host)) { |
foreach my $name (keys(%name_to_host)) { |
| my $ip; |
my $ip; |
| if (!exists($name_to_ip{$name})) { |
if (!exists($name_to_ip{$name})) { |
|
Line 12317 sub fetch_dns_checksums {
|
Line 12958 sub fetch_dns_checksums {
|
| } |
} |
| push(@{$iphost{$ip}},@{$name_to_host{$name}}); |
push(@{$iphost{$ip}},@{$name_to_host{$name}}); |
| } |
} |
| &do_cache_new('iphost','iphost', |
unless ($nocache) { |
| [\%iphost,\%name_to_ip,\%lonid_to_ip], |
&do_cache_new('iphost','iphost', |
| 48*60*60); |
[\%iphost,\%name_to_ip,\%lonid_to_ip], |
| |
48*60*60); |
| |
} |
| |
|
| return %iphost; |
return %iphost; |
| } |
} |
|
Line 12836 escaped strings of the action recorded i
|
Line 13479 escaped strings of the action recorded i
|
| |
|
| =item * |
=item * |
| |
|
| allowed($priv,$uri,$symb,$role) : check for a user privilege; returns codes for allowed actions |
allowed($priv,$uri,$symb,$role,$clientip,$noblockcheck) : check for a user privilege; |
| |
returns codes for allowed actions. |
| |
|
| |
The first argument is required, all others are optional. |
| |
|
| |
$priv is the privilege being checked. |
| |
$uri contains additional information about what is being checked for access (e.g., |
| |
URL, course ID etc.). |
| |
$symb is the unique resource instance identifier in a course; if needed, |
| |
but not provided, it will be retrieved via a call to &symbread(). |
| |
$role is the role for which a priv is being checked (only used if priv is evb). |
| |
$clientip is the user's IP address (only used when checking for access to portfolio |
| |
files). |
| |
$noblockcheck, if true, skips calls to &has_comm_blocking() for the bre priv. This |
| |
prevents recursive calls to &allowed. |
| |
|
| F: full access |
F: full access |
| U,I,K: authentication modes (cxx only) |
U,I,K: authentication modes (cxx only) |
| '': forbidden |
'': forbidden |
| 1: user needs to choose course |
1: user needs to choose course |
| 2: browse allowed |
2: browse allowed |
| A: passphrase authentication needed |
A: passphrase authentication needed |
| |
B: access temporarily blocked because of a blocking event in a course. |
| |
|
| =item * |
=item * |
| |
|
|
Line 12861 in which case the null string is returne
|
Line 13520 in which case the null string is returne
|
| |
|
| =item * |
=item * |
| |
|
| definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom |
definerole($rolename,$sysrole,$domrole,$courole,$uname,$udom) : define role; |
| role rolename set privileges in format of lonTabs/roles.tab for system, domain, |
define a custom role rolename set privileges in format of lonTabs/roles.tab |
| and course level |
for system, domain, and course level. $uname and $udom are optional (current |
| |
user's username and domain will be used when either of $uname or $udom are absent. |
| |
|
| =item * |
=item * |
| |
|
|
Line 13067 Inputs:
|
Line 13727 Inputs:
|
| |
|
| =item $credits, number of credits student will earn from this class |
=item $credits, number of credits student will earn from this class |
| |
|
| |
=item $instsec, institutional course section code for student |
| |
|
| =back |
=back |
| |
|
| |
|
|
Line 13236 will be stored for query
|
Line 13898 will be stored for query
|
| |
|
| =item * |
=item * |
| |
|
| symbread($filename) : return symbolic list entry (filename argument optional); |
symbread($filename,$donotrecurse,$ignorecachednull,$checkforblock,$possibles) : |
| |
return symbolic list entry (all arguments optional). |
| |
|
| |
Args: filename is the filename (including path) for the file for which a symb |
| |
is required; donotrecurse, if true will prevent calls to allowed() being made |
| |
to check access status if more than one resource was found in the bighash |
| |
(see rev. 1.249) to avoid an infinite loop if an ambiguous resource is part of |
| |
a randompick); ignorecachednull, if true will prevent a symb of '' being |
| |
returned if $env{$cache_str} is defined as ''; checkforblock if true will |
| |
cause possible symbs to be checked to determine if they are subject to content |
| |
blocking, if so they will not be included as possible symbs; possibles is a |
| |
ref to a hash, which, as a side effect, will be populated with all possible |
| |
symbs (content blocking not tested). |
| |
|
| returns the data handle |
returns the data handle |
| |
|
| =item * |
=item * |
|
Line 13543 for course's uploaded content.
|
Line 14218 for course's uploaded content.
|
| =over |
=over |
| |
|
| =item |
=item |
| canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota, communityquota, textbookquota |
canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota, |
| |
communityquota, textbookquota |
| |
|
| =back |
=back |
| |
|
![[BACK]](/icons/back.gif){kind=icon}
Return to lonnet.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / lonnet / perl