|
version 1.1308, 2016/05/30 02:45:43
|
version 1.1344, 2017/05/09 03:04:32
|
|
Line 229 sub get_server_distarch {
|
Line 229 sub get_server_distarch {
|
| return; |
return; |
| } |
} |
| |
|
| |
sub get_servercerts_info { |
| |
my ($lonhost,$context) = @_; |
| |
my ($rep,$uselocal); |
| |
if (grep { $_ eq $lonhost } ¤t_machine_ids()) { |
| |
$uselocal = 1; |
| |
} |
| |
if (($context ne 'cgi') && ($uselocal)) { |
| |
my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0]; |
| |
if ($distro eq '') { |
| |
$uselocal = 0; |
| |
} elsif ($distro =~ /^(?:centos|redhat|scientific)(\d+)$/) { |
| |
if ($1 < 6) { |
| |
$uselocal = 0; |
| |
} |
| |
} |
| |
} |
| |
if ($uselocal) { |
| |
$rep = LONCAPA::Lond::server_certs(\%perlvar); |
| |
} else { |
| |
$rep=&reply('servercerts',$lonhost); |
| |
} |
| |
my ($result,%returnhash); |
| |
if (defined($lonhost)) { |
| |
if (!defined(&hostname($lonhost))) { |
| |
return; |
| |
} |
| |
} |
| |
if (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') || |
| |
($rep eq 'unknown_cmd')) { |
| |
$result = $rep; |
| |
} else { |
| |
$result = 'ok'; |
| |
my @pairs=split(/\&/,$rep); |
| |
foreach my $item (@pairs) { |
| |
my ($key,$value)=split(/=/,$item,2); |
| |
my $what = &unescape($key); |
| |
$returnhash{$what}=&thaw_unescape($value); |
| |
} |
| |
} |
| |
return ($result,\%returnhash); |
| |
} |
| |
|
| sub get_server_loncaparev { |
sub get_server_loncaparev { |
| my ($dom,$lonhost,$ignore_cache,$caller) = @_; |
my ($dom,$lonhost,$ignore_cache,$caller) = @_; |
| if (defined($lonhost)) { |
if (defined($lonhost)) { |
|
Line 608 sub transfer_profile_to_env {
|
Line 650 sub transfer_profile_to_env {
|
| sub check_for_valid_session { |
sub check_for_valid_session { |
| my ($r,$name,$userhashref) = @_; |
my ($r,$name,$userhashref) = @_; |
| my %cookies=CGI::Cookie->parse($r->header_in('Cookie')); |
my %cookies=CGI::Cookie->parse($r->header_in('Cookie')); |
| |
my ($linkname,$pubname); |
| if ($name eq '') { |
if ($name eq '') { |
| $name = 'lonID'; |
$name = 'lonID'; |
| |
$linkname = 'lonLinkID'; |
| |
$pubname = 'lonPubID'; |
| } |
} |
| my $lonid=$cookies{$name}; |
my $lonid=$cookies{$name}; |
| |
if (!$lonid) { |
| |
if (($name eq 'lonID') && ($ENV{'SERVER_PORT'} != 443) && ($linkname)) { |
| |
$lonid=$cookies{$linkname}; |
| |
} |
| |
if (!$lonid) { |
| |
if (($name eq 'lonID') && ($pubname)) { |
| |
$lonid=$cookies{$pubname}; |
| |
} |
| |
} |
| |
} |
| return undef if (!$lonid); |
return undef if (!$lonid); |
| |
|
| my $handle=&LONCAPA::clean_handle($lonid->value); |
my $handle=&LONCAPA::clean_handle($lonid->value); |
|
Line 1007 sub choose_server {
|
Line 1062 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 1279 sub get_lonbalancer_config {
|
Line 1334 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 1430 sub check_loadbalancing {
|
Line 1485 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 1788 sub get_dom {
|
Line 1845 sub get_dom {
|
| } |
} |
| } |
} |
| if ($udom && $uhome && ($uhome ne 'no_host')) { |
if ($udom && $uhome && ($uhome ne 'no_host')) { |
| my $rep=&reply("getdom:$udom:$namespace:$items",$uhome); |
my $rep; |
| |
if ($namespace =~ /^enc/) { |
| |
$rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome); |
| |
} else { |
| |
$rep=&reply("getdom:$udom:$namespace:$items",$uhome); |
| |
} |
| my %returnhash; |
my %returnhash; |
| if ($rep eq '' || $rep =~ /^error: 2 /) { |
if ($rep eq '' || $rep =~ /^error: 2 /) { |
| return %returnhash; |
return %returnhash; |
|
Line 1832 sub put_dom {
|
Line 1894 sub put_dom {
|
| $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; |
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; |
| } |
} |
| $items=~s/\&$//; |
$items=~s/\&$//; |
| return &reply("putdom:$udom:$namespace:$items",$uhome); |
if ($namespace =~ /^enc/) { |
| |
return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome); |
| |
} else { |
| |
return &reply("putdom:$udom:$namespace:$items",$uhome); |
| |
} |
| } else { |
} else { |
| &logthis("put_dom failed - no homeserver and/or domain"); |
&logthis("put_dom failed - no homeserver and/or domain"); |
| } |
} |
|
Line 1929 sub inst_directory_query {
|
Line 1995 sub inst_directory_query {
|
| &escape($srch->{'srchtype'}),$homeserver); |
&escape($srch->{'srchtype'}),$homeserver); |
| my $host=&hostname($homeserver); |
my $host=&hostname($homeserver); |
| if ($queryid !~/^\Q$host\E\_/) { |
if ($queryid !~/^\Q$host\E\_/) { |
| &logthis('instituional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom); |
&logthis('institutional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.' in domain '.$udom); |
| return; |
return; |
| } |
} |
| my $response = &get_query_reply($queryid); |
my $response = &get_query_reply($queryid); |
|
Line 2202 sub get_domain_defaults {
|
Line 2268 sub get_domain_defaults {
|
| 'requestcourses','inststatus', |
'requestcourses','inststatus', |
| 'coursedefaults','usersessions', |
'coursedefaults','usersessions', |
| 'requestauthor','selfenrollment', |
'requestauthor','selfenrollment', |
| 'coursecategories'],$domain); |
'coursecategories','ssl','autoenroll', |
| |
'trust','helpsettings'],$domain); |
| my @coursetypes = ('official','unofficial','community','textbook','placement'); |
my @coursetypes = ('official','unofficial','community','textbook','placement'); |
| 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 2211 sub get_domain_defaults {
|
Line 2278 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 2328 sub get_domain_defaults {
|
Line 2398 sub get_domain_defaults {
|
| $domdefaults{'catunauth'} = $domconfig{'coursecategories'}{'unauth'}; |
$domdefaults{'catunauth'} = $domconfig{'coursecategories'}{'unauth'}; |
| } |
} |
| } |
} |
| |
if (ref($domconfig{'ssl'}) eq 'HASH') { |
| |
if (ref($domconfig{'ssl'}{'replication'}) eq 'HASH') { |
| |
$domdefaults{'replication'} = $domconfig{'ssl'}{'replication'}; |
| |
} |
| |
if (ref($domconfig{'ssl'}{'connto'}) eq 'HASH') { |
| |
$domdefaults{'connect'} = $domconfig{'ssl'}{'connto'}; |
| |
} |
| |
if (ref($domconfig{'ssl'}{'connfrom'}) eq 'HASH') { |
| |
$domdefaults{'connect'} = $domconfig{'ssl'}{'connfrom'}; |
| |
} |
| |
} |
| |
if (ref($domconfig{'trust'}) eq 'HASH') { |
| |
my @prefixes = qw(content shared enroll othcoau coaurem domroles catalog reqcrs msg); |
| |
foreach my $prefix (@prefixes) { |
| |
if (ref($domconfig{'trust'}{$prefix}) eq 'HASH') { |
| |
$domdefaults{'trust'.$prefix} = $domconfig{'trust'}{$prefix}; |
| |
} |
| |
} |
| |
} |
| |
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; |
| } |
} |
| |
|
| |
sub course_portal_url { |
| |
my ($cnum,$cdom) = @_; |
| |
my $chome = &homeserver($cnum,$cdom); |
| |
my $hostname = &hostname($chome); |
| |
my $protocol = $protocol{$chome}; |
| |
$protocol = 'http' if ($protocol ne 'https'); |
| |
my %domdefaults = &get_domain_defaults($cdom); |
| |
my $firsturl; |
| |
if ($domdefaults{'portal_def'}) { |
| |
$firsturl = $domdefaults{'portal_def'}; |
| |
} else { |
| |
$firsturl = $protocol.'://'.$hostname; |
| |
} |
| |
return $firsturl; |
| |
} |
| |
|
| # --------------------------------------------------- Assign a key to a student |
# --------------------------------------------------- Assign a key to a student |
| |
|
| sub assign_access_key { |
sub assign_access_key { |
|
Line 2568 sub make_key {
|
Line 2682 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) whenever possible |
| if (exists($remembered{$id})) { |
if (exists($remembered{$remembered_id})) { |
| if ($debug) { &Apache::lonnet::logthis("Early return $id of $remembered{$id} "); } |
if ($debug) { &Apache::lonnet::logthis("Early return $remembered_id of $remembered{$remembered_id} "); } |
| $accessed{$id}=[&gettimeofday()]; |
$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 2592 sub is_cached_new {
|
Line 2708 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 2614 sub do_cache_new {
|
Line 2731 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 3090 sub can_edit_resource {
|
Line 3207 sub can_edit_resource {
|
| $forceedit = 1; |
$forceedit = 1; |
| } |
} |
| $cfile = $resurl; |
$cfile = $resurl; |
| } elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/exttools?$}) { |
} elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) { |
| $incourse = 1; |
$incourse = 1; |
| if ($env{'form.forceedit'}) { |
if ($env{'form.forceedit'}) { |
| $forceview = 1; |
$forceview = 1; |
|
Line 3122 sub can_edit_resource {
|
Line 3239 sub can_edit_resource {
|
| $forceedit = 1; |
$forceedit = 1; |
| } |
} |
| $cfile = $resurl; |
$cfile = $resurl; |
| } elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/exttools?$}) && ($env{'form.folderpath'} =~ /^supplemental/)) { |
} elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) && ($env{'form.folderpath'} =~ /^supplemental/)) { |
| $incourse = 1; |
$incourse = 1; |
| if ($env{'form.forceedit'}) { |
if ($env{'form.forceedit'}) { |
| $forceview = 1; |
$forceview = 1; |
|
Line 3140 sub can_edit_resource {
|
Line 3257 sub can_edit_resource {
|
| } else { |
} else { |
| $cfile = $env{'form.suppurl'}; |
$cfile = $env{'form.suppurl'}; |
| my $escfile = &unescape($cfile); |
my $escfile = &unescape($cfile); |
| if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/exttools?$}) { |
if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) { |
| $cfile = '/adm/wrapper'.$escfile; |
$cfile = '/adm/wrapper'.$escfile; |
| } else { |
} else { |
| $escfile =~ s{^http://}{}; |
$escfile =~ s{^http://}{}; |
|
Line 4027 sub flushcourselogs {
|
Line 4144 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 4042 sub flushcourselogs {
|
Line 4159 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 4165 sub userrolelog {
|
Line 4291 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 4392 sub get_my_roles {
|
Line 4518 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 4632 sub get_domain_roles {
|
Line 4947 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 5486 sub rolesinit {
|
Line 5816 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 5524 sub custom_roleprivs {
|
Line 5855 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 5532 sub custom_roleprivs {
|
Line 5867 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 5566 sub set_userprivs {
|
Line 5943 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 5613 sub set_userprivs {
|
Line 5991 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 5621 sub set_userprivs {
|
Line 6000 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 5666 sub role_status {
|
Line 6045 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 ".$spec); |
| } |
} |
| } |
} |
| $$tstatus = 'is'; |
$$tstatus = 'is'; |
|
Line 5744 sub delete_env_groupprivs {
|
Line 6124 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 ".$spec); |
| 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 5926 sub currentdump {
|
Line 6323 sub currentdump {
|
| # |
# |
| my %returnhash=(); |
my %returnhash=(); |
| # |
# |
| if ($rep eq "unknown_cmd") { |
if ($rep eq 'unknown_cmd') { |
| # an old lond will not know currentdump |
# an old lond will not know currentdump |
| # Do a dump and make it look like a currentdump |
# Do a dump and make it look like a currentdump |
| my @tmp = &dumpstore($courseid,$sdom,$sname,'.'); |
my @tmp = &dumpstore($courseid,$sdom,$sname,'.'); |
|
Line 6160 sub tmpget {
|
Line 6557 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 6858 sub allowed {
|
Line 7257 sub allowed {
|
| |
|
| if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; } |
if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; } |
| # Free bre access to adm and meta resources |
# Free bre access to adm and meta resources |
| if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$})) |
if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard|ext\.tool)$})) |
| || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) |
|| (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) |
| && ($priv eq 'bre')) { |
&& ($priv eq 'bre')) { |
| return 'F'; |
return 'F'; |
|
Line 7346 sub constructaccess {
|
Line 7745 sub constructaccess {
|
| my ($ownername,$ownerdomain,$ownerhome); |
my ($ownername,$ownerdomain,$ownerhome); |
| |
|
| ($ownerdomain,$ownername) = |
($ownerdomain,$ownername) = |
| ($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)(?:/daxepage|/daxeopen)?/priv/($match_domain)/($match_username)/}); |
($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)(?:/daxepage|/daxeopen)?/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 7367 sub constructaccess {
|
Line 7766 sub constructaccess {
|
| $ownerhome = &homeserver($ownername,$ownerdomain); |
$ownerhome = &homeserver($ownername,$ownerdomain); |
| return ($ownername,$ownerdomain,$ownerhome); |
return ($ownername,$ownerdomain,$ownerhome); |
| } |
} |
| |
if ($env{'request.course.id'}) { |
| |
if (($ownername eq $env{'course.'.$env{'request.course.id'}.'.num'}) && |
| |
($ownerdomain eq $env{'course.'.$env{'request.course.id'}.'.domain'})) { |
| |
if (&allowed('mdc',$env{'request.course.id'})) { |
| |
$ownerhome = $env{'course.'.$env{'request.course.id'}.'.home'}; |
| |
return ($ownername,$ownerdomain,$ownerhome); |
| |
} |
| |
} |
| |
} |
| } |
} |
| |
|
| # We don't have any access right now. If we are not possibly going to do anything about this, |
# We don't have any access right now. If we are not possibly going to do anything about this, |
|
Line 7519 sub get_commblock_resources {
|
Line 7927 sub get_commblock_resources {
|
| } |
} |
| } |
} |
| } |
} |
| if ($interval[0] =~ /^(\d+/)) { |
if ($interval[0] =~ /^(\d+)/) { |
| my $timelimit = $1; |
my $timelimit = $1; |
| my $first_access; |
my $first_access; |
| if ($type eq 'resource') { |
if ($type eq 'resource') { |
|
Line 7685 sub get_symb_from_alias {
|
Line 8093 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 7713 sub definerole {
|
Line 8121 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 7799 sub update_allusers_table {
|
Line 8215 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 7820 sub fetch_enrollment_query {
|
Line 8238 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 7865 sub fetch_enrollment_query {
|
Line 8283 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(0.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 8293 sub auto_crsreq_update {
|
Line 8717 sub auto_crsreq_update {
|
| } |
} |
| |
|
| sub auto_export_grades { |
sub auto_export_grades { |
| my ($cnum,$cdom,$gradesref) = @_; |
my ($cdom,$cnum,$inforef,$gradesref) = @_; |
| return; |
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 { |
sub check_instcode_cloning { |
|
Line 8736 sub assignrole {
|
Line 9182 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 9041 sub modifyuser {
|
Line 9488 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 9057 sub modifystudent {
|
Line 9504 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 9110 sub modify_student_enrollment {
|
Line 9557 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 10096 sub dirlist {
|
Line 10543 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 10169 sub stat_file {
|
Line 10633 sub stat_file {
|
| return (); |
return (); |
| } |
} |
| |
|
| |
# --------------------------------------------------------- recursedirs |
| |
# Recursive function to traverse either a specific user's Authoring Space |
| |
# or corresponding Published Resource Space, and populate the hash ref: |
| |
# $dirhashref with URLs of all directories, and if $filehashref hash |
| |
# ref arg is provided, the URLs of any files, excluding versioned, .meta, |
| |
# or .rights files in resource space, and .meta, .save, .log, and .bak |
| |
# files in Authoring Space. |
| |
# |
| |
# Inputs: |
| |
# |
| |
# $is_home - true if current server is home server for user's space |
| |
# $context - either: priv, or res respectively for Authoring or Resource Space. |
| |
# $docroot - Document root (i.e., /home/httpd/html |
| |
# $toppath - Top level directory (i.e., /res/$dom/$uname or /priv/$dom/$uname |
| |
# $relpath - Current path (relative to top level). |
| |
# $dirhashref - reference to hash to populate with URLs of directories (Required) |
| |
# $filehashref - reference to hash to populate with URLs of files (Optional) |
| |
# |
| |
# Returns: nothing |
| |
# |
| |
# Side Effects: populates $dirhashref, and $filehashref (if provided). |
| |
# |
| |
# Currently used by interface/londocs.pm to create linked select boxes for |
| |
# directory and filename to import a Course "Author" resource into a course, and |
| |
# also to create linked select boxes for Authoring Space and Directory to choose |
| |
# save location for creation of a new "standard" problem from the Course Editor. |
| |
# |
| |
|
| |
sub recursedirs { |
| |
my ($is_home,$context,$docroot,$toppath,$relpath,$dirhashref,$filehashref) = @_; |
| |
return unless (ref($dirhashref) eq 'HASH'); |
| |
my $currpath = $docroot.$toppath; |
| |
if ($relpath) { |
| |
$currpath .= "/$relpath"; |
| |
} |
| |
my $savefile; |
| |
if (ref($filehashref)) { |
| |
$savefile = 1; |
| |
} |
| |
if ($is_home) { |
| |
if (opendir(my $dirh,$currpath)) { |
| |
foreach my $item (sort { lc($a) cmp lc($b) } grep(!/^\.+$/,readdir($dirh))) { |
| |
next if ($item eq ''); |
| |
if (-d "$currpath/$item") { |
| |
my $newpath; |
| |
if ($relpath) { |
| |
$newpath = "$relpath/$item"; |
| |
} else { |
| |
$newpath = $item; |
| |
} |
| |
$dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1; |
| |
&recursedirs($is_home,$context,$docroot,$toppath,$newpath,$dirhashref,$filehashref); |
| |
} elsif ($savefile) { |
| |
if ($context eq 'priv') { |
| |
unless ($item =~ /\.(meta|save|log|bak|DS_Store)$/) { |
| |
$filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1; |
| |
} |
| |
} else { |
| |
unless (($item =~ /\.meta$/) || ($item =~ /\.\d+\.\w+$/) || ($item =~ /\.rights$/)) { |
| |
$filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
closedir($dirh); |
| |
} |
| |
} else { |
| |
my ($dirlistref,$listerror) = |
| |
&dirlist($toppath.$relpath); |
| |
my @dir_lines; |
| |
my $dirptr=16384; |
| |
if (ref($dirlistref) eq 'ARRAY') { |
| |
foreach my $dir_line (sort |
| |
{ |
| |
my ($afile)=split('&',$a,2); |
| |
my ($bfile)=split('&',$b,2); |
| |
return (lc($afile) cmp lc($bfile)); |
| |
} (@{$dirlistref})) { |
| |
my ($item,$dom,undef,$testdir,undef,undef,undef,undef,$size,undef,$mtime,undef,undef,undef,$obs,undef) = |
| |
split(/\&/,$dir_line,16); |
| |
$item =~ s/\s+$//; |
| |
next if (($item =~ /^\.\.?$/) || ($obs)); |
| |
if ($dirptr&$testdir) { |
| |
my $newpath; |
| |
if ($relpath) { |
| |
$newpath = "$relpath/$item"; |
| |
} else { |
| |
$relpath = '/'; |
| |
$newpath = $item; |
| |
} |
| |
$dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1; |
| |
&recursedirs($is_home,$context,$docroot,$toppath,$newpath,$dirhashref,$filehashref); |
| |
} elsif ($savefile) { |
| |
if ($context eq 'priv') { |
| |
unless ($item =~ /\.(meta|save|log|bak|DS_Store)$/) { |
| |
$filehashref->{$relpath}{$item} = 1; |
| |
} |
| |
} else { |
| |
unless (($item =~ /\.meta$/) || ($item =~ /\.\d+\.\w+$/)) { |
| |
$filehashref->{$relpath}{$item} = 1; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| # -------------------------------------------------------- Value of a Condition |
# -------------------------------------------------------- Value of a Condition |
| |
|
| # gets the value of a specific preevaluated condition |
# gets the value of a specific preevaluated condition |
|
Line 10332 sub get_userresdata {
|
Line 10905 sub get_userresdata {
|
| # Parameters: |
# Parameters: |
| # $name - Course/user name. |
# $name - Course/user name. |
| # $domain - Name of the domain the user/course is registered on. |
# $domain - Name of the domain the user/course is registered on. |
| # $type - Type of thing $name is (must be 'course' or 'user' |
# $type - Type of thing $name is (must be 'course' or 'user') |
| # $mapp - decluttered URL of enclosing map |
# $mapp - decluttered URL of enclosing map |
| # $recursed - Ref to scalar -- set to 1, if nested maps have been recursed. |
# $recursed - Ref to scalar -- set to 1, if nested maps have been recursed. |
| # $recurseup - Ref to array of map URLs, starting with map containing |
# $recurseup - Ref to array of map URLs, starting with map containing |
|
Line 10392 sub get_domain_ltitools {
|
Line 10965 sub get_domain_ltitools {
|
| my %domconfig = &get_dom('configuration',['ltitools'],$cdom); |
my %domconfig = &get_dom('configuration',['ltitools'],$cdom); |
| if (ref($domconfig{'ltitools'}) eq 'HASH') { |
if (ref($domconfig{'ltitools'}) eq 'HASH') { |
| %ltitools = %{$domconfig{'ltitools'}}; |
%ltitools = %{$domconfig{'ltitools'}}; |
| |
my %encdomconfig = &get_dom('encconfig',['ltitools'],$cdom); |
| |
if (ref($encdomconfig{'ltitools'}) eq 'HASH') { |
| |
foreach my $id (keys(%ltitools)) { |
| |
if (ref($encdomconfig{'ltitools'}{$id}) eq 'HASH') { |
| |
foreach my $item ('key','secret') { |
| |
$ltitools{$id}{$item} = $encdomconfig{'ltitools'}{$id}{$item}; |
| |
} |
| |
} |
| |
} |
| |
} |
| } |
} |
| my $cachetime = 24*60*60; |
my $cachetime = 24*60*60; |
| &do_cache_new('ltitools',$cdom,\%ltitools,$cachetime); |
&do_cache_new('ltitools',$cdom,\%ltitools,$cachetime); |
|
Line 10901 sub metadata {
|
Line 11484 sub metadata {
|
| # if it is a non metadata possible uri return quickly |
# if it is a non metadata possible uri return quickly |
| if (($uri eq '') || |
if (($uri eq '') || |
| (($uri =~ m|^/*adm/|) && |
(($uri =~ m|^/*adm/|) && |
| ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard|exttools?)$})) || |
($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard|ext\.tool)$})) || |
| ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) { |
($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) { |
| return undef; |
return undef; |
| } |
} |
|
Line 12434 sub clutter {
|
Line 13017 sub clutter {
|
| # &logthis("Got a blank emb style"); |
# &logthis("Got a blank emb style"); |
| } |
} |
| } |
} |
| } elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/exttools?$}) { |
} elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/ext\.tool$}) { |
| $thisfn='/adm/wrapper'.$thisfn; |
$thisfn='/adm/wrapper'.$thisfn; |
| } |
} |
| return $thisfn; |
return $thisfn; |
|
Line 12706 sub fetch_dns_checksums {
|
Line 13289 sub fetch_dns_checksums {
|
| &purge_remembered(); |
&purge_remembered(); |
| &reset_domain_info(); |
&reset_domain_info(); |
| &reset_hosts_ip_info(); |
&reset_hosts_ip_info(); |
| |
undef(%internetdom); |
| undef(%name_to_host); |
undef(%name_to_host); |
| undef(%hostname); |
undef(%hostname); |
| undef(%hostdom); |
undef(%hostdom); |
|
Line 12748 sub fetch_dns_checksums {
|
Line 13332 sub fetch_dns_checksums {
|
| return %hostdom; |
return %hostdom; |
| } |
} |
| |
|
| |
sub all_host_intdom { |
| |
&load_hosts_tab() if (!$loaded); |
| |
return %internetdom; |
| |
} |
| |
|
| sub is_library { |
sub is_library { |
| &load_hosts_tab() if (!$loaded); |
&load_hosts_tab() if (!$loaded); |
| |
|
|
Line 13501 in which case the null string is returne
|
Line 14090 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 13707 Inputs:
|
Line 14297 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 |
| |
|
| |
|
![[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